-;;; allout.el --- Extensive outline mode for use alone and with other modes.
-
-;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
-
-;; Author: Ken Manheimer <klm@nist.gov>
-;; Maintainer: Ken Manheimer <klm@nist.gov>
-;; Created: Dec 1991 - first release to usenet
-;; Version: Id: allout.el,v 4.3 1994/05/12 17:43:08 klm Exp ||
-;; Keywords: outline mode
-
-;; 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; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;;_* Commentary:
-
-;; Allout outline mode provides extensive outline formatting and
-;; manipulation capabilities, subsuming and well beyond that of
-;; standard emacs outline mode. It is specifically aimed at
-;; supporting outline structuring and manipulation of syntax-
-;; sensitive text, eg programming languages. (For an example, see the
-;; allout code itself, which is organized in outline structure.)
-;;
-;; It also includes such things as topic-oriented repositioning, cut, and
-;; paste; integral outline exposure-layout; incremental search with
-;; dynamic exposure/concealment of concealed text; automatic topic-number
-;; maintenance; and many other features.
-;;
-;; See the docstring of the variables `outline-layout' and
-;; `outline-auto-activation' for details on automatic activation of
-;; allout outline-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 301 975-3539
-;;ken.manheimer@nist.gov FAX: 301 963-9137
-;;
-;;Computer Systems and Communications Division
-;;
-;; Nat'l Institute of Standards and Technology
-;; Technology A151
-;; Gaithersburg, MD 20899
-
-;;;_* Provide
-(provide 'outline)
-(provide 'allout)
-
-;;;_* USER CUSTOMIZATION VARIABLES:
-
-;;;_ + Layout, Mode, and Topic Header Configuration
-
-;;;_ = outline-auto-activation
-(defvar outline-auto-activation nil
- "*Regulates auto-activation modality of allout outlines - see `outline-init'.
-
-Setq-default by `outline-init' to regulate whether or not allout
-outline mode is automatically activated when the buffer-specific
-variable `outline-layout' is non-nil, and whether or not the layout
-dictated by `outline-layout' should be imposed on mode activation.
-
-With value `t', auto-mode-activation and auto-layout are enabled.
-\(This also depends on `outline-find-file-hooks' being installed in
-`find-file-hooks', which is also done by `outline-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 `outline-init' for the proper interface to
-this variable.")
-;;;_ = outline-layout
-(defvar outline-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 outline-mode. Any non-nil value
-will automatically trigger allout outline-mode, provided `outline-
-init' has been called to enable it.
-
-See the docstring for `outline-init' for details on setting up for
-auto-mode-activation, and for `outline-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:
-;;;outline-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
-`\(outline-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 `outline-use-mode-specific-
-leader', which see.")
-(make-variable-buffer-local 'outline-layout)
-
-;;;_ = outline-header-prefix
-(defvar outline-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 outline-primary-bullet. Many
-outlines start at level 2 to avoid this discrepancy.")
-(make-variable-buffer-local 'outline-header-prefix)
-;;;_ = outline-primary-bullet
-(defvar outline-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 outline-*-bullets-string vars.
-
-The value of an asterisk ('*') provides for backwards compatibility
-with the original emacs outline mode. See outline-plain-bullets-string
-and outline-distinctive-bullets-string for the range of available
-bullets.")
-(make-variable-buffer-local 'outline-primary-bullet)
-;;;_ = outline-plain-bullets-string
-(defvar outline-plain-bullets-string (concat outline-primary-bullet
- "+-:.;,")
- "*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, ']', as a bullet.
-
-Outline mode has to be reactivated in order for changes to the value
-of this var to take effect.")
-(make-variable-buffer-local 'outline-plain-bullets-string)
-;;;_ = outline-distinctive-bullets-string
-(defvar outline-distinctive-bullets-string "=>([{}&!?#%\"X@$~\\"
- "*Persistent outline header bullets used to distinguish special topics.
-
-These bullets are not offered among the regular, level-specific
-rotation, and are not altered by automatic rebulleting, as when
-shifting the level of a topic. See `outline-plain-bullets-string' for
-the selection of alternating bullets.
-
-You must run 'set-outline-regexp' in order for changes
-to the value of this var to effect outline-mode operation.
-
-DO NOT include the close-square-bracket, ']', on either of the bullet
-strings.")
-(make-variable-buffer-local 'outline-distinctive-bullets-string)
-
-;;;_ = outline-use-mode-specific-leader
-(defvar outline-use-mode-specific-leader t
- "*When non-nil, use mode-specific topic-header prefixes.
-
-Allout outline mode will use the mode-specific `outline-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 `outline-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 `outline-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 `outline-mode-leaders' to override this behavior, when
-incorrect.\]")
-;;;_ = outline-mode-leaders
-(defvar outline-mode-leaders '()
- "Specific outline-prefix leading strings per major modes.
-
-Entries will be used in the stead (or lieu) of mode-specific
-comment-start strings. See also `outline-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.")
-
-;;;_ = outline-old-style-prefixes
-(defvar outline-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.")
-(make-variable-buffer-local 'outline-old-style-prefixes)
-;;;_ = outline-stylish-prefixes - alternating bullets
-(defvar outline-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 outline-old-style-prefixes
-is non-nil.")
-(make-variable-buffer-local 'outline-stylish-prefixes)
-
-;;;_ = outline-numbered-bullet
-(defvar outline-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.")
-(make-variable-buffer-local 'outline-numbered-bullet)
-;;;_ = outline-file-xref-bullet
-(defvar outline-file-xref-bullet "@"
- "*Bullet signifying file cross-references, for `outline-resolve-xref'.
-
-Set this var to the bullet you want to use for file cross-references.
-Set it 'nil' if you want to inhibit this capability.")
-
-;;;_ + LaTeX formatting
-;;;_ - outline-number-pages
-(defvar outline-number-pages nil
- "*Non-nil turns on page numbering for LaTeX formatting of an outline.")
-;;;_ - outline-label-style
-(defvar outline-label-style "\\large\\bf"
- "*Font and size of labels for LaTeX formatting of an outline.")
-;;;_ - outline-head-line-style
-(defvar outline-head-line-style "\\large\\sl "
- "*Font and size of entries for LaTeX formatting of an outline.")
-;;;_ - outline-body-line-style
-(defvar outline-body-line-style " "
- "*Font and size of entries for LaTeX formatting of an outline.")
-;;;_ - outline-title-style
-(defvar outline-title-style "\\Large\\bf"
- "*Font and size of titles for LaTeX formatting of an outline.")
-;;;_ - outline-title
-(defvar outline-title '(or buffer-file-name (current-buffer-name))
- "*Expression to be evaluated to determine the title for LaTeX
-formatted copy.")
-;;;_ - outline-line-skip
-(defvar outline-line-skip ".05cm"
- "*Space between lines for LaTeX formatting of an outline.")
-;;;_ - outline-indent
-(defvar outline-indent ".3cm"
- "*LaTeX formatted depth-indent spacing.")
-
-;;;_ + Miscellaneous customization
-
-;;;_ = outline-keybindings-list
-;;; You have to reactivate outline-mode - '(outline-mode t)' - to
-;;; institute changes to this var.
-(defvar outline-keybindings-list ()
- "*List of outline-mode key / function bindings.
-
-These bindings will be locally bound on the outline-mode-map. The
-keys will be prefixed by outline-command-prefix, unless the cell
-contains a third, no-nil element, in which case the initial string
-will be used as is.")
-(setq outline-keybindings-list
- '(
- ; Motion commands:
- ("?t" outline-latexify-exposed)
- ("\C-n" outline-next-visible-heading)
- ("\C-p" outline-previous-visible-heading)
- ("\C-u" outline-up-current-level)
- ("\C-f" outline-forward-current-level)
- ("\C-b" outline-backward-current-level)
- ("\C-a" outline-beginning-of-current-entry)
- ("\C-e" outline-end-of-current-entry)
- ;;("\C-n" outline-next-line-or-topic)
- ;;("\C-p" outline-previous-line-or-topic)
- ; Exposure commands:
- ("\C-i" outline-show-children)
- ("\C-s" outline-show-current-subtree)
- ("\C-h" outline-hide-current-subtree)
- ("\C-o" outline-show-current-entry)
- ("!" outline-show-all)
- ; Alteration commands:
- (" " outline-open-sibtopic)
- ("." outline-open-subtopic)
- ("," outline-open-supertopic)
- ("'" outline-shift-in)
- (">" outline-shift-in)
- ("<" outline-shift-out)
- ("\C-m" outline-rebullet-topic)
- ("*" outline-rebullet-current-heading)
- ("#" outline-number-siblings)
- ("\C-k" outline-kill-line t)
- ("\C-y" outline-yank t)
- ("\M-y" outline-yank-pop t)
- ("\C-k" outline-kill-topic)
- ; Miscellaneous commands:
- ("\C-@" outline-mark-topic)
- ("@" outline-resolve-xref)
- ("?c" outline-copy-exposed)))
-
-;;;_ = outline-command-prefix
-(defvar outline-command-prefix "\C-c"
- "*Key sequence to be used as prefix for outline mode command key bindings.")
-
-;;;_ = outline-enwrap-isearch-mode
-(defvar outline-enwrap-isearch-mode t
- "*Set non-nil to enable automatic exposure of concealed isearch targets.
-
-If non-nil, isearch will expose hidden text encountered in the course
-of a search, and to reconceal it if the search is continued past it.")
-
-;;;_ = outline-use-hanging-indents
-(defvar outline-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.]")
-(make-variable-buffer-local 'outline-use-hanging-indents)
-
-;;;_ = outline-reindent-bodies
-(defvar outline-reindent-bodies (if outline-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.")
-
-(make-variable-buffer-local 'outline-reindent-bodies)
-
-;;;_ = outline-inhibit-protection
-(defvar outline-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 outline-mode activation, so you may have to
-deactivate and then reactivate the mode if you want to toggle the
-behavior.")
-
-;;;_* CODE - no user customizations below.
-
-;;;_ #1 Internal Outline Formatting and Configuration
-;;;_ - Version
-;;;_ = outline-version
-(defvar outline-version
- (let ((rcs-rev "Revision: 4.3"))
- (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)")
-;;;_ > outline-version
-(defun outline-version (&optional here)
- "Return string describing the loaded outline version."
- (interactive "P")
- (let ((msg (concat "Allout Outline Mode v " outline-version)))
- (if here (insert-string msg))
- (message "%s" msg)
- msg))
-;;;_ - 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 produced from the elements of 'outline-plain-bullets-string'
-and 'outline-distinctive-bullets-string'.")
-(make-variable-buffer-local 'outline-bullets-string)
-;;;_ = outline-bullets-string-len
-(defvar outline-bullets-string-len 0
- "Length of current buffers' outline-plain-bullets-string.")
-(make-variable-buffer-local 'outline-bullets-string-len)
-;;;_ = 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, for headers at beginning of buffer.
-\(match-beginning 2) and (match-end 2) delimit the prefix.")
-(make-variable-buffer-local 'outline-bob-regexp)
-;;;_ = outline-header-subtraction
-(defvar outline-header-subtraction (1- (length outline-header-prefix))
- "Outline-header prefix length to subtract when computing topic depth.")
-(make-variable-buffer-local 'outline-header-subtraction)
-;;;_ = outline-plain-bullets-string-len
-(defvar outline-plain-bullets-string-len (length outline-plain-bullets-string)
- "Length of outline-plain-bullets-string, updated by set-outline-regexp.")
-(make-variable-buffer-local 'outline-plain-bullets-string-len)
-
-
-;;;_ X outline-reset-header-lead (header-lead)
-(defun outline-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))
-;;;_ X 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."
-
- (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)
- header-lead)
-;;;_ > outline-infer-header-lead ()
-(defun outline-infer-header-lead ()
- "Determine appropriate `outline-header-prefix'.
-
-Works according to settings of:
-
- `comment-start'
- `outline-header-prefix' (default)
- `outline-use-mode-specific-leader'
-and `outline-mode-leaders'.
-
-Apply this via \(re\)activation of `outline-mode', rather than
-invoking it directly."
- (let* ((use-leader (and (boundp 'outline-use-mode-specific-leader)
- (if (or (stringp outline-use-mode-specific-leader)
- (memq outline-use-mode-specific-leader
- '(outline-mode-leaders
- comment-start
- t)))
- outline-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 outline-mode-leaders))
- ;; Get it from outline mode leaders?
- (cdr (assq major-mode outline-mode-leaders)))
- ;; ... didn't get from outline-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 outline-header-prefix)
- nil ; no change, nothing to do.
- (setq outline-header-prefix leader)
- outline-header-prefix))))
-;;;_ > outline-infer-body-reindent ()
-(defun outline-infer-body-reindent ()
- "Determine proper setting for `outline-reindent-bodies'.
-
-Depends on default setting of `outline-reindent-bodies' \(which see)
-and presence of setting for `comment-start', to tell whether the
-file is programming code."
- (if (and outline-reindent-bodies
- comment-start
- (not (eq 'force outline-reindent-bodies)))
- (setq outline-reindent-bodies nil)))
-;;;_ > set-outline-regexp ()
-(defun set-outline-regexp ()
- "Generate proper topic-header regexp form for outline functions.
-
-Works with respect to `outline-plain-bullets-string' and
-`outline-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))
- cur-string
- cur-len
- cur-char
- cur-char-string
- index
- new-string)
- (while strings
- (setq new-string "") (setq index 0)
- (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
- (cond
- ; Single dash would denote a
- ; sequence, repeated denotes
- ; a dash:
- ((eq cur-char ?-) "--")
- ; literal close-square-bracket
- ; doesn't work right in the
- ; expr, exclude it:
- ((eq cur-char ?\]) "")
- (t (regexp-quote (char-to-string cur-char))))))
- (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
- "[ \t]*["
- outline-bullets-string
- "]\\)\\|\\"
- outline-primary-bullet
- "+\\|\^l"))
- (setq outline-line-boundary-regexp
- (concat "\\([\n\r]\\)\\(" outline-regexp "\\)"))
- (setq outline-bob-regexp
- (concat "\\(\\`\\)\\(" outline-regexp "\\)"))
- )
-;;;_ - Key bindings
-;;;_ = outline-mode-map
-(defvar outline-mode-map nil "Keybindings for (allout) outline minor mode.")
-;;;_ > produce-outline-mode-map (keymap-alist &optional base-map)
-(defun produce-outline-mode-map (keymap-list &optional base-map)
- "Produce keymap for use as outline-mode-map, from keymap-list.
-
-Built on top of optional BASE-MAP, or empty sparse map if none specified.
-See doc string for outline-keybindings-list for format of binding list."
- (let ((map (or base-map (make-sparse-keymap))))
- (mapcar (lambda (cell)
- (apply 'define-key map (if (null (cdr (cdr cell)))
- (cons (concat outline-command-prefix
- (car cell))
- (cdr cell))
- (list (car cell) (car (cdr cell))))))
- keymap-list)
- map))
-;;;_ = outline-prior-bindings - being deprecated.
-(defvar outline-prior-bindings nil
- "Variable for use in V18, with outline-added-bindings, for
-resurrecting, on mode deactivation, bindings that existed before
-activation. Being deprecated.")
-;;;_ = outline-added-bindings - being deprecated
-(defvar outline-added-bindings nil
- "Variable for use in V18, with outline-prior-bindings, for
-resurrecting, on mode deactivation, bindings that existed before
-activation. Being deprecated.")
-;;;_ - Mode-Specific Variable Maintenance Utilities
-;;;_ = outline-mode-prior-settings
-(defvar outline-mode-prior-settings nil
- "Internal outline mode use; 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 or resumes settings over outline-mode activation/deactivation.
-
-First arg is NAME of variable affected. Optional second arg is list
-containing outline-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 outline-mode-prior-settings))
- prior-capsule ; By 'capsule' i mean a list
- ; containing a value, so we can
- ; distinguish nil from no value.
- )
-
- (if value
-
- ;; Registering:
- (progn
- (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
- (cons (list name
- (if (boundp name) (list (symbol-value name))))
- outline-mode-prior-settings)))
- ; And impose the new value, locally:
- (progn (make-local-variable name)
- (set name (car value))))
-
- ;; Relinquishing:
- (if (not on-list)
-
- ;; Oops, not registered - leave it be:
- nil
-
- ;; Some registration:
- ; reestablish it:
- (setq prior-capsule (car (cdr on-list)))
- (if prior-capsule
- (set name (car prior-capsule)) ; Some prior value - reestablish it.
- (makunbound name)) ; Previously unbound - demolish var.
- ; Remove registration:
- (let (rebuild)
- (while outline-mode-prior-settings
- (if (not (eq (car outline-mode-prior-settings)
- on-list))
- (setq rebuild
- (cons (car outline-mode-prior-settings)
- rebuild)))
- (setq outline-mode-prior-settings
- (cdr outline-mode-prior-settings)))
- (setq outline-mode-prior-settings rebuild)))))
- )
-;;;_ - Mode-specific incidentals
-;;;_ = outline-during-write-cue nil
-(defvar outline-during-write-cue nil
- "Used to inhibit outline change-protection during file write.
-
-See also `outline-post-command-business', `outline-write-file-hook',
-`outline-before-change-protect', and `outline-post-command-business'
-functions.")
-;;;_ = outline-override-protect nil
-(defvar outline-override-protect nil
- "Used in outline-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 'outline-override-protect)
-;;;_ > outline-unprotected (expr)
-(defmacro outline-unprotected (expr)
- "Evaluate EXPRESSION with `outline-override-protect' let-bound 't'."
- (` (let ((outline-override-protect t))
- (, expr))))
-;;;_ = outline-undo-aggregation
-(defvar outline-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-function and undo interact.")
-(make-variable-buffer-local 'outline-undo-aggregation)
-;;;_ = file-var-bug hack
-(defvar outline-v18/9-file-var-hack nil
- "Horrible hack used to prevent invalid multiple triggering of outline
-mode from prop-line file-var activation. Used by outline-mode function
-to track repeats.")
-;;;_ > outline-write-file-hook ()
-(defun outline-write-file-hook ()
- "In outline mode, run as a local-write-file-hooks activity.
-
-Currently just sets 'outline-during-write-cue', so outline-change-
-protection knows to keep inactive during file write."
- (setq outline-during-write-cue t)
- nil)
-
-;;;_ #2 Mode activation
-;;;_ = outline-mode
-(defvar outline-mode () "Allout outline mode minor-mode flag.")
-(make-variable-buffer-local 'outline-mode)
-;;;_ > outline-mode-p ()
-(defmacro outline-mode-p ()
- "Return t if outline-mode is active in current buffer."
- 'outline-mode)
-;;;_ = outline-explicitly-deactivated
-(defvar outline-explicitly-deactivated nil
- "Outline-mode was last deliberately deactivated.
-So outline-post-command-business should not reactivate it...")
-(make-variable-buffer-local 'outline-explicitly-deactivated)
-;;;_ > outline-init (&optional mode)
-(defun outline-init (&optional mode)
- "Prime outline-mode to enable/disable auto-activation, wrt `outline-layout'.
-
-MODE is one of the following symbols:
-
- - nil \(or no argument) deactivate auto-activation/layou;
- - '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 `outline-layout' variable. (See `outline-layout' and
-`outline-expose-topic' docstrings for more details on auto layout).
-
-`outline-init' works by setting up (or removing) the outline-mode
-find-file-hook, and giving `outline-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)
-\(outline-init t)"
-
- (interactive)
- (if (interactive-p)
- (progn
- (setq mode
- (completing-read
- (concat "Select outline auto setup mode "
- "(empty for report, ? for options) ")
- '(("nil")("full")("activate")("deactivate")
- ("ask") ("report") (""))
- nil
- t))
- (if (string= mode "")
- (setq mode 'report)
- (setq mode (intern-soft mode)))))
- (let
- ;; convenience aliases, for consistent ref to respective vars:
- ((hook 'outline-find-file-hook)
- (curr-mode 'outline-auto-activation))
-
- (cond ((not mode)
- (setq find-file-hooks (delq hook find-file-hooks))
- (if (interactive-p)
- (message "Allout outline mode auto-activation inhibited.")))
- ((eq mode 'report)
- (if (not (memq hook find-file-hooks))
- (outline-init nil)
- ;; Just punt and use the reports from each of the modes:
- (outline-init (symbol-value curr-mode))))
- (t (add-hook 'find-file-hooks 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:
- (outline-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)))))))
-
-;;;_ > outline-mode (&optional toggle)
-;;;_ : Defun:
-(defun outline-mode (&optional toggle)
-;;;_ . Doc string:
- "Toggle minor mode for controlling exposure and editing of text outlines.
-
-Optional arg forces mode reactivation iff arg is positive num or symbol.
-
-Allout outline mode provides extensive outline formatting and
-manipulation capabilities. It is specifically aimed at supporting
-outline structuring and manipulation of syntax-sensitive text, eg
-programming languages. \(For an example, see the allout code itself,
-which is organized in outline structure.\)
-
-It also includes such things as topic-oriented repositioning, cut, and
-paste; integral outline exposure-layout; incremental search with
-dynamic exposure/concealment of concealed text; automatic topic-number
-maintenance; and many other features.
-
-See the docstring of the variable `outline-init' for instructions on
-priming your emacs session for automatic activation of outline-mode,
-according to file-var settings of the `outline-layout' variable.
-
-Below is a description of the bindings, and then explanation of
-special outline-mode features and terminology.
-
-The bindings themselves are established according to the values of
-variables `outline-keybindings-list' and `outline-command-prefix',
-each time the mode is invoked. Prior bindings are resurrected when
-the mode is revoked.
-
- Navigation: Exposure Control:
- ---------- ----------------
-C-c C-n outline-next-visible-heading | C-c C-h outline-hide-current-subtree
-C-c C-p outline-previous-visible-heading | C-c C-i outline-show-children
-C-c C-u outline-up-current-level | C-c C-s outline-show-current-subtree
-C-c C-f outline-forward-current-level | C-c C-o outline-show-current-entry
-C-c C-b outline-backward-current-level | ^U C-c C-s outline-show-all
-C-c C-e outline-end-of-current-entry | outline-hide-current-leaves
-C-c C-a outline-beginning-of-current-entry, alternately, goes to hot-spot
-
- Topic Header Production:
- -----------------------
-C-c<SP> outline-open-sibtopic Create a new sibling after current topic.
-C-c . outline-open-subtopic ... an offspring of current topic.
-C-c , outline-open-supertopic ... a sibling of the current topic's parent.
-
- Topic Level and Prefix Adjustment:
- ---------------------------------
-C-c > outline-shift-in Shift current topic and all offspring deeper.
-C-c < outline-shift-out ... less deep.
-C-c<CR> outline-rebullet-topic Reconcile bullets of topic and its' offspring
- - distinctive bullets are not changed, others
- alternated according to nesting depth.
-C-c * outline-rebullet-current-heading Prompt for alternate bullet for
- current topic.
-C-c # outline-number-siblings Number bullets of topic and siblings - the
- offspring are not affected. With repeat
- count, revoke numbering.
-
- Topic-oriented Killing and Yanking:
- ----------------------------------
-C-c C-k outline-kill-topic Kill current topic, including offspring.
-C-k outline-kill-line Like kill-line, but reconciles numbering, etc.
-C-y outline-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 current topic outline sans concealed
- text, to buffer with name derived from
- current buffer - \"XXX exposed\"
-M-x outlineify-sticky Activate outline mode for current buffer,
- and establish a default file-var setting
- for `outline-layout'.
-ESC ESC (outline-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.
-
-\\<outline-mode-map>
-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 outline-mode keymap control chars. For example, \"f\"
-would invoke the command typically bound to \"C-c C-f\"
-\(\\[outline-forward-current-level] `outline-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 `outline-beginning-of-current-entry' \(\\[outline-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 \\[outline-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 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
- `outline-header-prefix' and then reinitializing outline-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 `outline-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 'outline-plain-bullets-string' or
- 'outline-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 (not (equal major-mode 'outline))
- (outline-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)))))))
- ;; outline-mode already called once during this complex command?
- (same-complex-command (eq outline-v18/9-file-var-hack
- (car command-history)))
- do-layout
- )
-
- ; See comments below re v19.18,.19 bug.
- (setq outline-v18/9-file-var-hack (car command-history))
-
- (cond
-
- ;; 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 outline-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 outline-explicitly-deactivated t)
- (if (string-match "^18\." emacs-version)
- ; Revoke those keys that remain
- ; as we set them:
- (let ((curr-loc (current-local-map)))
- (mapcar '(lambda (cell)
- (if (eq (lookup-key curr-loc (car cell))
- (car (cdr cell)))
- (define-key curr-loc (car cell)
- (assq (car cell) outline-prior-bindings))))
- outline-added-bindings)
- (outline-resumptions 'outline-added-bindings)
- (outline-resumptions 'outline-prior-bindings)))
-
- (if outline-old-style-prefixes
- (progn
- (outline-resumptions 'outline-primary-bullet)
- (outline-resumptions 'outline-old-style-prefixes)))
- (outline-resumptions 'selective-display)
- (if (and (boundp 'before-change-function) before-change-function)
- (outline-resumptions 'before-change-function))
- (setq pre-command-hook (delq 'outline-pre-command-business
- pre-command-hook))
- (setq local-write-file-hooks
- (delq 'outline-write-file-hook
- local-write-file-hooks))
- (outline-resumptions 'paragraph-start)
- (outline-resumptions 'paragraph-separate)
- (outline-resumptions (if (string-match "^18" emacs-version)
- 'auto-fill-hook
- 'auto-fill-function))
- (outline-resumptions 'outline-former-auto-filler)
- (setq outline-mode nil))
-
- ;; Activation:
- ((not active)
- (setq outline-explicitly-deactivated nil)
- (if outline-old-style-prefixes
- (progn ; Inhibit all the fancy formatting:
- (outline-resumptions 'outline-primary-bullet '("*"))
- (outline-resumptions 'outline-old-style-prefixes '(()))))
-
- (outline-infer-header-lead)
- (outline-infer-body-reindent)
-
- (set-outline-regexp)
-
- ; Produce map from current version
- ; of outline-keybindings-list:
- (if (boundp 'minor-mode-map-alist)
-
- (progn ; V19, and maybe lucid and
- ; epoch, minor-mode key bindings:
- (setq outline-mode-map
- (produce-outline-mode-map outline-keybindings-list))
- (fset 'outline-mode-map outline-mode-map)
- ; Include on minor-mode-map-alist,
- ; if not already there:
- (if (not (member '(outline-mode . outline-mode-map)
- minor-mode-map-alist))
- (setq minor-mode-map-alist
- (cons '(outline-mode . outline-mode-map)
- minor-mode-map-alist))))
-
- ; V18 minor-mode key bindings:
- ; Stash record of added bindings
- ; for later revocation:
- (outline-resumptions 'outline-added-bindings
- (list outline-keybindings-list))
- (outline-resumptions 'outline-prior-bindings
- (list (current-local-map)))
- ; and add them:
- (use-local-map (produce-outline-mode-map outline-keybindings-list
- (current-local-map)))
- )
-
- ; selective-display is the
- ; emacs conditional exposure
- ; mechanism:
- (outline-resumptions 'selective-display '(t))
- (if outline-inhibit-protection
- t
- (outline-resumptions 'before-change-function
- '(outline-before-change-protect)))
- ; Temporarily set by any outline
- ; functions that can be trusted to
- ; deal properly with concealed text.
- (add-hook 'local-write-file-hooks 'outline-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 outline-auto-fill:
- (outline-resumptions 'outline-former-auto-filler (list fill-func))
- ;; Register outline-auto-fill to be used if filling is active:
- (outline-resumptions fill-func-var '(outline-auto-fill)))
- ;; Paragraphs are broken by topic headlines.
- (make-local-variable 'paragraph-start)
- (outline-resumptions 'paragraph-start
- (list (concat paragraph-start "\\|\\("
- outline-regexp "\\)")))
- (make-local-variable 'paragraph-separate)
- (outline-resumptions 'paragraph-separate
- (list (concat paragraph-separate "\\|\\("
- outline-regexp "\\)")))
-
- (or (assq 'outline-mode minor-mode-alist)
- (setq minor-mode-alist
- (cons '(outline-mode " Outl") minor-mode-alist)))
-
- (if outline-layout
- (setq do-layout t))
-
- (if outline-enwrap-isearch-mode
- (outline-enwrap-isearch))
-
- (run-hooks 'outline-mode-hook)
- (setq outline-mode t))
-
- ;; Reactivation:
- ((setq do-layout t)
- (outline-infer-body-reindent))
- ) ; cond
-
- (if (and do-layout
- outline-auto-activation
- (listp outline-layout)
- (and (not (eq outline-auto-activation 'activate))
- (if (eq outline-auto-activation 'ask)
- (if (y-or-n-p (format "Expose %s with layout '%s'? "
- (buffer-name)
- outline-layout))
- t
- (message "Skipped %s layout." (buffer-name))
- nil)
- t)))
- (save-excursion
- (message "Adjusting '%s' exposure..." (buffer-name))
- (goto-char 0)
- (outline-this-or-next-heading)
- (condition-case err
- (progn
- (apply 'outline-expose-topic (list outline-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)))))
- outline-mode
- ) ; let*
- ) ; defun
-
-;;;_ #3 Internal Position State-Tracking - "outline-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)
-;;;_ = outline-recent-end-of-subtree
-(defvar outline-recent-end-of-subtree 0
- "Buffer point last returned by outline-end-of-current-subtree.")
-(make-variable-buffer-local 'outline-recent-end-of-subtree)
-;;;_ > outline-prefix-data (beg end)
-(defmacro outline-prefix-data (beg end)
- "Register outline-prefix state data - BEGINNING and END of prefix.
-
-For reference by 'outline-recent' funcs. Returns BEGINNING."
- (` (setq outline-recent-prefix-end (, end)
- outline-recent-prefix-beginning (, beg))))
-;;;_ > outline-recent-depth ()
-(defmacro 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 ()
-(defmacro 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 ()
-(defmacro 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))
-
-;;;_ #4 Navigation
-
-;;;_ - Position Assessment
-;;;_ : Location Predicates
-;;;_ > outline-on-current-heading-p ()
-(defun outline-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)
- (outline-prefix-data (match-beginning 0) (match-end 0)))))
-;;;_ > outline-e-o-prefix-p ()
-(defun outline-e-o-prefix-p ()
- "True if point is located where current topic prefix ends, heading begins."
- (and (save-excursion (beginning-of-line)
- (looking-at outline-regexp))
- (= (point)(save-excursion (outline-end-of-prefix)(point)))))
-;;;_ > outline-hidden-p ()
-(defmacro outline-hidden-p ()
- "True if point is in hidden text."
- '(save-excursion
- (and (re-search-backward "[\n\r]" () t)
- (= ?\r (following-char)))))
-;;;_ > outline-visible-p ()
-(defmacro outline-visible-p ()
- "True if point is not in hidden text."
- (interactive)
- '(not (outline-hidden-p)))
-;;;_ : Location attributes
-;;;_ > outline-depth ()
-(defmacro outline-depth ()
- "Like outline-current-depth, but respects hidden as well as visible topics."
- '(save-excursion
- (if (outline-goto-prefix)
- (outline-recent-depth)
- (progn
- ;; Oops, no prefix, zero prefix data:
- (outline-prefix-data (point)(point))
- ;; ... and return 0:
- 0))))
-;;;_ > outline-current-depth ()
-(defmacro outline-current-depth ()
- "Return nesting depth of visible topic most immediately containing point."
- '(save-excursion
- (if (outline-back-to-current-heading)
- (max 1
- (- outline-recent-prefix-end
- outline-recent-prefix-beginning
- outline-header-subtraction))
- 0)))
-;;;_ > outline-get-current-prefix ()
-(defun outline-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)."
- (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."
- (condition-case err
- (save-excursion
- (outline-back-to-current-heading)
- (buffer-substring (- outline-recent-prefix-end 1)
- outline-recent-prefix-end))
- ;; Quick and dirty provision, ostensibly for missing bullet:
- (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."
- ;; 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)
- (substring prefix (1- (match-end 0)) (match-end 0))))
-
-;;;_ - Navigation macros
-;;;_ > outline-next-heading ()
-(defmacro outline-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 outline-line-boundary-regexp nil 0)
- (progn ; Got valid location state - set vars:
- (outline-prefix-data
- (goto-char (or (match-beginning 2)
- outline-recent-prefix-beginning))
- (or (match-end 2) outline-recent-prefix-end)))))
-;;;_ : outline-this-or-next-heading
-(defun outline-this-or-next-heading ()
- "Position cursor on current or next heading."
- ;; A throwaway non-macro that is defined after outline-next-heading
- ;; and usable by outline-mode.
- (if (not (outline-goto-prefix)) (outline-next-heading)))
-;;;_ > outline-previous-heading ()
-(defmacro outline-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
- (outline-goto-prefix)
- (if
- ;; searches are unbounded and return nil if failed:
- (or (re-search-backward outline-line-boundary-regexp nil 0)
- (looking-at outline-bob-regexp))
- (progn ; Got valid location state - set vars:
- (outline-prefix-data
- (goto-char (or (match-beginning 2)
- outline-recent-prefix-beginning))
- (or (match-end 2) outline-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 whatever assessment or adjustment of the subtree that is
-;;; required, without requiring redundant topic-traversal procedures.
-
-;;;_ > outline-chart-subtree (&optional levels orig-depth prev-depth)
-(defun outline-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. Subsequent optional args are not for public
-use.
-
-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.
-
-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 (outline-depth))
- (or prev-depth (setq prev-depth (1+ orig-depth)))
- (outline-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 (outline-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 (outline-next-sibling curr-depth)
- ;; or no more siblings - proceed to
- ;; next heading at lesser depth:
- (while (and (<= curr-depth
- (outline-recent-depth))
- (outline-next-heading))))
- (outline-next-heading)))
-
- ((and (< prev-depth curr-depth)
- (or (not levels)
- (> levels 0)))
- ;; Recurse on deeper level of curr topic:
- (setq chart
- (cons (outline-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 ?\^M))
- (memq (aref (buffer-substring (max 1 (- (point) 3))
- (point))
- 1)
- '(?\n ?\^M))
- (forward-char -1))
- (setq outline-recent-end-of-subtree (point))))
-
- chart ; (nreverse chart) not necessary,
- ; and maybe not preferable.
- ))
-;;;_ > outline-chart-siblings (&optional start end)
-(defun outline-chart-siblings (&optional start end)
- "Produce a list of locations of this and succeeding sibling topics.
-Effectively a top-level chart of siblings. See 'outline-chart-subtree'
-for an explanation of charts."
- (save-excursion
- (if (outline-goto-prefix)
- (let ((chart (list (point))))
- (while (outline-next-sibling)
- (setq chart (cons (point) chart)))
- (if chart (setq chart (nreverse chart)))))))
-;;;_ > outline-chart-to-reveal (chart depth)
-(defun outline-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 (outline-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 outline-chart-spec (chart spec &optional exposing)
-(defun outline-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
-;;;_ > outline-goto-prefix ()
-(defun outline-goto-prefix ()
- "Put point at beginning of outline prefix for immediately containing topic.
-
-Goes to first subsequent topic if none immediately containing.
-
-Not sensitive to topic visibility.
-
-Returns a 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 outline-regexp)
- (setq done (outline-prefix-data (match-beginning 0)
- (match-end 0)))
- (forward-char -1)))
- (if (bobp)
- (cond ((looking-at outline-regexp)
- (outline-prefix-data (match-beginning 0)(match-end 0)))
- ((outline-next-heading)
- (outline-prefix-data (match-beginning 0)(match-end 0)))
- (done))
- done)))
-;;;_ > outline-end-of-prefix ()
-(defun outline-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 (outline-goto-prefix))
- nil
- (let ((match-data (match-data)))
- (goto-char (match-end 0))
- (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-current-bullet-pos ()
-(defun outline-current-bullet-pos ()
- "Return position of current \(visible) topic's bullet."
-
- (if (not (outline-current-depth))
- nil
- (1- (match-end 0))))
-;;;_ > outline-back-to-current-heading ()
-(defun outline-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 "\\)")
- nil
- 'move)
- (outline-prefix-data (match-beginning 1)(match-end 1))))
- (if (interactive-p) (outline-end-of-prefix))))
-;;;_ > outline-pre-next-preface ()
-(defun outline-pre-next-preface ()
- "Skip forward to just before the next heading line.
-
-Returns that character position."
-
- (if (re-search-forward outline-line-boundary-regexp nil 'move)
- (prog1 (goto-char (match-beginning 0))
- (outline-prefix-data (match-beginning 2)(match-end 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."
- (interactive)
- (outline-back-to-current-heading)
- (let ((level (outline-recent-depth)))
- (outline-next-heading)
- (while (and (not (eobp))
- (> (outline-recent-depth) level))
- (outline-next-heading))
- (and (not (eobp)) (forward-char -1))
- (and (memq (preceding-char) '(?\n ?\^M))
- (memq (aref (buffer-substring (max 1 (- (point) 3)) (point)) 1)
- '(?\n ?\^M))
- (forward-char -1))
- (setq outline-recent-end-of-subtree (point))))
-;;;_ > outline-beginning-of-current-entry ()
-(defun outline-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 outline-mode doc string for details on hot-spot operation.)"
- (interactive)
- (let ((start-point (point)))
- (outline-end-of-prefix)
- (if (and (interactive-p)
- (= (point) start-point))
- (goto-char (outline-current-bullet-pos)))))
-;;;_ > outline-end-of-current-entry ()
-(defun outline-end-of-current-entry ()
- "Position the point at the end of the current topics' entry."
- (interactive)
- (outline-show-entry)
- (prog1 (outline-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)))
- (let ((last-good (point)))
- (while (and (< depth (outline-depth))
- (setq last-good (point))
- (outline-beginning-of-level)
- (outline-previous-heading)))
- (if (= (outline-recent-depth) depth)
- (progn (goto-char outline-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."
- (let ((start-point (point))
- (start-depth (outline-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))
- depth
- (goto-char start-point)
- nil))
- )
-;;;_ > outline-up-current-level (arg &optional dont-complain)
-(defun outline-up-current-level (arg &optional dont-complain)
- "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")
- (outline-back-to-current-heading)
- (let ((present-level (outline-recent-depth))
- (last-good (point))
- failed
- return)
- ;; Loop for iterating arg:
- (while (and (> (outline-recent-depth) 1)
- (> arg 0)
- (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))
- (or (outline-previous-visible-heading 1)
- (not (setq failed present-level)))))
- (setq present-level (outline-current-depth))
- (setq arg (- arg 1)))
- (if (or failed
- (> arg 0))
- (progn (goto-char last-good)
- (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))
- nil))
- (if (interactive-p) (outline-end-of-prefix))
- outline-recent-prefix-beginning)))
-
-;;;_ - Linear
-;;;_ > outline-next-sibling (&optional depth backward)
-(defun outline-next-sibling (&optional depth backward)
- "Like outline-forward-current-level, but respects invisible topics.
-
-Traverse at optional DEPTH, or current depth if none specified.
-
-Go backward if optional arg BACKWARD is non-nil.
-
-Return depth if successful, nil otherwise."
-
- (if (and backward (bobp))
- nil
- (let ((start-depth (or depth (outline-depth)))
- (start-point (point))
- last-depth)
- (while (and (not (if backward (bobp) (eobp)))
- (if backward (outline-previous-heading)
- (outline-next-heading))
- (> (setq last-depth (outline-recent-depth)) start-depth)))
- (if (and (not (eobp))
- (and (> (or last-depth (outline-depth)) 0)
- (= (outline-recent-depth) start-depth)))
- outline-recent-prefix-beginning
- (goto-char start-point)
- (if depth (outline-depth) start-depth)
- nil))))
-;;;_ > outline-previous-sibling (&optional depth backward)
-(defun outline-previous-sibling (&optional depth backward)
- "Like outline-forward-current-level,but backwards & respect invisible topics.
-
-Optional DEPTH specifies depth to traverse, default current depth.
-
-Optional BACKWARD reverses direction.
-
-Return depth if successful, nil otherwise."
- (outline-next-sibling depth (not backward))
- )
-;;;_ > outline-snug-back ()
-(defun outline-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 ?\^M))))
- nil
- (forward-char -1)
- (if (or (bobp) (not (memq (preceding-char) '(?\n ?\^M))))
- (forward-char -1)))
- (point))
-;;;_ > 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."
-
- (let ((depth (outline-depth)))
- (while (outline-previous-sibling depth nil))
- (prog1 (outline-recent-depth)
- (if (interactive-p) (outline-end-of-prefix)))))
-;;;_ > outline-next-visible-heading (arg)
-(defun outline-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."
-
- (interactive "p")
- (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 outline-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:
- (outline-prefix-data (match-beginning 0) (match-end 0))
- (outline-end-of-prefix))
- (prev ; Last move wasn't, but prev was:
- (outline-prefix-data (match-beginning 0) (match-end 0)))
- ((not backward) (end-of-line) nil))))
-;;;_ > outline-previous-visible-heading (arg)
-(defun outline-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 outline-regexp
-matches)."
- (interactive "p")
- (outline-next-visible-heading (- arg)))
-;;;_ > outline-forward-current-level (arg)
-(defun outline-forward-current-level (arg)
- "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")
- (let ((start-depth (outline-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 (outline-previous-visible-heading 1)
- (outline-next-visible-heading 1))
- (> (setq last-depth (outline-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 (outline-depth)) 0)
- (= (outline-recent-depth) start-depth)))
- outline-recent-prefix-beginning
- (goto-char last-good)
- (if (not (interactive-p))
- nil
- (outline-end-of-prefix)
- (error "Hit %s level %d topic, traversed %d of %d requested."
- (if backward "first" "last")
- (outline-recent-depth)
- (- (abs start-arg) arg)
- (abs start-arg))))))
-;;;_ > outline-backward-current-level (arg)
-(defun outline-backward-current-level (arg)
- "Inverse of `outline-forward-current-level'."
- (interactive "p")
- (if (interactive-p)
- (let ((current-prefix-arg (* -1 arg)))
- (call-interactively 'outline-forward-current-level))
- (outline-forward-current-level (* -1 arg))))
-
-;;;_ #5 Alteration
-
-;;;_ - Fundamental
-;;;_ > outline-before-change-protect (beg end)
-(defun outline-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-function', which
-in emacs 19 is run before any change to the buffer. (Has no effect
-in Emacs 18, which doesn't support before-change-function.)
-
-Any functions which set ['this-command' to 'undo', or which set]
-'outline-override-protect' non-nil (as does, eg, outline-flag-chars)
-are exempt from this restriction."
- (if (and (outline-mode-p)
- ; outline-override-protect
- ; set by functions that know what
- ; they're doing, eg outline internals:
- (not outline-override-protect)
- (not outline-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 (outline-hidden-p)
- (and (not (= beg end))
- (goto-char end)
- (outline-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 (outline-hidden-p)
- (outline-show-children))
- (message "Undo!"))
- (let (response
- (rehide-completely (save-excursion (outline-goto-prefix)
- (outline-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
- (outline-goto-prefix)))
- (outline-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
- (outline-hide-current-entry-completely)
- (outline-hide-current-entry)))
- (if (outline-ascend-to-depth (1- (outline-recent-depth)))
- (outline-show-children)
- (outline-show-to-offshoot)))
- ; Prevent:
- (if rehide-completely
- (save-excursion
- (if rehide-place (goto-char rehide-place))
- (outline-hide-current-entry-completely))
- (outline-hide-current-entry))
- (error (concat
- "Change within concealed region prevented.")))))))
- ) ; if
- ) ; defun
-;;;_ = outline-post-goto-bullet
-(defvar outline-post-goto-bullet nil
- "Outline internal var, for `outline-pre-command-business' hot-spot operation.
-
-When set, tells post-processing to reposition on topic bullet, and
-then unset it. Set by outline-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
-outline-mode-map.")
-(make-variable-buffer-local 'outline-post-goto-bullet)
-;;;_ > outline-post-command-business ()
-(defun outline-post-command-business ()
- "Outline post-command-hook function.
-
-- Null outline-override-protect, so it's not left open.
-
-- Implement (and clear) outline-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-function is used."
-
- ; Apply any external change func:
- (if (not (outline-mode-p)) ; In outline-mode.
- nil
- (setq outline-override-protect nil)
- (if outline-during-write-cue
- ;; Was used by outline-before-change-protect, done with it now:
- (setq outline-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:
- (> outline-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 outline-post-goto-bullet
- (outline-current-bullet-pos))
- (progn (goto-char (outline-current-bullet-pos))
- (setq outline-post-goto-bullet nil)))
- ))
-;;;_ > outline-pre-command-business ()
-(defun outline-pre-command-business ()
- "Outline pre-command-hook function for outline buffers.
-
-Implements special behavior when cursor is on bullet char.
-
-Self-insert characters are reinterpreted control-character references
-into the outline-mode-map. The outline-mode post-command hook will
-position a cursor that has moved as a result of such reinterpretation,
-on the destination topic's bullet, when the cursor wound up in the
-
-The upshot is that you can get easy, single (unmodified) key outline
-maneuvering and general operations by positioning the cursor on the
-bullet char, and it continues until you deliberately some non-outline
-motion command to relocate the cursor off of a bullet char."
-
- (if (and (boundp 'outline-mode)
- outline-mode
- (eq this-command 'self-insert-command)
- (eq (point)(outline-current-bullet-pos)))
-
- (let* ((this-key-num (if (numberp last-command-event)
- last-command-event))
- mapped-binding)
-
- ; 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 'outline-mode-map
- (concat outline-command-prefix
- (char-to-string (- this-key-num 64))))))
- (if mapped-binding
- (setq outline-post-goto-bullet t
- this-command mapped-binding)))))
-;;;_ > outline-find-file-hook ()
-(defun outline-find-file-hook ()
- "Activate outline-mode when `outline-auto-activation' & `outline-layout' are non-nil.
-
-See `outline-init' for setup instructions."
- (if (and outline-auto-activation
- (not (outline-mode-p))
- outline-layout)
- (outline-mode t)))
-;;;_ : Establish the hooks
-(add-hook 'post-command-hook 'outline-post-command-business)
-(add-hook 'pre-command-hook 'outline-pre-command-business)
-
-;;;_ - 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.
-
-Offer one suitable for current depth DEPTH as default."
-
- (let* ((default-bullet (or current-bullet
- (outline-bullet-for-depth depth)))
- (sans-escapes (regexp-sans-escapes outline-bullets-string))
- (choice (solicit-char-in-string
- (format "Select bullet: %s ('%s' default): "
- sans-escapes
- default-bullet)
- sans-escapes
- t)))
- (if (string= choice "") default-bullet choice))
- )
-;;;_ > outline-sibling-index (&optional depth)
-(defun outline-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 (outline-depth)))
- (let ((index 1))
- (while (outline-previous-sibling (outline-recent-depth) nil)
- (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
- (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 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
- (% (max 0 (- depth 2))
- outline-plain-bullets-string-len)))
- outline-primary-bullet)
- )
-
-;;;_ - Topic Production
-;;;_ > outline-make-topic-prefix (&optional prior-bullet
-(defun outline-make-topic-prefix (&optional prior-bullet
- new
- depth
- solicit
- number-control
- index)
- ;; Depth null means use current depth, non-null means we're either
- ;; opening a new topic after current topic, lower or higher, or we're
- ;; changing level of current topic.
- ;; Solicit dominates specified bullet-char.
-;;;_ . 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 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)."
-;;;_ . 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.
- ;; Current prefix is least dominant, but most likely to be commonly
- ;; specified...
-
- (let* (body
- numbering
- denumbering
- (depth (or depth (outline-depth)))
- (header-lead outline-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)
- ; Simple, too: all asterisks:
- (outline-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)))
- (setq header-lead "")
- "")
-
- ;; (Neither level 1 nor old-style, so we're space padding.
- ;; Sneak it in the condition of the next case, whatever it is.)
-
- ;; Solicitation overrides numbering and other cases:
- ((progn (setq body (make-string (- depth 2) ?\ ))
- ;; The actual condition:
- solicit)
- (let* ((got (outline-solicit-alternate-bullet depth)))
- ;; Gotta check whether we're numbering and got a numbered bullet:
- (setq numbering (and outline-numbered-bullet
- (not (and number-control (not index)))
- (string= got outline-numbered-bullet)))
- ;; Now return what we got, regardless:
- got))
-
- ;; Numbering invoked through args:
- ((and outline-numbered-bullet number-control)
- (if (setq numbering (not (setq denumbering (not index))))
- outline-numbered-bullet
- (if (and prior-bullet
- (not (string= outline-numbered-bullet
- prior-bullet)))
- prior-bullet
- (outline-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
- (not denumbering)
- (let ((sibling-bullet
- (save-excursion
- ;; Locate correct sibling:
- (or (>= depth (outline-depth))
- (outline-ascend-to-depth depth))
- (outline-get-bullet))))
- (if (and sibling-bullet
- (string= outline-numbered-bullet sibling-bullet))
- (setq numbering sibling-bullet)))))
-
- ;; Distinctive prior bullet?
- ((and prior-bullet
- (outline-distinctive-bullet prior-bullet)
- ;; Either non-numbered:
- (or (not (and outline-numbered-bullet
- (string= prior-bullet outline-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)))))
-
- (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))))))
- )
- )
-;;;_ > outline-open-topic (relative-depth &optional before)
-(defun outline-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))
- (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-topic (save-excursion
- (cond ((< relative-depth 0)
- (outline-ascend-to-depth depth))
- ((>= relative-depth 1) nil)
- (t (outline-back-to-current-heading)))
- (setq ref-depth (outline-recent-depth))
- (setq opening-numbered
- (save-excursion
- (and outline-numbered-bullet
- (or (<= relative-depth 0)
- (outline-descend-to-depth depth))
- (if (outline-numbered-type-prefix)
- outline-numbered-bullet))))
- (point)))
- dbl-space
- doing-beginning)
-
- (if (not opening-on-blank)
- ; Positioning and vertical
- ; padding - only if not
- ; opening-on-blank:
- (progn
- (goto-char ref-topic)
- (setq dbl-space ; Determine double space action:
- (or (and (<= relative-depth 0) ; not descending;
- (save-excursion
- ;; 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?
- (outline-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)))))))
-
- ; Position to prior heading,
- ; if inserting backwards, and
- ; not going outwards:
- (if (and before (>= relative-depth 0))
- (progn (outline-back-to-current-heading)
- (setq doing-beginning (bobp))
- (if (not (bobp))
- (outline-previous-heading)))
- (if (and before (bobp))
- (outline-unprotected (open-line 1))))
-
- (if (<= relative-depth 0)
- ;; Not going inwards, don't snug up:
- (if doing-beginning
- (outline-unprotected (open-line (if dbl-space 2 1)))
- (if before
- (progn (end-of-line)
- (outline-pre-next-preface)
- (while (= ?\r (following-char))
- (forward-char 1))
- (if (not (looking-at "^$"))
- (outline-unprotected (open-line 1))))
- (outline-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)
- (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)
- ;; This is an offspring.
- (progn (forward-line -1)
- (looking-at "^\\s-*$"))))
- (progn (forward-line 1)
- (outline-unprotected (open-line 1))))
- (end-of-line))
- ;;(if doing-beginning (goto-char doing-beginning))
- (if (not (bobp))
- (progn (if (and (not (> depth ref-depth))
- (not before))
- (outline-unprotected (open-line 1))
- (if (> depth ref-depth)
- (outline-unprotected (newline 1))
- (if dbl-space
- (outline-unprotected (open-line 1))
- (if (not before)
- (outline-unprotected (newline 1))))))
- (if dbl-space
- (outline-unprotected (newline 1)))
- (if (and (not (eobp))
- (not (bolp)))
- (forward-char 1))))
- ))
- (insert-string (concat (outline-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
- t) (end-of-line)
- )
- )
-;;;_ . 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
-;;;_ .
-;;;_ > outline-open-subtopic (arg)
-(defun outline-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")
- (outline-open-topic 1 (> 0 arg)))
-;;;_ > outline-open-sibtopic (arg)
-(defun outline-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."
- (interactive "p")
- (outline-open-topic 0 (> 0 arg)))
-;;;_ > outline-open-supertopic (arg)
-(defun outline-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."
-
- (interactive "p")
- (outline-open-topic -1 (> 0 arg)))
-
-;;;_ - Outline Alteration
-;;;_ : Topic Modification
-;;;_ = outline-former-auto-filler
-(defvar outline-former-auto-filler nil
- "Name of modal fill function being wrapped by outline-auto-fill.")
-;;;_ > outline-auto-fill ()
-(defun outline-auto-fill ()
- "Outline-mode autofill function.
-
-Maintains outline hanging topic indentation if
-`outline-use-hanging-indents' is set."
- (let ((fill-prefix (if outline-use-hanging-indents
- ;; Check for topic header indentation:
- (save-excursion
- (beginning-of-line)
- (if (looking-at outline-regexp)
- ;; ... construct indentation to account for
- ;; length of topic prefix:
- (make-string (progn (outline-end-of-prefix)
- (current-column))
- ?\ ))))))
- (if (or outline-former-auto-filler outline-use-hanging-indents)
- (do-auto-fill))))
-;;;_ > outline-reindent-body (old-depth new-depth &optional number)
-(defun outline-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
- (outline-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:
- (outline-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 outline-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)))))))))
-;;;_ > outline-rebullet-current-heading (arg)
-(defun outline-rebullet-current-heading (arg)
- "Like non-interactive version 'outline-rebullet-heading'.
-
-But \(only\) affects 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 ...)
-(defun outline-rebullet-heading (&optional solicit
- new-depth
- number-control
- index
- do-successors)
-
- "Adjust bullet of current topic prefix.
-
-All args are optional.
-
-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.
-
-Second arg DEPTH forces the topic prefix to that depth, regardless
-of the topics 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.
-
-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.
-
-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."
-
- (let* ((current-depth (outline-depth))
- (new-depth (or new-depth current-depth))
- (mb outline-recent-prefix-beginning)
- (me outline-recent-prefix-end)
- (current-bullet (buffer-substring (- me 1) me))
- (new-prefix (outline-make-topic-prefix current-bullet
- nil
- new-depth
- solicit
- number-control
- index)))
-
- ;; 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:
- (outline-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)
- (looking-at "[0-9]+"))
- (outline-unprotected
- (delete-region (match-beginning 0)(match-end 0))))
-
- ; Put in new prefix:
- (outline-unprotected (insert-string new-prefix))
-
- ;; Reindent the body if elected and margin changed:
- (if (and outline-reindent-bodies
- (not (= new-depth current-depth)))
- (outline-reindent-body current-depth new-depth))
-
- ;; Recursively rectify successive siblings of orig topic if
- ;; caller elected for it:
- (if do-successors
- (save-excursion
- (while (outline-next-sibling new-depth nil)
- (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
- ) ; (if (and (= current-depth new-depth)...))
- ) ; let* ((current-depth (outline-depth))...)
- ) ; defun
-;;;_ > 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.
-
-With repeat count, shift topic depth by that amount."
- (interactive "P")
- (let ((start-col (current-column))
- (was-eol (eolp)))
- (save-excursion
- ;; Normalize arg:
- (cond ((null arg) (setq arg 0))
- ((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)
- (error "Attempt to shift topic below level 1"))
- (outline-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
- 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.
-
-All arguments are optional.
-
-First arg RELATIVE-DEPTH means to shift the depth of the entire
-topic that amount.
-
-The rest of the args are for internal recursive use by the function
-itself. The are STARTING-DEPTH, STARTING-POINT, and INDEX."
-
- (let* ((relative-depth (or relative-depth 0))
- (new-depth (outline-depth))
- (starting-depth (or starting-depth new-depth))
- (on-starting-call (null starting-point))
- (index (or index
- ;; Leave index null on starting call, so rebullet-heading
- ;; calculates it at what might be new depth:
- (and (or (zerop relative-depth)
- (not on-starting-call))
- (outline-sibling-index))))
- (moving-outwards (< 0 relative-depth))
- (starting-point (or starting-point (point))))
-
- ;; Sanity check for excessive promotion done only on starting call:
- (and on-starting-call
- moving-outwards
- (> 0 (+ starting-depth relative-depth))
- (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
- (+ starting-depth ;;; starting-depth
- relative-depth)
- nil ;;; number
- index ;;; index
- ;; Every contained topic will get hit,
- ;; and we have to get to outside ones
- ;; deliberately:
- nil) ;;; do-successors
- ;; ... and work on subsequent ones which are at greater depth:
- (setq index 0)
- (outline-next-heading)
- (while (and (not (eobp))
- (< starting-depth (outline-recent-depth)))
- (setq index (1+ index))
- (outline-rebullet-topic-grunt relative-depth ;;; relative-depth
- (1+ starting-depth);;;starting-depth
- starting-point ;;; starting-point
- index))) ;;; index
-
- ((< 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
- new-depth ;;; starting-depth
- starting-point ;;; starting-point
- index))) ;;; index
-
- (if on-starting-call
- (progn
- ;; Rectify numbering of former siblings of the adjusted topic,
- ;; 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
- relative-depth)))))
- (outline-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)))))
- )
- )
-;;;_ > outline-renumber-to-depth (&optional depth)
-(defun outline-renumber-to-depth (&optional depth)
- "Renumber siblings at current depth.
-
-Affects superior topics if optional arg DEPTH is less than current depth.
-
-Returns final depth."
-
- ;; Proceed by level, processing subsequent siblings on each,
- ;; ascending until we get shallower than the start depth:
-
- (let ((ascender (outline-depth)))
- (while (and (not (eobp))
- (outline-depth)
- (>= (outline-recent-depth) depth)
- (>= ascender depth))
- ; Skip over all topics at
- ; lesser depths, which can not
- ; have been disturbed:
- (while (and (not (eobp))
- (> (outline-recent-depth) ascender))
- (outline-next-heading))
- ; Prime ascender for ascension:
- (setq ascender (1- (outline-recent-depth)))
- (if (>= (outline-recent-depth) depth)
- (outline-rebullet-heading nil ;;; solicit
- nil ;;; depth
- nil ;;; number-control
- nil ;;; index
- t))));;; do-successors
- (outline-recent-depth))
-;;;_ > outline-number-siblings (&optional denumber)
-(defun outline-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 ((depth (outline-recent-depth))
- (index (if (not denumber) 1))
- (use-bullet (equal '(16) denumber))
- (more t))
- (while more
- (outline-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 depth nil))))))
-;;;_ > outline-shift-in (arg)
-(defun outline-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 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."
-
- (interactive "*P")
- (if (not (and (outline-mode-p) ; active outline mode,
- outline-numbered-bullet ; numbers may need adjustment,
- (bolp) ; may be clipping topic head,
- (looking-at outline-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)))
- ; Do the kill:
- (kill-line arg)
- ; Provide some feedback:
- (sit-for 0)
- (save-excursion
- ; Start with the topic
- ; following killed line:
- (if (not (looking-at outline-regexp))
- (outline-next-heading))
- (outline-renumber-to-depth depth)))))
-;;;_ > outline-kill-topic ()
-(defun outline-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
- ;; after the region is disposed of, though the renumbering process
- ;; has yet to be performed. This means that there may appear to be
- ;; a lag *after* the kill has been performed.
-
- (interactive)
- (let* ((beg (prog1 (outline-back-to-current-heading)(beginning-of-line)))
- (depth (outline-recent-depth)))
- (outline-end-of-current-subtree)
- (if (not (eobp))
- (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 (outline-next-heading)
- (>= (outline-recent-depth) depth))))
- (forward-char 1)))
-
- (kill-region beg (point))
- (sit-for 0)
- (save-excursion
- (outline-renumber-to-depth depth))))
-;;;_ > outline-yank-processing ()
-(defun outline-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
- topic prefix.
-
-Also, adjusts numbering of subsequent siblings when appropriate.
-
-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.
-
-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, non-outline-specific yanks."
-
- (interactive "*P")
- ; Get to beginning, leaving
- ; region around subject:
- (if (< (mark-marker) (point))
- (exchange-point-and-mark))
- (let* ((subj-beg (point))
- (subj-end (mark-marker))
- ;; 'resituate' if yanking an entire topic into topic header:
- (resituate (and (outline-e-o-prefix-p)
- (looking-at (concat "\\(" outline-regexp "\\)"))
- (outline-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 outline-regexp)))))
- (if resituate
- ; The yanked stuff is a topic:
- (let* ((prefix-len (- (match-end 1) subj-beg))
- (subj-depth (outline-recent-depth))
- (prefix-bullet (outline-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 outline-regexp)
- (progn
- (beginning-of-line)
- (not (= (point) subj-beg)))
- (looking-at outline-regexp)
- (outline-prefix-data (match-beginning 0)
- (match-end 0)))
- (outline-recent-depth))))
- done
- (more t))
- (setq rectify-numbering outline-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 "^$")
- (outline-unprotected (delete-char -1)))
- ; Work backwards, with each
- ; shallowest level,
- ; successively excluding the
- ; last processed topic from
- ; the narrow region:
- (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 (- adjust-to-depth
- subj-depth))
- (outline-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)
- outline-distinctive-bullets-string)
- ; Delete from bullet of old to
- ; before bullet of new:
- (progn
- (beginning-of-line)
- (delete-region (point) subj-beg)
- (set-marker (mark-marker) subj-end)
- (goto-char subj-beg)
- (outline-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 (outline-goto-prefix)
- (outline-rebullet-heading nil ;;; solicit
- (outline-depth) ;;; depth
- nil ;;; number-control
- nil ;;; index
- t))
- (message ""))))
- (if (not resituate)
- (exchange-point-and-mark))))
-;;;_ > outline-yank (&optional arg)
-(defun outline-yank (&optional arg)
- "Outline-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 outline-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.
-
-Outline-yank-pop works with outline-yank just like normal yank-pop
-works with normal yank in non-outline buffers."
-
- (interactive "*P")
- (setq this-command 'yank)
- (yank arg)
- (if (outline-mode-p)
- (outline-yank-processing)))
-;;;_ > outline-yank-pop (&optional arg)
-(defun outline-yank-pop (&optional arg)
- "Yank-pop like outline-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")
- (setq this-command 'yank)
- (yank-pop arg)
- (if (outline-mode-p)
- (outline-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.
-
-\(Works according to setting of `outline-file-xref-bullet')."
- (interactive)
- (if (not outline-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)
- (let (file-name)
- (save-excursion
- (let* ((text-start outline-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)
- (buffer-substring (match-beginning 1) (match-end 1))))))
- (setq file-name
- (if (not (= (aref file-name 0) ?:))
- (expand-file-name file-name)
- ; A registry-files ref, strip the ':'
- ; and try to follow it:
- (let ((reg-ref (reference-registered-file
- (substring file-name 1) nil t)))
- (if reg-ref (car (cdr reg-ref))))))
- (if (or (file-exists-p file-name)
- (if (file-writable-p file-name)
- (y-or-n-p (format "%s not there, create one? "
- file-name))
- (error "%s not found and can't be created" file-name)))
- (condition-case failure
- (find-file-other-window file-name)
- (error failure))
- (error "%s not found" file-name))
- )
- )
- )
- )
-
-;;;_ #6 Exposure Control and Processing
-
-;;;_ - Fundamental
-;;;_ > outline-flag-region (from to flag)
-(defmacro outline-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)
- (outline-override-protect t))
- (subst-char-in-region (, from) (, to)
- (if (= (, flag) ?\n) ?\r ?\n)
- (, flag) t))))
-;;;_ > outline-flag-current-subtree (flag)
-(defun outline-flag-current-subtree (flag)
- "Hide or show subtree of currently-visible topic.
-
-See `outline-flag-region' for more details."
-
- (save-excursion
- (outline-back-to-current-heading)
- (outline-flag-region (point)
- (progn (outline-end-of-current-subtree) (1- (point)))
- flag)))
-
-;;;_ - Mapping and processing of topics
-;;;_ " See also chart functions, in navigation
-;;;_ > outline-listify-exposed (&optional start end)
-(defun outline-listify-exposed (&optional start end)
-
- "Produce a list representing exposed topics in current region.
-
-This list can then be used by 'outline-process-exposed' to manipulate
-the subject region.
-
-List is composed of elements that may themselves be lists representing
-exposed components in subtopic.
-
-Each component list contains:
- - a number representing the depth of the topic,
- - a string representing the header-prefix (ref. 'outline-header-prefix'),
- - 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* (strings pad result depth bullet beg next done) ; State vars.
- (goto-char start)
- (beginning-of-line)
- (if (not (outline-goto-prefix)) ; Get initial position within a topic:
- (outline-next-visible-heading 1))
- (while (and (not done)
- (not (eobp)) ; Loop until we've covered the region.
- (not (> (point) end)))
- (setq depth (outline-recent-depth) ; Current topics' depth,
- bullet (outline-recent-bullet) ; ... bullet,
- beg (progn (outline-end-of-prefix t) (point))) ; and beginning.
- (setq done ; The boundary for the current topic:
- (not (outline-next-visible-heading 1)))
- (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 result
- (cons (append (list depth
- outline-header-prefix
- bullet)
- (nreverse strings))
- result)))
- ;; Put the list with first at front, to last at back:
- (nreverse result))))
-;;;_ > outline-process-exposed (arg &optional tobuf)
-(defun outline-process-exposed (&optional func from to frombuf tobuf)
- "Map function on exposed parts of current topic; results to another buffer.
-
-Apply FUNCTION \(default 'outline-insert-listified) to exposed
-portions FROM position TO position \(default region, or the entire
-buffer if no region active) in buffer FROMBUF \(default current
-buffer) to buffer TOBUF \(default is buffer named like frombuf but
-with \"*\" prepended and \" exposed*\" appended).
-
-The function must as its arguments the elements of the list
-representations of topic entries produced by outline-listify-exposed."
-
- ; Resolve arguments,
- ; defaulting if necessary:
- (if (not func) (setq func 'outline-insert-listified))
- (if (not (and from to))
- (if mark-active
- (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 "outline-process-exposed: source buffer %s not found."
- frombuf)
- (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*")))
-
- (let* ((listified (progn (set-buffer frombuf)
- (outline-listify-exposed from to)))
- (prefix outline-header-prefix) ; ... as set in frombuf.
- curr)
- (set-buffer tobuf)
- (while listified
- (setq curr (car listified))
- (setq listified (cdr listified))
- (apply func (list (car curr) ; depth
- (car (cdr curr)) ; header-prefix
- (car (cdr (cdr curr))) ; bullet
- (cdr (cdr (cdr curr)))))) ; list of text lines
- (pop-to-buffer tobuf)))
-
-;;;_ - Topic-specific
-;;;_ > outline-show-entry ()
-; outline-show-entry basically for isearch dynamic exposure, as is...
-(defun outline-show-entry ()
- "Like `outline-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. outline-hide-current-entry-completely or outline-show-offshoot
-should be used after the peek to rectify the exposure."
-
- (interactive)
- (save-excursion
- (outline-goto-prefix)
- (outline-flag-region (if (bobp) (point) (1- (point)))
- (or (outline-pre-next-preface) (point))
- ?\n)))
-;;;_ > outline-show-children (&optional level strict)
-(defun outline-show-children (&optional level strict)
-
- "If point is visible, show all direct subheadings of this heading.
-
-Otherwise, do outline-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)
- (outline-hidden-p))
-
- (progn (outline-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 (outline-show-children level t)))
-
- (save-excursion
- (save-restriction
- (let* ((start-pt (point))
- (chart (outline-chart-subtree (or level 1)))
- (to-reveal (outline-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.
- (outline-flag-region (point) (outline-snug-back) ?\n))
- (while to-reveal
- (goto-char (car to-reveal))
- (outline-flag-region (point) (outline-snug-back) ?\n)
- (setq to-reveal (cdr to-reveal)))))))))
-;;;_ x outline-show-current-children (&optional level strict)
-(defun outline-show-current-children (&optional level strict)
- "This command was misnamed, use `outline-show-children' instead.
-
-\(The \"current\" in the name is supposed to imply that it works on
-the visible topic containing point, while it really works with respect
-to the most immediate topic, concealed or not. I'll leave this old
-name around for a bit, but i'll soon activate an annoying message to
-warn people about the change, and then deprecate this alias."
-
- (interactive "p")
- ;;(beep)
- ;;(message (format "Use '%s' instead of '%s' (%s)."
- ;; "outline-show-children"
- ;; "outline-show-current-children"
- ;; (buffer-name (current-buffer))))
- (outline-show-children level strict))
-;;;_ > outline-hide-point-reconcile ()
-(defun outline-hide-reconcile ()
- "Like `outline-hide-current-entry'; hides completely if within hidden region.
-
-Specifically intended for aberrant exposure states, like entries that were
-exposed by outline-show-entry but are within otherwise concealed regions."
- (interactive)
- (save-excursion
- (outline-goto-prefix)
- (outline-flag-region (if (not (bobp)) (1- (point)) (point))
- (progn (outline-pre-next-preface)
- (if (= ?\r (following-char))
- (point)
- (1- (point))))
- ?\r)))
-;;;_ > outline-show-to-offshoot ()
-(defun outline-show-to-offshoot ()
- "Like outline-show-entry, but reveals opens all concealed ancestors, as well.
-
-As with outline-hide-current-entry-completely, useful for rectifying
-aberrant exposure states produced by outline-show-entry."
-
- (interactive)
- (save-excursion
- (let ((orig-pt (point))
- (orig-pref (outline-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)
- (outline-show-current-subtree)
- (goto-char orig-pt)
- (setq bag-it t)
- (beep)
- (message "%s: %s"
- "outline-show-to-offshoot: "
- "Aberrant nesting encountered.")))
- (outline-show-children)
- (goto-char orig-pref))
- (goto-char orig-pt)))
- (if (outline-hidden-p)
- (outline-show-entry)))
-;;;_ > 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 following current heading, or hide the entry 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-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.
-
-Specifically intended for aberrant exposure states, like entries that were
-exposed by outline-show-entry but are within otherwise concealed regions."
- (interactive)
- (save-excursion
- (outline-goto-prefix)
- (outline-flag-region (if (not (bobp)) (1- (point)) (point))
- (progn (outline-pre-next-preface)
- (if (= ?\r (following-char))
- (point)
- (1- (point))))
- ?\r)))
-;;;_ > outline-show-current-subtree (&optional arg)
-(defun outline-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 (<= (outline-current-depth) 0)
- ;; Outside any topics - try to get to the first:
- (if (not (outline-next-heading))
- (error "No topics.")
- ;; got to first, outermost topic - set to expose it and siblings:
- (message "Above outermost topic - exposing all.")
- (outline-flag-region (point-min)(point-max) ?\n))
- (if (not arg)
- (outline-flag-current-subtree ?\n)
- (outline-beginning-of-level)
- (outline-expose-topic '(* :))))))
-;;;_ > outline-hide-current-subtree (&optional just-close)
-(defun outline-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 (outline-goto-prefix))
- (error "No topics found.")
- (end-of-line)(point)))))
- (outline-flag-current-subtree ?\^M)
- (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 (outline-up-current-level 1 t)
- t
- (goto-char 0)
- (let ((msg
- "Top-level topic already closed - closing siblings..."))
- (message msg)
- (outline-expose-topic '(0 :))
- (message (concat msg " Done.")))
- nil)
- (/= (outline-recent-depth) 0))
- (outline-hide-current-subtree))
- (goto-char from)))
-;;;_ > outline-show-current-branches ()
-(defun outline-show-current-branches ()
- "Show all subheadings of this heading, but not their bodies."
- (interactive)
- (beginning-of-line)
- (outline-show-children t))
-;;;_ > outline-hide-current-leaves ()
-(defun outline-hide-current-leaves ()
- "Hide the bodies of the current topic and all its' offspring."
- (interactive)
- (outline-back-to-current-heading)
- (outline-hide-region-body (point) (progn (outline-end-of-current-subtree)
- (point))))
-
-;;;_ - Region and beyond
-;;;_ > outline-show-all ()
-(defun outline-show-all ()
- "Show all of the text in the buffer."
- (interactive)
- (message "Exposing entire buffer...")
- (outline-flag-region (point-min) (point-max) ?\n)
- (message "Exposing entire buffer... Done."))
-;;;_ > 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\r][\n\r]")
- 2 1)))))))
-
-;;;_ > outline-expose-topic (spec)
-(defun outline-expose-topic (spec)
- "Apply exposure specs to successive outline topic items.
-
-Use the more convenient frontend, `outline-new-exposure', if you don't
-need evaluation of the arguments, or even better, the `outline-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:
-\(outline-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.
-\(outline-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.
-\(outline-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 (outline-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 '*) (outline-show-current-subtree)
- (if (> outline-recent-end-of-subtree max-pos)
- (setq max-pos outline-recent-end-of-subtree)))
- ((eq curr-elem '+) (outline-show-current-branches)
- (if (> outline-recent-end-of-subtree max-pos)
- (setq max-pos outline-recent-end-of-subtree)))
- ((eq curr-elem '-) (outline-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 (outline-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) (outline-visible-p))
- (save-excursion (outline-hide-current-subtree t)
- (if (> 0 curr-elem)
- nil
- (if (> outline-recent-end-of-subtree max-pos)
- (setq max-pos
- outline-recent-end-of-subtree)))))
- (if (> (abs curr-elem) 0)
- (progn (outline-show-children (abs curr-elem))
- (if (> outline-recent-end-of-subtree max-pos)
- (setq max-pos outline-recent-end-of-subtree)))))
- ((listp curr-elem)
- (if (outline-descend-to-depth (1+ depth))
- (let ((got (outline-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))
- (outline-next-heading)))
- ((outline-next-sibling depth))))
- max-pos)))
-;;;_ > outline-old-expose-topic (spec &rest followers)
-(defun outline-old-expose-topic (spec &rest followers)
-
- "Deprecated. Use outline-expose-topic \(with different schema
-format\) instead.
-
-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 FOLLOWER arguments dictate exposure for succeeding siblings."
-
- (interactive "xExposure spec: ")
- (let ((depth (outline-current-depth))
- done
- max-pos)
- (cond ((null spec) nil)
- ((symbolp spec)
- (if (eq spec '*) (outline-show-current-subtree))
- (if (eq spec '+) (outline-show-current-branches))
- (if (eq spec '-) (outline-show-current-entry)))
- ((numberp spec)
- (if (>= 0 spec)
- (save-excursion (outline-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)
- (outline-show-children spec)))
- ((listp spec)
- ;(let ((got (outline-old-expose-topic (car spec))))
- ; (if (and got (or (not max-pos) (> got max-pos)))
- ; (setq max-pos got)))
- (let ((new-depth (+ (outline-current-depth) 1))
- got)
- (setq max-pos (outline-old-expose-topic (car spec)))
- (setq spec (cdr spec))
- (if (and spec
- (outline-descend-to-depth new-depth)
- (not (outline-hidden-p)))
- (progn (setq got (apply 'outline-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)
- (outline-next-sibling depth)))
- (outline-old-expose-topic (car followers))
- (setq followers (cdr followers)))
- max-pos))
-;;;_ > outline-new-exposure '()
-(defmacro outline-new-exposure (&rest spec)
- "Literal frontend for `outline-expose-topic', doesn't evaluate arguments.
-Some arguments that would need to be quoted in outline-expose-topic
-need not be quoted in outline-new-exposure.
-
-Cursor is left at start position.
-
-Use this instead of obsolete 'outline-exposure'.
-
-Examples:
-\(outline-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.
-\(outline-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.
-\(outline-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 (outline-goto-prefix)
- (outline-next-heading)))
- (error "outline-new-exposure: Can't find any outline topics."))
- (list 'outline-expose-topic (list 'quote spec))))
-;;;_ > outline-exposure '()
-(defmacro outline-exposure (&rest spec)
- "Being deprecated - use more recent 'outline-new-exposure' instead.
-
-Literal frontend for `outline-old-expose-topic', doesn't evaluate arguments
-and retains start position."
- (list 'save-excursion
- '(if (not (or (outline-goto-prefix)
- (outline-next-heading)))
- (error "Can't find any outline topics."))
- (cons 'outline-old-expose-topic
- (mapcar '(lambda (x) (list 'quote x)) spec))))
-
-;;;_ #7 ISearch with Dynamic Exposure
-;;;_ = outline-search-reconceal
-(defvar outline-search-reconceal nil
- "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
- "Distinguishes isearch conclusion and cancellation.
-
-Used by isearch-terminate/outline-provisions and
-isearch-done/outline-provisions")
-
-
-;;;_ > outline-enwrap-isearch ()
-(defun outline-enwrap-isearch ()
- "Impose outline-mode isearch-mode wrappers for dynamic exposure in isearch.
-
-Isearch progressively exposes and reconceals hidden topics when
-working in outline mode, but works normally 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:
- 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 isearch 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.
-
-Registers 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 (outline-mode-p)
- (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.
-
-Works according to reconceal state registration."
- (if (and (outline-mode-p) 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 (outline-mode-p) 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 (outline-mode-p) outline-enwrap-isearch-mode)
- (progn (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:
- (save-excursion
- (message "(exposing destination)")(sit-for 0)
- (outline-goto-prefix)
- ; There may be a closed blank
- ; line between prior and
- ; current topic that would be
- ; missed - provide for it:
- (if (not (bobp))
- (progn (forward-char -1) ; newline
- (if (eq ?\r (preceding-char))
- (outline-flag-region (1- (point))
- (point)
- ?\n))
- (forward-char 1)))
- ; Goto parent
- (outline-ascend-to-depth (1- (outline-recent-depth)))
- (outline-show-children)))
- (if (and (boundp 'outline-search-quitting)
- outline-search-quitting)
- nil
- ; We're concluding abort:
- (outline-isearch-arrival-business)
- (outline-show-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 dynamically adjusts isearch target exposure.
-
-Appropriately exposes and reconceals hidden outline portions, as
-necessary, in the course of searching."
- (if (not (and (outline-mode-p) 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)))))
-
-;;;_ #8 Copying and printing
-
-;;;_ - Copy exposed
-;;;_ > outline-insert-listified (depth prefix bullet text)
-(defun outline-insert-listified (depth prefix bullet text)
- "Insert contents of listified outline portion in current buffer."
- (insert-string (concat (if (> depth 1) prefix "")
- (make-string (1- depth) ?\ )
- bullet))
- (while text
- (insert-string (car text))
- (if (setq text (cdr text))
- (insert-string "\n")))
- (insert-string "\n"))
-;;;_ > outline-copy-exposed (arg &optional tobuf)
-(defun outline-copy-exposed (arg &optional tobuf)
- "Duplicate exposed portions of current topic to another buffer.
-
-Other buffer has current buffers' name with \" exposed\" appended to it.
-
-With repeat count, copy the exposed portions of entire buffer."
-
- (interactive "P")
- (if (not tobuf)
- (setq tobuf (get-buffer-create (concat "*" (buffer-name) " exposed*"))))
- (let* ((start-pt (point))
- (beg (if arg (point-min) (outline-back-to-current-heading)))
- (end (if arg (point-max) (outline-end-of-current-subtree)))
- (buf (current-buffer)))
- (save-excursion (set-buffer tobuf)(erase-buffer))
- (outline-process-exposed 'outline-insert-listified
- beg
- end
- (current-buffer)
- tobuf)
- (goto-char (point-min))
- (pop-to-buffer buf)
- (goto-char start-pt)))
-
-;;;_ - LaTeX formatting
-;;;_ > outline-latex-verb-quote (str &optional flow)
-(defun outline-latex-verb-quote (str &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 '(lambda (char)
- ;;;mess: (cond ((memq char '(?"" ?$ ?% ?# ?& ?- ?" ?` ?^ ?- ?*));;;"))))
- (cond ((memq char '(?\\ ?$ ?% ?# ?& ?{ ?} ?_ ?^ ?- ?*))
- (concat "\\char" (number-to-string char) "{}"))
- ((= char ?\n) "\\\\")
- (t (char-to-string char))))
- str
- ""))
-;;;_ > outline-latex-verbatim-quote-curr-line ()
-(defun outline-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-string "\\")
- (setq end (1+ end))
- (goto-char (1+ (match-end 0))))))
-;;;_ > outline-insert-latex-header (buf)
-(defun outline-insert-latex-header (buf)
- "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 buf)
- (let ((doc-style (format "\n\\documentstyle{%s}\n"
- "report"))
- (page-numbering (if outline-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"
- outline-title-style))
- (labelcmd (format "\\newcommand{\\labelcmd}[1]{{%s #1}}\n"
- outline-label-style))
- (headlinecmd (format "\\newcommand{\\headlinecmd}[1]{{%s #1}}\n"
- outline-head-line-style))
- (bodylinecmd (format "\\newcommand{\\bodylinecmd}[1]{{%s #1}}\n"
- outline-body-line-style))
- (setlength (format "%s%s%s%s"
- "\\newlength{\\stepsize}\n"
- "\\setlength{\\stepsize}{"
- outline-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}\\\\["
- outline-line-skip
- "]\n}\n"))
- (onebodyline (format "%s%s%s%s%s%s"
- "\\newcommand{\\OneBodyLine}[2]{%\n"
- "\\noindent%\n"
- "\\hspace*{#1\\stepsize}%\n"
- "\\bodylinecmd{#2}\\\\["
- outline-line-skip
- "]\n}\n"))
- (begindoc "\\begin{document}\n\\begin{center}\n")
- (title (format "%s%s%s%s"
- "\\titlecmd{"
- (outline-latex-verb-quote (if outline-title
- (condition-case err
- (eval outline-title)
- (error "<unnamed buffer>"))
- "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)
- )))
-;;;_ > outline-insert-latex-trailer (buf)
-(defun outline-insert-latex-trailer (buf)
- "Insert concluding latex commands at point in BUFFER."
- (set-buffer buf)
- (insert "\n\\end{document}\n"))
-;;;_ > outline-latexify-one-item (depth prefix bullet text)
-(defun outline-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-string (concat "\\OneHeadLine{\\verb\1 "
- (outline-latex-verb-quote bullet)
- "\1}{"
- depth
- "}{\\verb\1 "
- (if head-line
- (outline-latex-verb-quote head-line)
- "")
- "\1}\n"))
- (if (not body-lines)
- nil
- ;;(insert-string "\\beginlines\n")
- (insert-string "\\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-string "|" (car body-lines) "|")
- (insert-string curr-line)
- (outline-latex-verbatim-quote-curr-line)
- (insert-string "\n")
- (setq body-lines (cdr body-lines)))
- (if body-content
- (setq body-content nil)
- (forward-char -1)
- (insert-string "\\ ")
- (forward-char 1))
- ;;(insert-string "\\endlines\n")
- (insert-string "\\end{verbatim}\n")
- )))
-;;;_ > outline-latexify-exposed (arg &optional tobuf)
-(defun outline-latexify-exposed (arg &optional tobuf)
- "Format current topic's 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) (outline-back-to-current-heading)))
- (end (if arg (point-max) (outline-end-of-current-subtree)))
- (buf (current-buffer)))
- (set-buffer tobuf)
- (erase-buffer)
- (outline-insert-latex-header tobuf)
- (goto-char (point-max))
- (outline-process-exposed 'outline-latexify-one-item
- beg
- end
- buf
- tobuf)
- (goto-char (point-max))
- (outline-insert-latex-trailer tobuf)
- (goto-char (point-min))
- (pop-to-buffer buf)
- (goto-char start-pt)))
-
-;;;_ #9 miscellaneous
-;;;_ > outline-mark-topic ()
-(defun outline-mark-topic ()
- "Put the region around topic currently containing point."
- (interactive)
- (beginning-of-line)
- (outline-goto-prefix)
- (push-mark (point))
- (outline-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 `outline-layout' and `outline-init' for details on
-setup for auto-startup."
-
- (interactive "P")
-
- (outline-mode t)
-
- (save-excursion
- (goto-char (point-min))
- (if (looking-at outline-regexp)
- t
- (outline-open-topic 2)
- (insert-string (concat "Dummy outline topic header - see"
- "`outline-mode' docstring for info."))
- (next-line 1)
- (goto-char (point-max))
- (next-line 1)
- (outline-open-topic 0)
- (insert-string "Local emacs vars.\n")
- (outline-open-topic 1)
- (insert-string "(`outline-layout' is for allout.el outline-mode)\n")
- (outline-open-topic 0)
- (insert-string "Local variables:\n")
- (outline-open-topic 0)
- (insert-string (format "outline-layout: %s\n"
- (or outline-layout
- '(1 : 0))))
- (outline-open-topic 0)
- (insert-string "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.
-
-Optional arg DO-DEFAULTING indicates to accept empty input (CR)."
-
- (let ((new-prompt prompt)
- got)
-
- (while (not got)
- (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.)
- (setq got
- (char-to-string (let ((cursor-in-echo-area nil)) (read-char))))
-
- (if (null (string-match (regexp-quote 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)
- )
-;;;_ > 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.
-
-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))))
-;;;_ - 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)))))))
-
-;;;_ #10 Under development
-;;;_ > outline-bullet-isearch (&optional bullet)
-(defun outline-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 outline-bullets-string))))
-
- (let ((isearch-regexp t)
- (isearch-string (concat "^"
- outline-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.
-;;; The following `outline-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:
-;;;outline-layout: (0 : -1 -1 0)
-;;;End:
-
-;; allout.el ends here
+;;; allout.el --- extensive outline mode for use alone and with other modes
+
+;; Copyright (C) 1992, 1993, 1994, 2001, 2002, 2003, 2004,
+;; 2005, 2006 Free Software Foundation, Inc.
+
+;; Author: Ken Manheimer <ken dot manheimer at gmail dot com>
+;; Maintainer: Ken Manheimer <ken dot manheimer at gmail dot com>
+;; Created: Dec 1991 - first release to usenet
+;; Version: 2.2.1
+;; Keywords: outlines wp languages
+;; Website: http://myriadicity.net/Sundry/EmacsAllout
+
+;; 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; 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 minor mode provides extensive outline formatting and
+;; and manipulation beyond standard emacs outline mode. Some features:
+;;
+;; - Classic outline-mode topic-oriented navigation and exposure adjustment
+;; - Topic-oriented editing including coherent topic and subtopic
+;; creation, promotion, demotion, cut/paste across depths, etc.
+;; - Incremental search with dynamic exposure and reconcealment of text
+;; - Customizable bullet format - enables programming-language specific
+;; outlining, for code-folding editing. (Allout code itself is to try it;
+;; formatted as an outline - do ESC-x eval-buffer in allout.el; but
+;; emacs local file variables need to be enabled when the
+;; file was visited - see `enable-local-variables'.)
+;; - Configurable per-file initial exposure settings
+;; - Symmetric-key and key-pair topic encryption, plus symmetric passphrase
+;; mnemonic support, with verification against an established passphrase
+;; (using a stashed encrypted dummy string) and user-supplied hint
+;; maintenance. (See allout-toggle-current-subtree-encryption docstring.)
+;; - Automatic topic-number maintenance
+;; - "Hot-spot" operation, for single-keystroke maneuvering and
+;; exposure control (see the allout-mode docstring)
+;; - Easy rendering of exposed portions into numbered, latex, indented, etc
+;; outline styles
+;; - Careful attention to whitespace - enabling blank lines between items
+;; and maintenance of hanging indentation (in paragraph auto-fill and
+;; across topic promotion and demotion) of topic bodies consistent with
+;; indentation of their topic header.
+;;
+;; and more.
+;;
+;; See the `allout-mode' function's docstring for an introduction to the
+;; mode.
+;;
+;; The latest development version and helpful notes are available at
+;; http://myriadicity.net/Sundry/EmacsAllout .
+;;
+;; The outline menubar additions provide quick reference to many of
+;; the features, and see the docstring of the variable `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-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-buffer' to give it a whirl.
+
+;; ken manheimer (ken dot manheimer at gmail dot com)
+
+;;; Code:
+
+;;;_* Dependency autoloads
+(require 'overlay)
+(eval-when-compile
+ ;; Most of the requires here are for stuff covered by autoloads.
+ ;; Since just byte-compiling doesn't trigger autoloads, so that
+ ;; "function not found" warnings would occur without these requires.
+ (progn
+ (require 'pgg)
+ (require 'pgg-gpg)
+ (require 'overlay)
+ ;; `cl' is required for `assert'. `assert' is not covered by a standard
+ ;; autoload, but it is a macro, so that eval-when-compile is sufficient
+ ;; to byte-compile it in, or to do the require when the buffer evalled.
+ (require 'cl)
+ ))
+
+;;;_* USER CUSTOMIZATION VARIABLES:
+
+;;;_ > defgroup allout
+(defgroup allout nil
+ "Extensive outline mode for use alone and with other modes."
+ :prefix "allout-"
+ :group 'outlines)
+
+;;;_ + 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-default-layout
+(defcustom allout-default-layout '(-2 : 0)
+ "*Default allout outline layout specification.
+
+This setting specifies the outline exposure to use when
+`allout-layout' has the local value `t'. This docstring describes the
+layout specifications.
+
+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 this behavior.
+
+The types of elements in the layout specification are:
+
+ integer - dictate the relative depth to open the corresponding topic(s),
+ where:
+ - 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 subitems.
+ : - repeat spec - apply the preceeding 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
+ trailing ones accounted for by trailing specs. \(Only the first of
+ multiple colons at the same level is honored - later ones are ignored.)
+ * - completely exposes the topic, including bodies
+ + - exposes all subtopics, but not the bodies
+ - - exposes the body of the corresponding topic, but not subtopics
+ list - a nested layout spec, to be applied intricately to its
+ corresponding item(s)
+
+Examples:
+ '(-2 : 0)
+ Collapse the top-level topics to show their children and
+ grandchildren, but completely collapse the final top-level topic.
+ '(-1 () : 1 0)
+ Close the first topic so only the immediate subtopics are shown,
+ leave the subsequent topics exposed as they are until the second
+ second to last topic, which is exposed at least one level, and
+ completely close the last 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 expose the last one, including its subtopics.
+
+See `allout-expose-topic' for more about the exposure process.
+
+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."
+ :type 'allout-layout-type
+ :group 'allout)
+;;;_ : allout-layout-type
+(define-widget 'allout-layout-type 'lazy
+ "Allout layout format customization basic building blocks."
+ :type '(repeat
+ (choice (integer :tag "integer (<= zero is strict)")
+ (const :tag ": (repeat prior)" :)
+ (const :tag "* (completely expose)" *)
+ (const :tag "+ (expose all offspring, headlines only)" +)
+ (const :tag "- (expose topic body but not offspring)" -)
+ (allout-layout-type :tag "<Nested 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)
+;;;###autoload
+(put 'allout-show-bodies 'safe-local-variable
+ (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil)))))
+
+;;;_ = allout-beginning-of-line-cycles
+(defcustom allout-beginning-of-line-cycles t
+ "*If non-nil, \\[allout-beginning-of-line] will cycle through smart-placement options.
+
+Cycling only happens on when the command is repeated, not when it
+follows a different command.
+
+Smart-placement means that repeated calls to this function will
+advance as follows:
+
+ - if the cursor is on a non-headline body line and not on the first column:
+ then it goes to the first column
+ - if the cursor is on the first column of a non-headline body line:
+ then it goes to the start of the headline within the item body
+ - if the cursor is on the headline and not the start of the headline:
+ then it goes to the start of the headline
+ - if the cursor is on the start of the headline:
+ then it goes to the bullet character \(for hotspot navigation\)
+ - if the cursor is on the bullet character:
+ then it goes to the first column of that line \(the headline\)
+ - if the cursor is on the first column of the headline:
+ then it goes to the start of the headline within the item body.
+
+In this fashion, you can use the beginning-of-line command to do
+its normal job and then, when repeated, advance through the
+entry, cycling back to start.
+
+If this configuration variable is nil, then the cursor is just
+advanced to the beginning of the line and remains there on
+repeated calls."
+ :type 'boolean :group 'allout)
+;;;_ = allout-end-of-line-cycles
+(defcustom allout-end-of-line-cycles t
+ "*If non-nil, \\[allout-end-of-line] will cycle through smart-placement options.
+
+Cycling only happens on when the command is repeated, not when it
+follows a different command.
+
+Smart-placement means that repeated calls to this function will
+advance as follows:
+
+ - if the cursor is not on the end-of-line,
+ then it goes to the end-of-line
+ - if the cursor is on the end-of-line but not the end-of-entry,
+ then it goes to the end-of-entry, exposing it if necessary
+ - if the cursor is on the end-of-entry,
+ then it goes to the end of the head line
+
+In this fashion, you can use the end-of-line command to do its
+normal job and then, when repeated, advance through the entry,
+cycling back to start.
+
+If this configuration variable is nil, then the cursor is just
+advanced to the end of the line and remains there on repeated
+calls."
+ :type 'boolean :group 'allout)
+
+;;;_ = allout-header-prefix
+(defcustom allout-header-prefix "."
+;; this string is treated as literal match. it will be `regexp-quote'd, so
+;; one cannot use regular expressions to match varying header prefixes.
+ "*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'."
+ :type 'string
+ :group 'allout)
+(make-variable-buffer-local 'allout-header-prefix)
+;;;###autoload
+(put 'allout-header-prefix 'safe-local-variable 'stringp)
+;;;_ = 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)
+;;;###autoload
+(put 'allout-primary-bullet 'safe-local-variable 'stringp)
+;;;_ = 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)
+;;;###autoload
+(put 'allout-plain-bullets-string 'safe-local-variable 'stringp)
+;;;_ = 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 quotation
+ `=' value settings
+ `~' \"more or less\"
+ `^' see above
+
+ ... 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)
+;;;###autoload
+(put 'allout-distinctive-bullets-string 'safe-local-variable 'stringp)
+
+;;;_ = 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' or
+comment-start string, if any, to lead the topic prefix string, so topic
+headers look like comments in the programming language. It will also use
+the comment-start string, with an '_' appended, for `allout-primary-bullet'.
+
+String values are used as literals, not regular expressions, so
+do not escape any regulare-expression characters.
+
+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 \(`.') and leave
+`allout-primary-bullet' unaltered.
+
+comment-start strings that do not end in spaces are tripled in
+the header-prefix, 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
+undesired.]"
+ :type '(choice (const t) (const nil) string
+ (const allout-mode-leaders)
+ (const comment-start))
+ :group 'allout)
+;;;###autoload
+(put 'allout-use-mode-specific-leader 'safe-local-variable
+ '(lambda (x) (or (memq x '(t nil allout-mode-leaders comment-start))
+ (stringp x))))
+;;;_ = allout-mode-leaders
+(defvar allout-mode-leaders '()
+ "Specific allout-prefix leading strings per major modes.
+
+Use this if the mode's comment-start string isn't what you
+prefer, or if the mode lacks a comment-start string. See
+`allout-use-mode-specific-leader' for more details.
+
+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 the beginning-of-line.")
+
+;;;_ = 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)
+;;;###autoload
+(put 'allout-old-style-prefixes 'safe-local-variable
+ (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil)))))
+;;;_ = 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)
+;;;###autoload
+(put 'allout-stylish-prefixes 'safe-local-variable
+ (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil)))))
+
+;;;_ = 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)
+;;;###autoload
+(put 'allout-numbered-bullet 'safe-local-variable
+ (if (fboundp 'string-or-null-p)
+ 'string-or-null-p
+ '(lambda (x) (or (stringp x) (null x)))))
+;;;_ = 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)
+;;;###autoload
+(put 'allout-file-xref-bullet 'safe-local-variable
+ (if (fboundp 'string-or-null-p)
+ 'string-or-null-p
+ '(lambda (x) (or (stringp x) (null x)))))
+;;;_ = 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)
+;;;###autoload
+(put 'allout-presentation-padding 'safe-local-variable 'integerp)
+
+;;;_ = 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 (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)
+
+;;;_ + Topic encryption
+;;;_ = allout-encryption group
+(defgroup allout-encryption nil
+ "Settings for topic encryption features of allout outliner."
+ :group 'allout)
+;;;_ = allout-topic-encryption-bullet
+(defcustom allout-topic-encryption-bullet "~"
+ "*Bullet signifying encryption of the entry's body."
+ :type '(choice (const nil) string)
+ :version "22.0"
+ :group 'allout-encryption)
+;;;_ = allout-passphrase-verifier-handling
+(defcustom allout-passphrase-verifier-handling t
+ "*Enable use of symmetric encryption passphrase verifier if non-nil.
+
+See the docstring for the `allout-enable-file-variable-adjustment'
+variable for details about allout ajustment of file variables."
+ :type 'boolean
+ :version "22.0"
+ :group 'allout-encryption)
+(make-variable-buffer-local 'allout-passphrase-verifier-handling)
+;;;_ = allout-passphrase-hint-handling
+(defcustom allout-passphrase-hint-handling 'always
+ "*Dictate outline encryption passphrase reminder handling:
+
+ always - always show reminder when prompting
+ needed - show reminder on passphrase entry failure
+ disabled - never present or adjust reminder
+
+See the docstring for the `allout-enable-file-variable-adjustment'
+variable for details about allout ajustment of file variables."
+ :type '(choice (const always)
+ (const needed)
+ (const disabled))
+ :version "22.0"
+ :group 'allout-encryption)
+(make-variable-buffer-local 'allout-passphrase-hint-handling)
+;;;_ = allout-encrypt-unencrypted-on-saves
+(defcustom allout-encrypt-unencrypted-on-saves t
+ "*When saving, should topics pending encryption be encrypted?
+
+The idea is to prevent file-system exposure of any un-encrypted stuff, and
+mostly covers both deliberate file writes and auto-saves.
+
+ - Yes: encrypt all topics pending encryption, even if it's the one
+ currently being edited. \(In that case, the currently edited topic
+ will be automatically decrypted before any user interaction, so they
+ can continue editing but the copy on the file system will be
+ encrypted.)
+ Auto-saves will use the \"All except current topic\" mode if this
+ one is selected, to avoid practical difficulties - see below.
+ - All except current topic: skip the topic currently being edited, even if
+ it's pending encryption. This may expose the current topic on the
+ file sytem, but avoids the nuisance of prompts for the encryption
+ passphrase in the middle of editing for, eg, autosaves.
+ This mode is used for auto-saves for both this option and \"Yes\".
+ - No: leave it to the user to encrypt any unencrypted topics.
+
+For practical reasons, auto-saves always use the 'except-current policy
+when auto-encryption is enabled. \(Otherwise, spurious passphrase prompts
+and unavoidable timing collisions are too disruptive.) If security for a
+file requires that even the current topic is never auto-saved in the clear,
+disable auto-saves for that file."
+
+ :type '(choice (const :tag "Yes" t)
+ (const :tag "All except current topic" except-current)
+ (const :tag "No" nil))
+ :version "22.0"
+ :group 'allout-encryption)
+(make-variable-buffer-local 'allout-encrypt-unencrypted-on-saves)
+
+;;;_ + Developer
+;;;_ = allout-developer group
+(defgroup allout-developer nil
+ "Settings for topic encryption features of allout outliner."
+ :group 'allout)
+;;;_ = allout-run-unit-tests-on-load
+(defcustom allout-run-unit-tests-on-load nil
+ "*When non-nil, unit tests will be run at end of loading the allout module.
+
+Generally, allout code developers are the only ones who'll want to set this.
+
+\(If set, this makes it an even better practice to exercise changes by
+doing byte-compilation with a repeat count, so the file is loaded after
+compilation.)
+
+See `allout-run-unit-tests' to see what's run."
+ :type 'boolean
+ :group 'allout-developer)
+
+;;;_ + Miscellaneous customization
+
+;;;_ = allout-command-prefix
+(defcustom allout-command-prefix "\C-c "
+ "*Key sequence to be used as prefix for outline mode command key bindings.
+
+Default is '\C-c<space>'; just '\C-c' is more short-and-sweet, if you're
+willing to let allout use a bunch of \C-c keybindings."
+ :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-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-entry)
+ ; Exposure commands:
+ ("\C-i" allout-show-children)
+ ("\C-s" allout-show-current-subtree)
+ ("\C-h" allout-hide-current-subtree)
+ ("h" allout-hide-current-subtree)
+ ("\C-o" allout-show-current-entry)
+ ("!" allout-show-all)
+ ("x" allout-toggle-current-subtree-encryption)
+ ; Alteration commands:
+ (" " 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)
+ ("\M-k" allout-copy-line-as-kill t)
+ ("\C-y" allout-yank t)
+ ("\M-y" allout-yank-pop t)
+ ("\C-k" allout-kill-topic)
+ ("\M-k" allout-copy-topic-as-kill)
+ ; Miscellaneous commands:
+ ;([?\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-inhibit-auto-fill
+(defcustom allout-inhibit-auto-fill nil
+ "*If non-nil, auto-fill will be inhibited in the allout buffers.
+
+You can customize this setting to set it for all allout buffers, or set it
+in individual buffers if you want to inhibit auto-fill only in particular
+buffers. \(You could use a function on `allout-mode-hook' to inhibit
+auto-fill according, eg, to the major mode.\)
+
+If you don't set this and auto-fill-mode is enabled, allout will use the
+value that `normal-auto-fill-function', if any, when allout mode starts, or
+else allout's special hanging-indent maintaining auto-fill function,
+`allout-auto-fill'."
+ :type 'boolean
+ :group 'allout)
+(make-variable-buffer-local 'allout-inhibit-auto-fill)
+
+;;;_ = 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."
+ :type 'boolean
+ :group 'allout)
+(make-variable-buffer-local 'allout-use-hanging-indents)
+;;;###autoload
+(put 'allout-use-hanging-indents 'safe-local-variable
+ (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil)))))
+
+;;;_ = 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)
+;;;###autoload
+(put 'allout-reindent-bodies 'safe-local-variable
+ '(lambda (x) (memq x '(nil t text force))))
+
+;;;_ = allout-enable-file-variable-adjustment
+(defcustom allout-enable-file-variable-adjustment t
+ "*If non-nil, some allout outline actions edit Emacs local file var text.
+
+This can range from changes to existing entries, addition of new ones,
+and creation of a new local variables section when necessary.
+
+Emacs file variables adjustments are also inhibited if `enable-local-variables'
+is nil.
+
+Operations potentially causing edits include allout encryption routines.
+For details, see `allout-toggle-current-subtree-encryption's docstring."
+ :type 'boolean
+ :group 'allout)
+(make-variable-buffer-local 'allout-enable-file-variable-adjustment)
+
+;;;_* CODE - no user customizations below.
+
+;;;_ #1 Internal Outline Formatting and Configuration
+;;;_ : Version
+;;;_ = allout-version
+(defvar allout-version "2.2.1"
+ "Version 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))
+;;;_ : Mode activation (defined here because it's referenced early)
+;;;_ = allout-mode
+(defvar allout-mode nil "Allout outline mode minor-mode flag.")
+(make-variable-buffer-local 'allout-mode)
+;;;_ = allout-layout nil
+(defvar allout-layout nil ; LEAVE GLOBAL VALUE NIL - see docstring.
+ "Buffer-specific setting for allout layout.
+
+In buffers where this is non-nil \(and if `allout-init' has been run, to
+enable this behavior), `allout-mode' will be automatically activated. The
+layout dictated by the value will be used to set the initial exposure when
+`allout-mode' is activated.
+
+\*You should not setq-default this variable non-nil unless you want every
+visited file to be treated as an allout file.*
+
+The value would typically be set by a file local variable. For
+example, the following lines at the bottom of an Emacs Lisp file:
+
+;;;Local variables:
+;;;allout-layout: \(0 : -1 -1 0)
+;;;End:
+
+dictate activation of `allout-mode' mode when the file is visited
+\(presuming allout-init was already run), followed by the
+equivalent of `\(allout-expose-topic 0 : -1 -1 0)'. \(This is
+the layout used for the allout.el source file.)
+
+`allout-default-layout' describes the specification format.
+`allout-layout' can additionally have the value `t', in which
+case the value of `allout-default-layout' is used.")
+(make-variable-buffer-local 'allout-layout)
+;;;###autoload
+(put 'allout-layout 'safe-local-variable
+ '(lambda (x) (or (numberp x) (listp x) (memq x '(: * + -)))))
+
+;;;_ : 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-depth-specific-regexp
+(defvar allout-depth-specific-regexp ""
+ "*Regular expression to match a heading line prefix for a particular depth.
+
+This expression is used to search for depth-specific topic
+headers at depth 2 and greater. Use `allout-depth-one-regexp'
+for to seek topics at depth one.
+
+This var is set according to the user configuration vars by
+`set-allout-regexp'. It is prepared with format strings for two
+decimal numbers, which should each be one less than the depth of the
+topic prefix to be matched.")
+(make-variable-buffer-local 'allout-depth-specific-regexp)
+;;;_ = allout-depth-one-regexp
+(defvar allout-depth-one-regexp ""
+ "*Regular expression to match a heading line prefix for depth one.
+
+This var is set according to the user configuration vars by
+`set-allout-regexp'. It is prepared with format strings for two
+decimal numbers, which should each be one less than the depth of the
+topic prefix to be matched.")
+(make-variable-buffer-local 'allout-depth-one-regexp)
+;;;_ = allout-line-boundary-regexp
+(defvar allout-line-boundary-regexp ()
+ "`allout-regexp' with outline style beginning-of-line anchor.
+
+This is properly set by `set-allout-regexp'.")
+(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.")
+(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)
+
+;;;_ = allout-doublecheck-at-and-shallower
+(defconst allout-doublecheck-at-and-shallower 3
+ "Verify apparent topics of this depth and shallower as being non-aberrant.
+
+Verified with `allout-aberrant-container-p'. This check's usefulness is
+limited to shallow prospects, because the determination of aberrance
+depends on the mistaken item being followed by a legitimate item of
+excessively greater depth.")
+;;;_ 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 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 allout-reindent-bodies nil)
+ (allout-reset-header-lead header-lead)
+ header-lead)
+;;;_ > allout-infer-header-lead-and-primary-bullet ()
+(defun allout-infer-header-lead-and-primary-bullet ()
+ "Determine appropriate `allout-header-prefix' and `allout-primary-bullet'.
+
+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
+ (setq allout-header-prefix leader)
+ (if (not allout-old-style-prefixes)
+ ;; setting allout-primary-bullet makes the top level topics use -
+ ;; actually, be - the special prefix:
+ (setq allout-primary-bullet leader))
+ allout-header-prefix)))
+(defalias 'allout-infer-header-lead
+ 'allout-infer-header-lead-and-primary-bullet)
+;;;_ > 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'.
+
+Also refresh various data structures that hinge on the regexp."
+
+ (interactive)
+ ;; 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
+ index)
+ (while strings
+ (setq index 0)
+ (setq cur-len (length (setq cur-string (symbol-value (car strings)))))
+ (while (< index cur-len)
+ (setq cur-char (aref cur-string index))
+ (setq allout-bullets-string
+ (concat allout-bullets-string
+ (cond
+ ; Single dash would denote a
+ ; sequence, repeated denotes
+ ; a dash:
+ ((eq cur-char ?-) "--")
+ ; literal close-square-bracket
+ ; doesn't work right in the
+ ; expr, exclude it:
+ ((eq cur-char ?\]) "")
+ (t (regexp-quote (char-to-string cur-char))))))
+ (setq index (1+ index)))
+ (setq strings (cdr strings)))
+ )
+ ;; 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)))
+
+ (let (new-part old-part)
+ (setq new-part (concat "\\("
+ (regexp-quote allout-header-prefix)
+ "[ \t]*"
+ ;; already regexp-quoted in a custom way:
+ "[" allout-bullets-string "]"
+ "\\)")
+ old-part (concat "\\("
+ (regexp-quote allout-primary-bullet)
+ "\\|"
+ (regexp-quote allout-header-prefix)
+ "\\)"
+ "+"
+ " ?[^" allout-primary-bullet "]")
+ allout-regexp (concat new-part
+ "\\|"
+ old-part
+ "\\|\^l")
+
+ allout-line-boundary-regexp (concat "\n" new-part
+ "\\|"
+ "\n" old-part)
+
+ allout-bob-regexp (concat "\\`" new-part
+ "\\|"
+ "\\`" old-part))
+
+ (setq allout-depth-specific-regexp
+ (concat "\\(^\\|\\`\\)"
+ "\\("
+
+ ;; new-style spacers-then-bullet string:
+ "\\("
+ (allout-format-quote (regexp-quote allout-header-prefix))
+ " \\{%s\\}"
+ "[" (allout-format-quote allout-bullets-string) "]"
+ "\\)"
+
+ ;; old-style all-bullets string, if primary not multi-char:
+ (if (< 0 allout-header-subtraction)
+ ""
+ (concat "\\|\\("
+ (allout-format-quote
+ (regexp-quote allout-primary-bullet))
+ (allout-format-quote
+ (regexp-quote allout-primary-bullet))
+ (allout-format-quote
+ (regexp-quote allout-primary-bullet))
+ "\\{%s\\}"
+ ;; disqualify greater depths:
+ "[^"
+ (allout-format-quote allout-primary-bullet)
+ "]\\)"
+ ))
+ "\\)"
+ ))
+ (setq allout-depth-one-regexp
+ (concat "\\(^\\|\\`\\)"
+ "\\("
+
+ "\\("
+ (regexp-quote allout-header-prefix)
+ ;; disqualify any bullet char following any amount of
+ ;; intervening whitespace:
+ " *"
+ (concat "[^ " allout-bullets-string "]")
+ "\\)"
+ (if (< 0 allout-header-subtraction)
+ ;; Need not support anything like the old
+ ;; bullet style if the prefix is multi-char.
+ ""
+ (concat "\\|"
+ (regexp-quote allout-primary-bullet)
+ ;; disqualify deeper primary-bullet sequences:
+ "[^" allout-primary-bullet "]"))
+ "\\)"
+ ))))
+;;;_ : 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]
+ "----"
+ ["Toggle Topic Encryption"
+ allout-toggle-current-subtree-encryption
+ (> (allout-current-depth) 1)]))
+ (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-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])))
+;;;_ : Allout Modal-Variables Utilities
+;;;_ = allout-mode-prior-settings
+(defvar allout-mode-prior-settings nil
+ "Internal `allout-mode' use; settings to be resumed on mode deactivation.
+
+See `allout-add-resumptions' and `allout-do-resumptions'.")
+(make-variable-buffer-local 'allout-mode-prior-settings)
+;;;_ > allout-add-resumptions (&rest pairs)
+(defun allout-add-resumptions (&rest pairs)
+ "Set name/value PAIRS.
+
+Old settings are preserved for later resumption using `allout-do-resumptions'.
+
+The new values are set as a buffer local. On resumption, the prior buffer
+scope of the variable is restored along with its value. If it was a void
+buffer-local value, then it is left as nil on resumption.
+
+The pairs are lists whose car is the name of the variable and car of the
+cdr is the new value: '(some-var some-value)'. The pairs can actually be
+triples, where the third element qualifies the disposition of the setting,
+as described further below.
+
+If the optional third element is the symbol 'extend, then the new value
+created by `cons'ing the second element of the pair onto the front of the
+existing value.
+
+If the optional third element is the symbol 'append, then the new value is
+extended from the existing one by `append'ing a list containing the second
+element of the pair onto the end of the existing value.
+
+Extension, and resumptions in general, should not be used for hook
+functions - use the 'local mode of `add-hook' for that, instead.
+
+The settings are stored on `allout-mode-prior-settings'."
+ (while pairs
+ (let* ((pair (pop pairs))
+ (name (car pair))
+ (value (cadr pair))
+ (qualifier (if (> (length pair) 2)
+ (caddr pair)))
+ prior-value)
+ (if (not (symbolp name))
+ (error "Pair's name, %S, must be a symbol, not %s"
+ name (type-of name)))
+ (setq prior-value (condition-case nil
+ (symbol-value name)
+ (void-variable nil)))
+ (when (not (assoc name allout-mode-prior-settings))
+ ;; Not already added as a resumption, create the prior setting entry.
+ (if (local-variable-p name)
+ ;; is already local variable - preserve the prior value:
+ (push (list name prior-value) allout-mode-prior-settings)
+ ;; wasn't local variable, indicate so for resumption by killing
+ ;; local value, and make it local:
+ (push (list name) allout-mode-prior-settings)
+ (make-local-variable name)))
+ (if qualifier
+ (cond ((eq qualifier 'extend)
+ (if (not (listp prior-value))
+ (error "extension of non-list prior value attempted")
+ (set name (cons value prior-value))))
+ ((eq qualifier 'append)
+ (if (not (listp prior-value))
+ (error "appending of non-list prior value attempted")
+ (set name (append prior-value (list value)))))
+ (t (error "unrecognized setting qualifier `%s' encountered"
+ qualifier)))
+ (set name value)))))
+;;;_ > allout-do-resumptions ()
+(defun allout-do-resumptions ()
+ "Resume all name/value settings registered by `allout-add-resumptions'.
+
+This is used when concluding allout-mode, to resume selected variables to
+their settings before allout-mode was started."
+
+ (while allout-mode-prior-settings
+ (let* ((pair (pop allout-mode-prior-settings))
+ (name (car pair))
+ (value-cell (cdr pair)))
+ (if (not value-cell)
+ ;; Prior value was global:
+ (kill-local-variable name)
+ ;; Prior value was explicit:
+ (set name (car value-cell))))))
+;;;_ : Mode-specific incidentals
+;;;_ > allout-unprotected (expr)
+(defmacro allout-unprotected (expr)
+ "Enable internal outline operations to alter invisible text."
+ `(let ((inhibit-read-only (if (not buffer-read-only) t))
+ (inhibit-field-text-motion t))
+ ,expr))
+;;;_ = allout-mode-hook
+(defvar allout-mode-hook nil
+ "*Hook that's run when allout mode starts.")
+;;;_ = allout-mode-deactivate-hook
+(defvar allout-mode-deactivate-hook nil
+ "*Hook that's run when allout mode ends.")
+;;;_ = allout-exposure-category
+(defvar allout-exposure-category nil
+ "Symbol for use as allout invisible-text overlay category.")
+;;;_ x allout-view-change-hook
+(defvar allout-view-change-hook nil
+ "*\(Deprecated\) A hook run after allout outline exposure changes.
+
+Switch to using `allout-exposure-change-hook' instead. Both hooks are
+currently respected, but the other conveys the details of the exposure
+change via explicit parameters, and this one will eventually be disabled in
+a subsequent allout version.")
+;;;_ = allout-exposure-change-hook
+(defvar allout-exposure-change-hook nil
+ "*Hook that's run after allout outline subtree exposure changes.
+
+It is run at the conclusion of `allout-flag-region'.
+
+Functions on the hook must take three arguments:
+
+ - from - integer indicating the point at the start of the change.
+ - to - integer indicating the point of the end of the change.
+ - flag - change mode: nil for exposure, otherwise concealment.
+
+This hook might be invoked multiple times by a single command.
+
+This hook is replacing `allout-view-change-hook', which is being deprecated
+and eventually will not be invoked.")
+;;;_ = allout-structure-added-hook
+(defvar allout-structure-added-hook nil
+ "*Hook that's run after addition of items to the outline.
+
+Functions on the hook should take two arguments:
+
+ - new-start - integer indicating the point at the start of the first new item.
+ - new-end - integer indicating the point of the end of the last new item.
+
+Some edits that introduce new items may missed by this hook -
+specifically edits that native allout routines do not control.
+
+This hook might be invoked multiple times by a single command.")
+;;;_ = allout-structure-deleted-hook
+(defvar allout-structure-deleted-hook nil
+ "*Hook that's run after disciplined deletion of subtrees from the outline.
+
+Functions on the hook must take two arguments:
+
+ - depth - integer indicating the depth of the subtree that was deleted.
+ - removed-from - integer indicating the point where the subtree was removed.
+
+Some edits that remove or invalidate items may missed by this hook -
+specifically edits that native allout routines do not control.
+
+This hook might be invoked multiple times by a single command.")
+;;;_ = allout-structure-shifted-hook
+(defvar allout-structure-shifted-hook nil
+ "*Hook that's run after shifting of items in the outline.
+
+Functions on the hook should take two arguments:
+
+ - depth-change - integer indicating depth increase, negative for decrease
+ - start - integer indicating the start point of the shifted parent item.
+
+Some edits that shift items can be missed by this hook - specifically edits
+that native allout routines do not control.
+
+This hook might be invoked multiple times by a single command.")
+;;;_ = allout-outside-normal-auto-fill-function
+(defvar allout-outside-normal-auto-fill-function nil
+ "Value of normal-auto-fill-function outside of allout mode.
+
+Used by allout-auto-fill to do the mandated normal-auto-fill-function
+wrapped within allout's automatic fill-prefix setting.")
+(make-variable-buffer-local 'allout-outside-normal-auto-fill-function)
+;;;_ = 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-passphrase-verifier-string
+(defvar allout-passphrase-verifier-string nil
+ "Setting used to test solicited encryption passphrases against the one
+already associated with a file.
+
+It consists of an encrypted random string useful only to verify that a
+passphrase entered by the user is effective for decryption. The passphrase
+itself is \*not* recorded in the file anywhere, and the encrypted contents
+are random binary characters to avoid exposing greater susceptibility to
+search attacks.
+
+The verifier string is retained as an Emacs file variable, as well as in
+the emacs buffer state, if file variable adjustments are enabled. See
+`allout-enable-file-variable-adjustment' for details about that.")
+(make-variable-buffer-local 'allout-passphrase-verifier-string)
+;;;###autoload
+(put 'allout-passphrase-verifier-string 'safe-local-variable 'stringp)
+;;;_ = allout-passphrase-hint-string
+(defvar allout-passphrase-hint-string ""
+ "Variable used to retain reminder string for file's encryption passphrase.
+
+See the description of `allout-passphrase-hint-handling' for details about how
+the reminder is deployed.
+
+The hint is retained as an Emacs file variable, as well as in the emacs buffer
+state, if file variable adjustments are enabled. See
+`allout-enable-file-variable-adjustment' for details about that.")
+(make-variable-buffer-local 'allout-passphrase-hint-string)
+(setq-default allout-passphrase-hint-string "")
+;;;###autoload
+(put 'allout-passphrase-hint-string 'safe-local-variable 'stringp)
+;;;_ = allout-after-save-decrypt
+(defvar allout-after-save-decrypt nil
+ "Internal variable, is nil or has the value of two points:
+
+ - the location of a topic to be decrypted after saving is done
+ - where to situate the cursor after the decryption is performed
+
+This is used to decrypt the topic that was currently being edited, if it
+was encrypted automatically as part of a file write or autosave.")
+(make-variable-buffer-local 'allout-after-save-decrypt)
+;;;_ = allout-encryption-plaintext-sanitization-regexps
+(defvar allout-encryption-plaintext-sanitization-regexps nil
+ "List of regexps whose matches are removed from plaintext before encryption.
+
+This is for the sake of removing artifacts, like escapes, that are added on
+and not actually part of the original plaintext. The removal is done just
+prior to encryption.
+
+Entries must be symbols that are bound to the desired values.
+
+Each value can be a regexp or a list with a regexp followed by a
+substitution string. If it's just a regexp, all its matches are removed
+before the text is encrypted. If it's a regexp and a substitution, the
+substition is used against the regexp matches, a la `replace-match'.")
+(make-variable-buffer-local 'allout-encryption-text-removal-regexps)
+;;;_ = allout-encryption-ciphertext-rejection-regexps
+(defvar allout-encryption-ciphertext-rejection-regexps nil
+ "Variable for regexps matching plaintext to remove before encryption.
+
+This is for the sake of redoing encryption in cases where the ciphertext
+incidentally contains strings that would disrupt mode operation -
+for example, a line that happens to look like an allout-mode topic prefix.
+
+Entries must be symbols that are bound to the desired regexp values.
+
+The encryption will be retried up to
+`allout-encryption-ciphertext-rejection-limit' times, after which an error
+is raised.")
+
+(make-variable-buffer-local 'allout-encryption-ciphertext-rejection-regexps)
+;;;_ = allout-encryption-ciphertext-rejection-ceiling
+(defvar allout-encryption-ciphertext-rejection-ceiling 5
+ "Limit on number of times encryption ciphertext is rejected.
+
+See `allout-encryption-ciphertext-rejection-regexps' for rejection reasons.")
+(make-variable-buffer-local 'allout-encryption-ciphertext-rejection-ceiling)
+;;;_ > allout-mode-p ()
+;; Must define this macro above any uses, or byte compilation will lack
+;; proper def, if file isn't loaded - eg, during emacs build!
+(defmacro allout-mode-p ()
+ "Return t if `allout-mode' is active in current buffer."
+ 'allout-mode)
+;;;_ > allout-write-file-hook-handler ()
+(defun allout-write-file-hook-handler ()
+ "Implement `allout-encrypt-unencrypted-on-saves' policy for file writes."
+
+ (if (or (not (allout-mode-p))
+ (not (boundp 'allout-encrypt-unencrypted-on-saves))
+ (not allout-encrypt-unencrypted-on-saves))
+ nil
+ (let ((except-mark (and (equal allout-encrypt-unencrypted-on-saves
+ 'except-current)
+ (point-marker))))
+ (if (save-excursion (goto-char (point-min))
+ (allout-next-topic-pending-encryption except-mark))
+ (progn
+ (message "auto-encrypting pending topics")
+ (sit-for 0)
+ (condition-case failure
+ (setq allout-after-save-decrypt
+ (allout-encrypt-decrypted except-mark))
+ (error (progn
+ (message
+ "allout-write-file-hook-handler suppressing error %s"
+ failure)
+ (sit-for 2))))))
+ ))
+ nil)
+;;;_ > allout-auto-save-hook-handler ()
+(defun allout-auto-save-hook-handler ()
+ "Implement `allout-encrypt-unencrypted-on-saves' policy for auto save."
+
+ (if (and (allout-mode-p) allout-encrypt-unencrypted-on-saves)
+ ;; Always implement 'except-current policy when enabled.
+ (let ((allout-encrypt-unencrypted-on-saves 'except-current))
+ (allout-write-file-hook-handler))))
+;;;_ > allout-after-saves-handler ()
+(defun allout-after-saves-handler ()
+ "Decrypt topic encrypted for save, if it's currently being edited.
+
+Ie, if it was pending encryption and contained the point in its body before
+the save.
+
+We use values stored in `allout-after-save-decrypt' to locate the topic
+and the place for the cursor after the decryption is done."
+ (if (not (and (allout-mode-p)
+ (boundp 'allout-after-save-decrypt)
+ allout-after-save-decrypt))
+ t
+ (goto-char (car allout-after-save-decrypt))
+ (let ((was-modified (buffer-modified-p)))
+ (allout-toggle-subtree-encryption)
+ (if (not was-modified)
+ (set-buffer-modified-p nil)))
+ (goto-char (cadr allout-after-save-decrypt))
+ (setq allout-after-save-decrypt nil))
+ )
+
+;;;_ #2 Mode activation
+;;;_ = allout-explicitly-deactivated
+(defvar allout-explicitly-deactivated nil
+ "If t, `allout-mode's last deactivation was deliberate.
+So `allout-post-command-business' should not reactivate it...")
+(make-variable-buffer-local 'allout-explicitly-deactivated)
+;;;_ > allout-init (&optional mode)
+(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) the `allout-mode'
+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)
+ (if (interactive-p)
+ (progn
+ (setq mode
+ (completing-read
+ (concat "Select outline auto setup mode "
+ "(empty for report, ? for options) ")
+ '(("nil")("full")("activate")("deactivate")
+ ("ask") ("report") (""))
+ nil
+ t))
+ (if (string= mode "")
+ (setq mode 'report)
+ (setq mode (intern-soft mode)))))
+ (let
+ ;; convenience aliases, for consistent ref to respective vars:
+ ((hook 'allout-find-file-hook)
+ (find-file-hook-var-name (if (boundp 'find-file-hook)
+ 'find-file-hook
+ 'find-file-hooks))
+ (curr-mode 'allout-auto-activation))
+
+ (cond ((not mode)
+ (set find-file-hook-var-name
+ (delq hook (symbol-value find-file-hook-var-name)))
+ (if (interactive-p)
+ (message "Allout outline mode auto-activation inhibited.")))
+ ((eq mode 'report)
+ (if (not (memq hook (symbol-value find-file-hook-var-name)))
+ (allout-init nil)
+ ;; Just punt and use the reports from each of the modes:
+ (allout-init (symbol-value curr-mode))))
+ (t (add-hook find-file-hook-var-name 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-overlay-preparations
+(defun allout-overlay-preparations ()
+ "Set the properties of the allout invisible-text overlay and others."
+ (setplist 'allout-exposure-category nil)
+ (put 'allout-exposure-category 'invisible 'allout)
+ (put 'allout-exposure-category 'evaporate t)
+ ;; XXX We use isearch-open-invisible *and* isearch-mode-end-hook. The
+ ;; latter would be sufficient, but it seems that a separate behavior -
+ ;; the _transient_ opening of invisible text during isearch - is keyed to
+ ;; presence of the isearch-open-invisible property - even though this
+ ;; property controls the isearch _arrival_ behavior. This is the case at
+ ;; least in emacs 21, 22.0, and xemacs 21.4.
+ (put 'allout-exposure-category 'isearch-open-invisible
+ 'allout-isearch-end-handler)
+ (if (featurep 'xemacs)
+ (put 'allout-exposure-category 'start-open t)
+ (put 'allout-exposure-category 'insert-in-front-hooks
+ '(allout-overlay-insert-in-front-handler)))
+ (put 'allout-exposure-category 'modification-hooks
+ '(allout-overlay-interior-modification-handler)))
+;;;_ > allout-mode (&optional toggle)
+;;;_ : Defun:
+;;;###autoload
+(defun allout-mode (&optional toggle)
+;;;_ . Doc string:
+ "Toggle minor mode for controlling exposure and editing of text outlines.
+\\<allout-mode-map>
+
+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, promotion/demotion, cut, and paste
+ - integral outline exposure-layout
+ - incremental search with dynamic exposure and reconcealment of hidden text
+ - automatic topic-number maintenance
+ - easy topic encryption and decryption
+ - \"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:
+ ---------- ----------------
+\\[allout-next-visible-heading] allout-next-visible-heading | \\[allout-hide-current-subtree] allout-hide-current-subtree
+\\[allout-previous-visible-heading] allout-previous-visible-heading | \\[allout-show-children] allout-show-children
+\\[allout-up-current-level] allout-up-current-level | \\[allout-show-current-subtree] allout-show-current-subtree
+\\[allout-forward-current-level] allout-forward-current-level | \\[allout-show-current-entry] allout-show-current-entry
+\\[allout-backward-current-level] allout-backward-current-level | \\[allout-show-all] allout-show-all
+\\[allout-end-of-entry] allout-end-of-entry
+\\[allout-beginning-of-current-entry] allout-beginning-of-current-entry, alternately, goes to hot-spot
+
+ Topic Header Production:
+ -----------------------
+\\[allout-open-sibtopic] allout-open-sibtopic Create a new sibling after current topic.
+\\[allout-open-subtopic] allout-open-subtopic ... an offspring of current topic.
+\\[allout-open-supertopic] allout-open-supertopic ... a sibling of the current topic's parent.
+
+ Topic Level and Prefix Adjustment:
+ ---------------------------------
+\\[allout-shift-in] allout-shift-in Shift current topic and all offspring deeper.
+\\[allout-shift-out] allout-shift-out ... less deep.
+\\[allout-rebullet-current-heading] allout-rebullet-current-heading Prompt for alternate bullet for
+ current topic.
+\\[allout-rebullet-topic] allout-rebullet-topic Reconcile bullets of topic and its offspring
+ - distinctive bullets are not changed, others
+ alternated according to nesting depth.
+\\[allout-number-siblings] allout-number-siblings Number bullets of topic and siblings - the
+ offspring are not affected. With repeat
+ count, revoke numbering.
+
+ Topic-oriented Killing and Yanking:
+ ----------------------------------
+\\[allout-kill-topic] allout-kill-topic Kill current topic, including offspring.
+\\[allout-copy-topic-as-kill] allout-copy-topic-as-kill Copy current topic, including offspring.
+\\[allout-kill-line] allout-kill-line kill-line, attending to outline structure.
+\\[allout-copy-line-as-kill] allout-copy-line-as-kill Copy line but don't delete it.
+\\[allout-yank] allout-yank Yank, adjusting depth of yanked topic to
+ depth of heading if yanking into bare topic
+ heading (ie, prefix sans text).
+\\[allout-yank-pop] allout-yank-pop Is to allout-yank as yank-pop is to yank
+
+ Topic-oriented Encryption:
+ -------------------------
+\\[allout-toggle-current-subtree-encryption] allout-toggle-current-subtree-encryption Encrypt/Decrypt topic content
+
+ Misc commands:
+ -------------
+M-x outlineify-sticky Activate outline mode for current buffer,
+ and establish a default file-var setting
+ for `allout-layout'.
+\\[allout-mark-topic] allout-mark-topic
+\\[allout-copy-exposed-to-buffer] allout-copy-exposed-to-buffer
+ Duplicate outline, sans concealed text, to
+ buffer with name derived from derived from that
+ of current buffer - \"*BUFFERNAME exposed*\".
+\\[allout-flatten-exposed-to-buffer] allout-flatten-exposed-to-buffer
+ Like above 'copy-exposed', but convert topic
+ prefixes to section.subsection... numeric
+ format.
+\\[eval-expression] (allout-init t) Setup Emacs session for outline mode
+ auto-activation.
+
+ Topic Encryption
+
+Outline mode supports gpg encryption of topics, with support for
+symmetric and key-pair modes, passphrase timeout, passphrase
+consistency checking, user-provided hinting for symmetric key
+mode, and auto-encryption of topics pending encryption on save.
+\(Topics pending encryption are, by default, automatically
+encrypted during file saves; if you're editing the contents of
+such a topic, it is automatically decrypted for continued
+editing.) The aim is reliable topic privacy while preventing
+accidents like neglected encryption before saves, forgetting
+which passphrase was used, and other practical pitfalls.
+
+See `allout-toggle-current-subtree-encryption' function docstring and
+`allout-encrypt-unencrypted-on-saves' customization variable for details.
+
+ 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<space>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. Regular navigation keys (eg, \\[forward-char], \\[next-line]) never get
+this special translation, so you can use them to get out of 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 usually can 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 and be contained 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, determining 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 topics 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.
+
+ 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 (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 (and toggle
+ (or (symbolp toggle)
+ (and (wholenump 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)))
+ (write-file-hook-var-name (cond ((boundp 'write-file-functions)
+ 'write-file-functions)
+ ((boundp 'write-file-hooks)
+ 'write-file-hooks)
+ (t 'local-write-file-hooks)))
+ do-layout
+ )
+
+ ; See comments below re v19.18,.19 bug.
+ (setq allout-v18/19-file-var-hack (car command-history))
+
+ (cond
+
+ ;; 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)
+
+ (allout-do-resumptions)
+
+ (remove-from-invisibility-spec '(allout . t))
+ (remove-hook 'pre-command-hook 'allout-pre-command-business t)
+ (remove-hook 'post-command-hook 'allout-post-command-business t)
+ (remove-hook 'before-change-functions 'allout-before-change-handler t)
+ (remove-hook 'isearch-mode-end-hook 'allout-isearch-end-handler t)
+ (remove-hook write-file-hook-var-name 'allout-write-file-hook-handler t)
+ (remove-hook 'auto-save-hook 'allout-auto-save-hook-handler t)
+
+ (remove-overlays (point-min) (point-max)
+ 'category 'allout-exposure-category)
+
+ (setq allout-mode nil)
+ (run-hooks 'allout-mode-deactivate-hook))
+
+ ;; Activation:
+ ((not active)
+ (setq allout-explicitly-deactivated nil)
+ (if allout-old-style-prefixes
+ ;; Inhibit all the fancy formatting:
+ (allout-add-resumptions '(allout-primary-bullet "*")))
+
+ (allout-overlay-preparations) ; Doesn't hurt to redo this.
+
+ (allout-infer-header-lead-and-primary-bullet)
+ (allout-infer-body-reindent)
+
+ (set-allout-regexp)
+ (allout-add-resumptions
+ '(allout-encryption-ciphertext-rejection-regexps
+ allout-line-boundary-regexp
+ extend)
+ '(allout-encryption-ciphertext-rejection-regexps
+ allout-bob-regexp
+ extend))
+
+ ;; Produce map from current version of allout-keybindings-list:
+ (setq allout-mode-map
+ (produce-allout-mode-map allout-keybindings-list))
+ (substitute-key-definition 'beginning-of-line
+ 'allout-beginning-of-line
+ allout-mode-map global-map)
+ (substitute-key-definition 'move-beginning-of-line
+ 'allout-beginning-of-line
+ allout-mode-map global-map)
+ (substitute-key-definition 'end-of-line
+ 'allout-end-of-line
+ allout-mode-map global-map)
+ (substitute-key-definition 'move-end-of-line
+ 'allout-end-of-line
+ allout-mode-map global-map)
+ (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)))
+
+ (add-to-invisibility-spec '(allout . t))
+ (allout-add-resumptions '(line-move-ignore-invisible t))
+ (add-hook 'pre-command-hook 'allout-pre-command-business nil t)
+ (add-hook 'post-command-hook 'allout-post-command-business nil t)
+ (add-hook 'before-change-functions 'allout-before-change-handler
+ nil t)
+ (add-hook 'isearch-mode-end-hook 'allout-isearch-end-handler nil t)
+ (add-hook write-file-hook-var-name 'allout-write-file-hook-handler
+ nil t)
+ (add-hook 'auto-save-hook 'allout-auto-save-hook-handler
+ nil t)
+
+ ;; Stash auto-fill settings and adjust so custom allout auto-fill
+ ;; func will be used if auto-fill is active or activated. (The
+ ;; custom func respects topic headline, maintains hanging-indents,
+ ;; etc.)
+ (if (and auto-fill-function (not allout-inhibit-auto-fill))
+ ;; allout-auto-fill will use the stashed values and so forth.
+ (allout-add-resumptions '(auto-fill-function allout-auto-fill)))
+ (allout-add-resumptions (list 'allout-former-auto-filler
+ auto-fill-function)
+ ;; Register allout-auto-fill to be used if
+ ;; filling is active:
+ (list 'allout-outside-normal-auto-fill-function
+ normal-auto-fill-function)
+ '(normal-auto-fill-function allout-auto-fill)
+ ;; Paragraphs are broken by topic headlines.
+ (list 'paragraph-start
+ (concat paragraph-start "\\|^\\("
+ allout-regexp "\\)"))
+ (list 'paragraph-separate
+ (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))
+
+ (setq allout-mode t)
+ (run-hooks 'allout-mode-hook))
+
+ ;; Reactivation:
+ ((setq do-layout t)
+ (allout-infer-body-reindent))
+ ) ;; end of activation-mode cases.
+
+ ;; Do auto layout if warranted:
+ (let ((use-layout (if (listp allout-layout)
+ allout-layout
+ allout-default-layout)))
+ (if (and do-layout
+ allout-auto-activation
+ use-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)
+ use-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 use-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
+(defalias 'allout-minor-mode 'allout-mode)
+
+;;;_ - Position Assessment
+;;;_ > allout-hidden-p (&optional pos)
+(defsubst allout-hidden-p (&optional pos)
+ "Non-nil if the character after point is invisible."
+ (eq (get-char-property (or pos (point)) 'invisible) 'allout))
+
+;;;_ > allout-overlay-insert-in-front-handler (ol after beg end
+;;; &optional prelen)
+(defun allout-overlay-insert-in-front-handler (ol after beg end
+ &optional prelen)
+ "Shift the overlay so stuff inserted in front of it are excluded."
+ (if after
+ (move-overlay ol (1+ beg) (overlay-end ol))))
+;;;_ > allout-overlay-interior-modification-handler (ol after beg end
+;;; &optional prelen)
+(defun allout-overlay-interior-modification-handler (ol after beg end
+ &optional prelen)
+ "Get confirmation before making arbitrary changes to invisible text.
+
+We expose the invisible text and ask for confirmation. Refusal or
+keyboard-quit abandons the changes, with keyboard-quit additionally
+reclosing the opened text.
+
+No confirmation is necessary when inhibit-read-only is set - eg, allout
+internal functions use this feature cohesively bunch changes."
+
+ (when (and (not inhibit-read-only) (not after))
+ (let ((start (point))
+ (ol-start (overlay-start ol))
+ (ol-end (overlay-end ol))
+ first)
+ (goto-char beg)
+ (while (< (point) end)
+ (when (allout-hidden-p)
+ (allout-show-to-offshoot)
+ (if (allout-hidden-p)
+ (save-excursion (forward-char 1)
+ (allout-show-to-offshoot)))
+ (when (not first)
+ (setq first (point))))
+ (goto-char (if (featurep 'xemacs)
+ (next-property-change (1+ (point)) nil end)
+ (next-char-property-change (1+ (point)) end))))
+ (when first
+ (goto-char first)
+ (condition-case nil
+ (if (not
+ (yes-or-no-p
+ (substitute-command-keys
+ (concat "Modify concealed text? (\"no\" just aborts,"
+ " \\[keyboard-quit] also reconceals) "))))
+ (progn (goto-char start)
+ (error "Concealed-text change refused.")))
+ (quit (allout-flag-region ol-start ol-end nil)
+ (allout-flag-region ol-start ol-end t)
+ (error "Concealed-text change abandoned, text reconcealed."))))
+ (goto-char start))))
+;;;_ > allout-before-change-handler (beg end)
+(defun allout-before-change-handler (beg end)
+ "Protect against changes to invisible text.
+
+See allout-overlay-interior-modification-handler for details."
+
+ (if (and (allout-mode-p) undo-in-progress (allout-hidden-p))
+ (allout-show-to-offshoot))
+
+ ;; allout-overlay-interior-modification-handler on an overlay handles
+ ;; this in other emacs, via `allout-exposure-category's 'modification-hooks.
+ (when (and (featurep 'xemacs) (allout-mode-p))
+ ;; process all of the pending overlays:
+ (save-excursion
+ (got-char beg)
+ (let ((overlay (allout-get-invisibility-overlay)))
+ (allout-overlay-interior-modification-handler
+ overlay nil beg end nil)))))
+;;;_ > allout-isearch-end-handler (&optional overlay)
+(defun allout-isearch-end-handler (&optional overlay)
+ "Reconcile allout outline exposure on arriving in hidden text after isearch.
+
+Optional OVERLAY parameter is for when this function is used by
+`isearch-open-invisible' overlay property. It is otherwise unused, so this
+function can also be used as an `isearch-mode-end-hook'."
+
+ (if (and (allout-mode-p) (allout-hidden-p))
+ (allout-show-to-offshoot)))
+
+;;;_ #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
+;;; `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-depth
+(defvar allout-recent-depth 0
+ "Depth of the last topic prefix encountered.")
+(make-variable-buffer-local 'allout-recent-depth)
+;;;_ = 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 ()
+(defsubst allout-prefix-data ()
+ "Register allout-prefix state data.
+
+For reference by `allout-recent' funcs. Returns BEGINNING."
+ (setq allout-recent-prefix-end (or (match-end 1) (match-end 2))
+ allout-recent-prefix-beginning (or (match-beginning 1)
+ (match-beginning 2))
+ allout-recent-depth (max 1 (- allout-recent-prefix-end
+ allout-recent-prefix-beginning
+ allout-header-subtraction)))
+ allout-recent-prefix-beginning)
+;;;_ > nullify-allout-prefix-data ()
+(defsubst nullify-allout-prefix-data ()
+ "Mark allout prefix data as being uninformative."
+ (setq allout-recent-prefix-end (point)
+ allout-recent-prefix-beginning (point)
+ allout-recent-depth 0)
+ allout-recent-prefix-beginning)
+;;;_ > allout-recent-depth ()
+(defsubst 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."
+
+ allout-recent-depth)
+;;;_ > allout-recent-prefix ()
+(defsubst 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 prefix."
+ (buffer-substring-no-properties 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-no-properties (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
+ (allout-beginning-of-current-line)
+ (and (looking-at allout-regexp)
+ (not (allout-aberrant-container-p))
+ (allout-prefix-data))))
+;;;_ > 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 (let ((inhibit-field-text-motion t))
+ (beginning-of-line))
+ (looking-at allout-regexp))
+ (= (point)(save-excursion (allout-end-of-prefix)(point)))))
+;;;_ > allout-aberrant-container-p ()
+(defun allout-aberrant-container-p ()
+ "True if topic, or next sibling with children, contains them discontinuously.
+
+Discontinuous means an immediate offspring that is nested more
+than one level deeper than the topic.
+
+If topic has no offspring, then the next sibling with offspring will
+determine whether or not this one is determined to be aberrant.
+
+If true, then the allout-recent-* settings are calibrated on the
+offspring that qaulifies it as aberrant, ie with depth that
+exceeds the topic by more than one."
+
+ ;; This is most clearly understood when considering standard-prefix-leader
+ ;; low-level topics, which can all too easily match text not intended as
+ ;; headers. For example, any line with a leading '.' or '*' and lacking a
+ ;; following bullet qualifies without this protection. (A sequence of
+ ;; them can occur naturally, eg a typical textual bullet list.) We
+ ;; disqualify such low-level sequences when they are followed by a
+ ;; discontinuously contained child, inferring that the sequences are not
+ ;; actually connected with their prospective context.
+
+ (let ((depth (allout-depth))
+ (start-point (point))
+ done aberrant)
+ (save-excursion
+ (while (and (not done)
+ (re-search-forward allout-line-boundary-regexp nil 0))
+ (allout-prefix-data)
+ (goto-char allout-recent-prefix-beginning)
+ (cond
+ ;; sibling - continue:
+ ((eq allout-recent-depth depth))
+ ;; first offspring is excessive - aberrant:
+ ((> allout-recent-depth (1+ depth))
+ (setq done t aberrant t))
+ ;; next non-sibling is lower-depth - not aberrant:
+ (t (setq done t)))))
+ (if aberrant
+ aberrant
+ (goto-char start-point)
+ ;; recalibrate allout-recent-*
+ (allout-depth)
+ nil)))
+;;;_ : Location attributes
+;;;_ > allout-depth ()
+(defun allout-depth ()
+ "Return depth of topic most immediately containing point.
+
+Return zero if point is not within any topic.
+
+Like `allout-current-depth', but respects hidden as well as visible topics."
+ (save-excursion
+ (let ((start-point (point)))
+ (if (and (allout-goto-prefix)
+ (not (< start-point (point))))
+ allout-recent-depth
+ (progn
+ ;; Oops, no prefix, nullify it:
+ (nullify-allout-prefix-data)
+ ;; ... and return 0:
+ 0)))))
+;;;_ > allout-current-depth ()
+(defun allout-current-depth ()
+ "Return depth of visible topic most immediately containing point.
+
+Return zero if point is not within any topic."
+ (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 (allout-goto-prefix)
+ (allout-recent-prefix))))
+;;;_ > allout-get-bullet ()
+(defun allout-get-bullet ()
+ "Return bullet of containing topic (visible or not)."
+ (save-excursion
+ (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 nil
+ (save-excursion
+ (allout-back-to-current-heading)
+ (buffer-substring-no-properties (- allout-recent-prefix-end 1)
+ allout-recent-prefix-end))
+ ;; Quick and dirty provision, ostensibly for missing bullet:
+ (args-out-of-range nil))
+ )
+;;;_ > 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 allout-regexp prefix)
+ (substring prefix (1- (match-end 2)) (match-end 2))))
+;;;_ > 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)
+ )
+
+;;;_ - Navigation routines
+;;;_ > allout-beginning-of-current-line ()
+(defun allout-beginning-of-current-line ()
+ "Like beginning of line, but to visible text."
+
+ ;; This combination of move-beginning-of-line and beginning-of-line is
+ ;; deliberate, but the (beginning-of-line) may now be superfluous.
+ (let ((inhibit-field-text-motion t))
+ (move-beginning-of-line 1)
+ (beginning-of-line)
+ (while (and (not (bobp)) (or (not (bolp)) (allout-hidden-p)))
+ (beginning-of-line)
+ (if (or (allout-hidden-p) (not (bolp)))
+ (forward-char -1)))))
+;;;_ > allout-end-of-current-line ()
+(defun allout-end-of-current-line ()
+ "Move to the end of line, past concealed text if any."
+ ;; XXX This is for symmetry with `allout-beginning-of-current-line' -
+ ;; `move-end-of-line' doesn't suffer the same problem as
+ ;; `move-beginning-of-line'.
+ (let ((inhibit-field-text-motion t))
+ (end-of-line)
+ (while (allout-hidden-p)
+ (end-of-line)
+ (if (allout-hidden-p) (forward-char 1)))))
+;;;_ > allout-beginning-of-line ()
+(defun allout-beginning-of-line ()
+ "Beginning-of-line with `allout-beginning-of-line-cycles' behavior, if set."
+
+ (interactive)
+
+ (if (or (not allout-beginning-of-line-cycles)
+ (not (equal last-command this-command)))
+ (move-beginning-of-line 1)
+ (allout-depth)
+ (let ((beginning-of-body
+ (save-excursion
+ (while (and (<= allout-recent-depth
+ allout-doublecheck-at-and-shallower)
+ (allout-aberrant-container-p)
+ (allout-previous-visible-heading 1)))
+ (allout-beginning-of-current-entry)
+ (point))))
+ (cond ((= (current-column) 0)
+ (goto-char beginning-of-body))
+ ((< (point) beginning-of-body)
+ (allout-beginning-of-current-line))
+ ((= (point) beginning-of-body)
+ (goto-char (allout-current-bullet-pos)))
+ (t (allout-beginning-of-current-line)
+ (if (< (point) beginning-of-body)
+ ;; we were on the headline after its start:
+ (goto-char beginning-of-body)))))))
+;;;_ > allout-end-of-line ()
+(defun allout-end-of-line ()
+ "End-of-line with `allout-end-of-line-cycles' behavior, if set."
+
+ (interactive)
+
+ (if (or (not allout-end-of-line-cycles)
+ (not (equal last-command this-command)))
+ (allout-end-of-current-line)
+ (let ((end-of-entry (save-excursion
+ (allout-end-of-entry)
+ (point))))
+ (cond ((not (eolp))
+ (allout-end-of-current-line))
+ ((or (allout-hidden-p) (save-excursion
+ (forward-char -1)
+ (allout-hidden-p)))
+ (allout-back-to-current-heading)
+ (allout-show-current-entry)
+ (allout-show-children)
+ (allout-end-of-entry))
+ ((>= (point) end-of-entry)
+ (allout-back-to-current-heading)
+ (allout-end-of-current-line))
+ (t (allout-end-of-entry))))))
+;;;_ > allout-next-heading ()
+(defsubst allout-next-heading ()
+ "Move to the heading for the topic \(possibly invisible) after this one.
+
+Returns the location of the heading, or nil if none found.
+
+We skip anomolous low-level topics, a la `allout-aberrant-container-p'."
+ (if (looking-at allout-regexp)
+ (forward-char 1))
+
+ (when (re-search-forward allout-line-boundary-regexp nil 0)
+ (allout-prefix-data)
+ (and (<= allout-recent-depth allout-doublecheck-at-and-shallower)
+ ;; this will set allout-recent-* on the first non-aberrant topic,
+ ;; whether it's the current one or one that disqualifies it:
+ (allout-aberrant-container-p))
+ (goto-char allout-recent-prefix-beginning)))
+;;;_ > 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-doublechecked)) (allout-next-heading)))
+;;;_ > allout-previous-heading ()
+(defun 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.
+
+We skip anomolous low-level topics, a la `allout-aberrant-container-p'."
+
+ (if (bobp)
+ nil
+ ;; allout-goto-prefix-doublechecked calls us, so we can't use it here.
+ (let ((start-point (point)))
+ (allout-goto-prefix)
+ (when (or (re-search-backward allout-line-boundary-regexp nil 0)
+ (looking-at allout-bob-regexp))
+ (goto-char (allout-prefix-data))
+ (if (and (<= allout-recent-depth allout-doublecheck-at-and-shallower)
+ (allout-aberrant-container-p))
+ (or (allout-previous-heading)
+ (and (goto-char start-point)
+ ;; recalibrate allout-recent-*:
+ (allout-depth)
+ nil))
+ (point))))))
+;;;_ > allout-get-invisibility-overlay ()
+(defun allout-get-invisibility-overlay ()
+ "Return the overlay at point that dictates allout invisibility."
+ (let ((overlays (overlays-at (point)))
+ got)
+ (while (and overlays (not got))
+ (if (equal (overlay-get (car overlays) 'invisible) 'allout)
+ (setq got (car overlays))
+ (pop overlays)))
+ got))
+;;;_ > allout-back-to-visible-text ()
+(defun allout-back-to-visible-text ()
+ "Move to most recent prior character that is visible, and return point."
+ (if (allout-hidden-p)
+ (goto-char (overlay-start (allout-get-invisibility-overlay))))
+ (point))
+
+;;;_ - Subtree Charting
+;;;_ " These routines either produce or assess charts, which are
+;;; nested lists of the locations of topics within a subtree.
+;;;
+;;; Charts enable efficient subtree navigation by providing a reusable basis
+;;; for elaborate, compound assessment and adjustment of a subtree.
+
+;;;_ > allout-chart-subtree (&optional levels visible orig-depth prev-depth)
+(defun allout-chart-subtree (&optional levels visible 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.
+
+When optional argument VISIBLE is non-nil, the chart includes
+only the visible subelements of the charted subjects.
+
+The remaining optional args are not for internal use by the function.
+
+Point is left at the end of the subtree.
+
+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.
+
+The chart entries for the topics are in reverse order, so the
+last topic is listed first. The entry for each topic consists of
+an integer indicating the point at the beginning of the topic
+prefix. 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.
+
+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)))
+ (if visible
+ (allout-next-visible-heading 1)
+ (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 allout-recent-prefix-beginning 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)
+ (if visible
+ (allout-next-visible-heading 1)
+ (allout-next-heading)))))
+ (if visible
+ (allout-next-visible-heading 1)
+ (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))
+ visible
+ 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 (= (preceding-char) ?\n)
+ (= (aref (buffer-substring (max 1 (- (point) 3))
+ (point))
+ 1)
+ ?\n)
+ (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
+ (when (allout-goto-prefix-doublechecked)
+ (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 (allout-hidden-p)
+ (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)
+ (search-backward "\n" nil 1))
+ (forward-char 1)
+ (if (looking-at allout-regexp)
+ (setq done (allout-prefix-data))
+ (forward-char -1)))
+ (if (bobp)
+ (cond ((looking-at allout-regexp)
+ (allout-prefix-data))
+ ((allout-next-heading))
+ (done))
+ done)))
+;;;_ > allout-goto-prefix-doublechecked ()
+(defun allout-goto-prefix-doublechecked ()
+ "Put point at beginning of immediately containing outline topic.
+
+Like `allout-goto-prefix', but shallow topics \(according to `allout-doublecheck-at-and-shallower') are checked and disqualified for child containment discontinuity, according to `allout-aberrant-container-p'."
+ (allout-goto-prefix)
+ (if (and (<= allout-recent-depth allout-doublecheck-at-and-shallower)
+ (allout-aberrant-container-p))
+ (allout-previous-heading)
+ (point)))
+
+;;;_ > 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-doublechecked))
+ nil
+ (goto-char allout-recent-prefix-end)
+ (if ignore-decorations
+ t
+ (while (looking-at "[0-9]") (forward-char 1))
+ (if (and (not (eolp)) (looking-at "\\s-")) (forward-char 1)))
+ ;; Reestablish where we are:
+ (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- allout-recent-prefix-end)))
+;;;_ > 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.
+
+Return value of point, unless we started outside of (before any) topics,
+in which case we return nil."
+
+ (allout-beginning-of-current-line)
+ (if (or (allout-on-current-heading-p)
+ (and (re-search-backward (concat "^\\(" allout-regexp "\\)")
+ nil 'move)
+ (progn (while (allout-hidden-p)
+ (allout-beginning-of-current-line)
+ (if (not (looking-at allout-regexp))
+ (re-search-backward allout-regexp
+ nil 'move)))
+ (allout-prefix-data))))
+ (if (interactive-p)
+ (allout-end-of-prefix)
+ (point))))
+;;;_ > allout-back-to-heading ()
+(defalias 'allout-back-to-heading 'allout-back-to-current-heading)
+;;;_ > allout-pre-next-prefix ()
+(defun allout-pre-next-prefix ()
+ "Skip forward to just before the next heading line.
+
+Returns that character position."
+
+ (if (allout-next-heading)
+ (goto-char (1- allout-recent-prefix-beginning))))
+;;;_ > allout-end-of-subtree (&optional current include-trailing-blank)
+(defun allout-end-of-subtree (&optional current include-trailing-blank)
+ "Put point at the end of the last leaf in the containing topic.
+
+Optional CURRENT means put point at the end of the containing
+visible topic.
+
+Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
+any, as part of the subtree. Otherwise, that trailing blank will be
+excluded as delimiting whitespace between topics.
+
+Returns the value of point."
+ (interactive "P")
+ (if current
+ (allout-back-to-current-heading)
+ (allout-goto-prefix-doublechecked))
+ (let ((level allout-recent-depth))
+ (allout-next-heading)
+ (while (and (not (eobp))
+ (> allout-recent-depth level))
+ (allout-next-heading))
+ (if (eobp)
+ (allout-end-of-entry)
+ (forward-char -1))
+ (if (and (not include-trailing-blank) (= ?\n (preceding-char)))
+ (forward-char -1))
+ (setq allout-recent-end-of-subtree (point))))
+;;;_ > allout-end-of-current-subtree (&optional include-trailing-blank)
+(defun allout-end-of-current-subtree (&optional include-trailing-blank)
+
+ "Put point at end of last leaf in currently visible containing topic.
+
+Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if
+any, as part of the subtree. Otherwise, that trailing blank will be
+excluded as delimiting whitespace between topics.
+
+Returns the value of point."
+ (interactive)
+ (allout-end-of-subtree t include-trailing-blank))
+;;;_ > allout-beginning-of-current-entry ()
+(defun allout-beginning-of-current-entry ()
+ "When not already there, position point at beginning of current topic header.
+
+If already there, move cursor to bullet for hot-spot operation.
+\(See `allout-mode' doc string for details of hot-spot operation.)"
+ (interactive)
+ (let ((start-point (point)))
+ (move-beginning-of-line 1)
+ (if (< 0 (allout-current-depth))
+ (goto-char allout-recent-prefix-end)
+ (goto-char (point-min)))
+ (allout-end-of-prefix)
+ (if (and (interactive-p)
+ (= (point) start-point))
+ (goto-char (allout-current-bullet-pos)))))
+;;;_ > allout-end-of-entry (&optional inclusive)
+(defun allout-end-of-entry (&optional inclusive)
+ "Position the point at the end of the current topics' entry.
+
+Optional INCLUSIVE means also include trailing empty line, if any. When
+unset, whitespace between items separates them even when the items are
+collapsed."
+ (interactive)
+ (allout-pre-next-prefix)
+ (if (and (not inclusive) (not (bobp)) (= ?\n (preceding-char)))
+ (forward-char -1))
+ (point))
+;;;_ > allout-end-of-current-heading ()
+(defun allout-end-of-current-heading ()
+ (interactive)
+ (allout-beginning-of-current-entry)
+ (search-forward "\n" nil t)
+ (forward-char -1))
+(defalias 'allout-end-of-heading 'allout-end-of-current-heading)
+;;;_ > allout-get-body-text ()
+(defun allout-get-body-text ()
+ "Return the unmangled body text of the topic immediately containing point."
+ (save-excursion
+ (allout-end-of-prefix)
+ (if (not (search-forward "\n" nil t))
+ nil
+ (backward-char 1)
+ (let ((pre-body (point)))
+ (if (not pre-body)
+ nil
+ (allout-end-of-entry t)
+ (if (not (= pre-body (point)))
+ (buffer-substring-no-properties (1+ pre-body) (point))))
+ )
+ )
+ )
+ )
+
+;;;_ - 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-ascended)
+ (while (and (< depth allout-recent-depth)
+ (setq last-ascended (allout-ascend))))
+ (goto-char allout-recent-prefix-beginning)
+ (if (interactive-p) (allout-end-of-prefix))
+ (and last-ascended allout-recent-depth))))
+;;;_ > allout-ascend ()
+(defun allout-ascend ()
+ "Ascend one level, returning t if successful, nil if not."
+ (prog1
+ (if (allout-beginning-of-level)
+ (allout-previous-heading))
+ (if (interactive-p) (allout-end-of-prefix))))
+;;;_ > 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 (allout-depth)))
+ (while
+ (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))
+ )
+;;;_ > allout-up-current-level (arg)
+(defun allout-up-current-level (arg)
+ "Move out ARG levels from current visible topic."
+ (interactive "p")
+ (let ((start-point (point)))
+ (allout-back-to-current-heading)
+ (if (not (allout-ascend))
+ (progn (goto-char start-point)
+ (error "Can't ascend past outermost level"))
+ (if (interactive-p) (allout-end-of-prefix))
+ allout-recent-prefix-beginning)))
+
+;;;_ - Linear
+;;;_ > allout-next-sibling (&optional depth backward)
+(defun allout-next-sibling (&optional depth backward)
+ "Like `allout-forward-current-level', but respects invisible topics.
+
+Traverse at optional DEPTH, or current depth if none specified.
+
+Go backward if optional arg BACKWARD is non-nil.
+
+Return the start point of the new topic if successful, nil otherwise."
+
+ (if (if backward (bobp) (eobp))
+ nil
+ (let ((target-depth (or depth (allout-depth)))
+ (start-point (point))
+ (count 0)
+ leaping
+ last-depth)
+ (while (and
+ ;; done too few single steps to resort to the leap routine:
+ (not leaping)
+ ;; not at limit:
+ (not (if backward (bobp) (eobp)))
+ ;; still traversable:
+ (if backward (allout-previous-heading) (allout-next-heading))
+ ;; we're below the target depth
+ (> (setq last-depth allout-recent-depth) target-depth))
+ (setq count (1+ count))
+ (if (> count 7) ; lists are commonly 7 +- 2, right?-)
+ (setq leaping t)))
+ (cond (leaping
+ (or (allout-next-sibling-leap target-depth backward)
+ (progn
+ (goto-char start-point)
+ (if depth (allout-depth) target-depth)
+ nil)))
+ ((and (not (eobp))
+ (and (> (or last-depth (allout-depth)) 0)
+ (= allout-recent-depth target-depth)))
+ allout-recent-prefix-beginning)
+ (t
+ (goto-char start-point)
+ (if depth (allout-depth) target-depth)
+ nil)))))
+;;;_ > allout-next-sibling-leap (&optional depth backward)
+(defun allout-next-sibling-leap (&optional depth backward)
+ "Like `allout-next-sibling', but by direct search for topic at depth.
+
+Traverse at optional DEPTH, or current depth if none specified.
+
+Go backward if optional arg BACKWARD is non-nil.
+
+Return the start point of the new topic if successful, nil otherwise.
+
+Costs more than regular `allout-next-sibling' for short traversals:
+
+ - we have to check the prior \(next, if travelling backwards)
+ item to confirm connectivity with the prior topic, and
+ - if confirmed, we have to reestablish the allout-recent-* settings with
+ some extra navigation
+ - if confirmation fails, we have to do more work to recover
+
+It is an increasingly big win when there are many intervening
+offspring before the next sibling, however, so
+`allout-next-sibling' resorts to this if it finds itself in that
+situation."
+
+ (if (if backward (bobp) (eobp))
+ nil
+ (let* ((start-point (point))
+ (target-depth (or depth (allout-depth)))
+ (search-whitespace-regexp nil)
+ (depth-biased (- target-depth 2))
+ (expression (if (<= target-depth 1)
+ allout-depth-one-regexp
+ (format allout-depth-specific-regexp
+ depth-biased depth-biased)))
+ found
+ done)
+ (while (not done)
+ (setq found (if backward
+ (re-search-backward expression nil 'to-limit)
+ (forward-char 1)
+ (re-search-forward expression nil 'to-limit)))
+ (if (and found (allout-aberrant-container-p))
+ (setq found nil))
+ (setq done (or found (if backward (bobp) (eobp)))))
+ (if (not found)
+ (progn (goto-char start-point)
+ nil)
+ ;; rationale: if any intervening items were at a lower depth, we
+ ;; would now be on the first offspring at the target depth - ie,
+ ;; the preceeding item (per the search direction) must be at a
+ ;; lesser depth. that's all we need to check.
+ (if backward (allout-next-heading) (allout-previous-heading))
+ (if (< allout-recent-depth target-depth)
+ ;; return to start and reestablish allout-recent-*:
+ (progn
+ (goto-char start-point)
+ (allout-depth)
+ nil)
+ (goto-char found)
+ ;; locate cursor and set allout-recent-*:
+ (allout-goto-prefix))))))
+;;;_ > allout-previous-sibling (&optional depth backward)
+(defun allout-previous-sibling (&optional depth backward)
+ "Like `allout-forward-current-level' backwards, respecting invisible topics.
+
+Optional DEPTH specifies depth to traverse, default current depth.
+
+Optional BACKWARD reverses direction.
+
+Return depth if successful, nil otherwise."
+ (allout-next-sibling depth (not backward))
+ )
+;;;_ > 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 (= ?\n (preceding-char))))
+ nil
+ (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
+ (if (interactive-p) (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 to buffer limit in indicated direction if headings are exhausted."
+
+ (interactive "p")
+ (let* ((inhibit-field-text-motion t)
+ (backward (if (< arg 0) (setq arg (* -1 arg))))
+ (step (if backward -1 1))
+ prev got)
+
+ (while (> arg 0)
+ (while (and
+ ;; Boundary condition:
+ (not (if backward (bobp)(eobp)))
+ ;; Move, skipping over all concealed lines in one fell swoop:
+ (prog1 (condition-case nil (or (line-move step) t)
+ (error nil))
+ (allout-beginning-of-current-line))
+ ;; Deal with apparent header line:
+ (if (not (looking-at allout-regexp))
+ ;; not a header line, keep looking:
+ t
+ (allout-prefix-data)
+ (if (and (<= allout-recent-depth
+ allout-doublecheck-at-and-shallower)
+ (allout-aberrant-container-p))
+ ;; skip this aberrant prospective header line:
+ t
+ ;; this prospective headerline qualifies - register:
+ (setq got allout-recent-prefix-beginning)
+ ;; and break the loop:
+ nil))))
+ ;; 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-end-of-prefix))
+ (prev ; Last move wasn't, but prev was:
+ (goto-char prev)
+ (allout-end-of-prefix))
+ ((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")
+ (prog1 (allout-next-visible-heading (- arg))
+ (if (interactive-p) (allout-end-of-prefix))))
+;;;_ > allout-forward-current-level (arg)
+(defun allout-forward-current-level (arg)
+ "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")
+ (let ((start-depth (allout-current-depth))
+ (start-arg arg)
+ (backward (> 0 arg)))
+ (if (= 0 start-depth)
+ (error "No siblings, not in a topic..."))
+ (if backward (setq arg (* -1 arg)))
+ (allout-back-to-current-heading)
+ (while (and (not (zerop arg))
+ (if backward
+ (allout-previous-sibling)
+ (allout-next-sibling)))
+ (setq arg (1- arg)))
+ (if (not (interactive-p))
+ nil
+ (allout-end-of-prefix)
+ (if (not (zerop arg))
+ (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)
+ "Inverse of `allout-forward-current-level'."
+ (interactive "p")
+ (if (interactive-p)
+ (let ((current-prefix-arg (* -1 arg)))
+ (call-interactively 'allout-forward-current-level))
+ (allout-forward-current-level (* -1 arg))))
+
+;;;_ #5 Alteration
+
+;;;_ - Fundamental
+;;;_ = 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-command-counter
+(defvar allout-command-counter 0
+ "Counter that monotonically increases in allout-mode buffers.
+
+Set by `allout-pre-command-business', to support allout addons in
+coordinating with allout activity.")
+(make-variable-buffer-local 'allout-command-counter)
+;;;_ > allout-post-command-business ()
+(defun allout-post-command-business ()
+ "Outline `post-command-hook' function.
+
+- Implement (and clear) `allout-post-goto-bullet', for hot-spot
+ outline commands.
+
+- Decrypt topic currently being edited if it was encrypted for a save."
+
+ ; Apply any external change func:
+ (if (not (allout-mode-p)) ; In allout-mode.
+ nil
+
+ (if (and (boundp 'allout-after-save-decrypt)
+ allout-after-save-decrypt)
+ (allout-after-saves-handler))
+
+ ;; Implement allout-post-goto-bullet, if set:
+ (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.
+
+Among other things, implements special behavior when the cursor is on the
+topic 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))
+ nil
+ ;; Increment allout-command-counter
+ (setq allout-command-counter (1+ allout-command-counter))
+ ;; Do hot-spot navigation.
+ (if (and (eq this-command 'self-insert-command)
+ (eq (point)(allout-current-bullet-pos)))
+ (allout-hotspot-key-handler))))
+;;;_ > allout-hotspot-key-handler ()
+(defun allout-hotspot-key-handler ()
+ "Catchall handling of key bindings in hot-spots.
+
+Translates unmodified keystrokes to corresponding allout commands, when
+they would qualify if prefixed with the allout-command-prefix, and sets
+this-command accordingly.
+
+Returns the qualifying command, if any, else nil."
+ (interactive)
+ (let* ((key-string (if (numberp last-command-char)
+ (char-to-string last-command-char)))
+ (key-num (cond ((numberp last-command-char) last-command-char)
+ ;; for XEmacs character type:
+ ((and (fboundp 'characterp)
+ (apply 'characterp (list last-command-char)))
+ (apply 'char-to-int (list last-command-char)))
+ (t 0)))
+ mapped-binding)
+
+ (if (zerop key-num)
+ nil
+
+ (if (and
+ ;; exclude control chars and escape:
+ (<= 33 key-num)
+ (setq mapped-binding
+ (or (and (assoc key-string allout-keybindings-list)
+ ;; translate literal membership on list:
+ (cadr (assoc key-string allout-keybindings-list)))
+ ;; translate as a keybinding:
+ (key-binding (concat allout-command-prefix
+ (char-to-string
+ (if (and (<= 97 key-num) ; "a"
+ (>= 122 key-num)) ; "z"
+ (- key-num 96) key-num)))
+ t))))
+ ;; Qualified as an allout command - do hot-spot operation.
+ (setq allout-post-goto-bullet t)
+ ;; accept-defaults nil, or else we'll get allout-item-icon-key-handler.
+ (setq mapped-binding (key-binding (char-to-string key-num))))
+
+ (while (keymapp mapped-binding)
+ (setq mapped-binding
+ (lookup-key mapped-binding (vector (read-char)))))
+
+ (if mapped-binding
+ (setq this-command mapped-binding)))))
+
+;;;_ > allout-find-file-hook ()
+(defun allout-find-file-hook ()
+ "Activate `allout-mode' on non-nil `allout-auto-activation', `allout-layout'.
+
+See `allout-init' for setup instructions."
+ (if (and allout-auto-activation
+ (not (allout-mode-p))
+ allout-layout)
+ (allout-mode t)))
+
+;;;_ - 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
+ (substring-no-properties default-bullet))
+ sans-escapes
+ t)))
+ (message "")
+ (if (string= choice "") default-bullet choice))
+ )
+;;;_ > 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
+ (allout-get-prefix-bullet prefix)
+ (allout-get-bullet)))))
+;;;_ > allout-encrypted-type-prefix (&optional prefix)
+(defun allout-encrypted-type-prefix (&optional prefix)
+ "True if current header prefix bullet is for an encrypted entry \(body)."
+ (and allout-topic-encryption-bullet
+ (string= allout-topic-encryption-bullet
+ (if prefix
+ (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 allout-stylish-prefixes
+ (char-to-string (aref allout-plain-bullets-string
+ (% (max 0 (- depth 2))
+ allout-plain-bullets-string-len)))
+ allout-primary-bullet)
+ )
+
+;;;_ - Topic Production
+;;;_ > allout-make-topic-prefix (&optional prior-bullet
+(defun allout-make-topic-prefix (&optional prior-bullet
+ new
+ depth
+ solicit
+ number-control
+ index)
+ ;; Depth null means use current depth, non-null means we're either
+ ;; opening a new topic after current topic, lower or higher, or we're
+ ;; changing level of current topic.
+ ;; Solicit dominates specified bullet-char.
+;;;_ . 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.
+ ;; Current prefix is least dominant, but most likely to be commonly
+ ;; specified...
+
+ (let* (body
+ numbering
+ denumbering
+ (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 "") allout-primary-bullet)
+ ; Simple, too: all asterisks:
+ (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 allout-primary-bullet)))
+ (setq header-lead "")
+ "")
+
+ ;; (Neither level 1 nor old-style, so we're space padding.
+ ;; Sneak it in the condition of the next case, whatever it is.)
+
+ ;; Solicitation overrides numbering and other cases:
+ ((progn (setq body (make-string (- depth 2) ?\ ))
+ ;; The actual condition:
+ solicit)
+ (let* ((got (allout-solicit-alternate-bullet depth solicit)))
+ ;; Gotta check whether we're numbering and got a numbered bullet:
+ (setq numbering (and allout-numbered-bullet
+ (not (and number-control (not index)))
+ (string= got allout-numbered-bullet)))
+ ;; Now return what we got, regardless:
+ got))
+
+ ;; Numbering invoked through args:
+ ((and allout-numbered-bullet number-control)
+ (if (setq numbering (not (setq denumbering (not index))))
+ 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 (allout-depth))
+ allout-numbered-bullet ; ... & numbering enabled
+ (not denumbering)
+ (let ((sibling-bullet
+ (save-excursion
+ ;; Locate correct sibling:
+ (or (>= depth (allout-depth))
+ (allout-ascend-to-depth depth))
+ (allout-get-bullet))))
+ (if (and sibling-bullet
+ (string= allout-numbered-bullet sibling-bullet))
+ (setq numbering sibling-bullet)))))
+
+ ;; Distinctive prior bullet?
+ ((and prior-bullet
+ (allout-distinctive-bullet prior-bullet)
+ ;; Either non-numbered:
+ (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:
+ ((allout-bullet-for-depth depth)))))
+
+ (concat header-lead
+ body
+ bullet-char
+ (if numbering
+ (format "%d" (cond ((and index (numberp index)) index)
+ (new (1+ (allout-sibling-index depth)))
+ ((allout-sibling-index))))))
+ )
+ )
+;;;_ > allout-open-topic (relative-depth &optional before offer-recent-bullet)
+(defun allout-open-topic (relative-depth &optional before offer-recent-bullet)
+ "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 completely empty - lacking even
+whitespace - in which case open is done on the current line.
+
+When adding an offspring, it will be added immediately after the parent if
+the other offspring are exposed, or after the last child if the offspring
+are hidden. \(The intervening offspring will be exposed in the latter
+case.)
+
+If OFFER-RECENT-BULLET is true, offer to use the bullet of the prior sibling.
+
+Runs
+
+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."
+
+ (allout-beginning-of-current-line)
+ (let* ((inhibit-field-text-motion t)
+ (depth (+ (allout-current-depth) relative-depth))
+ (opening-on-blank (if (looking-at "^\$")
+ (not (setq before nil))))
+ ;; bunch o vars set while computing ref-topic
+ opening-numbered
+ ref-depth
+ ref-bullet
+ (ref-topic (save-excursion
+ (cond ((< relative-depth 0)
+ (allout-ascend-to-depth depth))
+ ((>= relative-depth 1) nil)
+ (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 allout-numbered-bullet
+ (or (<= relative-depth 0)
+ (allout-descend-to-depth depth))
+ (if (allout-numbered-type-prefix)
+ allout-numbered-bullet))))
+ (point)))
+ dbl-space
+ doing-beginning
+ start end)
+
+ (if (not opening-on-blank)
+ ; Positioning and vertical
+ ; padding - only if not
+ ; opening-on-blank:
+ (progn
+ (goto-char ref-topic)
+ (setq dbl-space ; Determine double space action:
+ (or (and (<= relative-depth 0) ; not descending;
+ (save-excursion
+ ;; 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)
+ (looking-at "\n\n")))
+ (and (= ref-depth 1)
+ (or before
+ (= depth 1)
+ (save-excursion
+ ;; Don't already have following
+ ;; vertical padding:
+ (not (allout-pre-next-prefix)))))))
+
+ ;; Position to prior 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 (not (bobp))
+ (allout-previous-heading)))
+ (if (and before (bobp))
+ (open-line 1)))
+
+ (if (<= relative-depth 0)
+ ;; Not going inwards, don't snug up:
+ (if doing-beginning
+ (if (not dbl-space)
+ (open-line 1)
+ (open-line 2))
+ (if before
+ (progn (end-of-line)
+ (allout-pre-next-prefix)
+ (while (and (= ?\n (following-char))
+ (save-excursion
+ (forward-char 1)
+ (allout-hidden-p)))
+ (forward-char 1))
+ (if (not (looking-at "^$"))
+ (open-line 1)))
+ (allout-end-of-current-subtree)
+ (if (looking-at "\n\n") (forward-char 1))))
+ ;; Going inwards - double-space if first offspring is
+ ;; double-spaced, otherwise snug up.
+ (allout-end-of-entry)
+ (if (eobp)
+ (newline 1)
+ (line-move 1))
+ (allout-beginning-of-current-line)
+ (backward-char 1)
+ (if (bolp)
+ ;; Blank lines between current header body and next
+ ;; header - get to last substantive (non-white-space)
+ ;; line in body:
+ (progn (setq dbl-space t)
+ (re-search-backward "[^ \t\n]" nil t)))
+ (if (looking-at "\n\n")
+ (setq dbl-space t))
+ (if (save-excursion
+ (allout-next-heading)
+ (when (> allout-recent-depth ref-depth)
+ ;; This is an offspring.
+ (forward-line -1)
+ (looking-at "^\\s-*$")))
+ (progn (forward-line 1)
+ (open-line 1)
+ (forward-line 1)))
+ (allout-end-of-current-line))
+
+ ;;(if doing-beginning (goto-char doing-beginning))
+ (if (not (bobp))
+ ;; We insert a newline char rather than using open-line to
+ ;; avoid rear-stickiness inheritence of read-only property.
+ (progn (if (and (not (> depth ref-depth))
+ (not before))
+ (open-line 1)
+ (if (and (not dbl-space) (> depth ref-depth))
+ (newline 1)
+ (if dbl-space
+ (open-line 1)
+ (if (not before)
+ (newline 1)))))
+ (if (and dbl-space (not (> relative-depth 0)))
+ (newline 1))
+ (if (and (not (eobp))
+ (or (not (bolp))
+ (and (not (bobp))
+ ;; bolp doesnt detect concealed
+ ;; trailing newlines, compensate:
+ (save-excursion
+ (forward-char -1)
+ (allout-hidden-p)))))
+ (forward-char 1))))
+ ))
+ (setq start (point))
+ (insert (concat (allout-make-topic-prefix opening-numbered t depth)
+ " "))
+ (setq end (1+ (point)))
+
+ (allout-rebullet-heading (and offer-recent-bullet ref-bullet)
+ depth nil nil t)
+ (if (> relative-depth 0)
+ (save-excursion (goto-char ref-topic)
+ (allout-show-children)))
+ (end-of-line)
+
+ (run-hook-with-args 'allout-structure-added-hook start end)
+ )
+ )
+;;;_ > 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")
+ (allout-open-topic 1 (> 0 arg) (< 1 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")
+ (allout-open-topic 0 (> 0 arg) (not (= 1 arg))))
+;;;_ > allout-open-supertopic (arg)
+(defun allout-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."
+
+ (interactive "p")
+ (allout-open-topic -1 (> 0 arg) (< 1 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."
+
+ (when (not allout-inhibit-auto-fill)
+ (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))
+ ?\ )))))
+ (use-auto-fill-function (or allout-outside-normal-auto-fill-function
+ auto-fill-function
+ 'do-auto-fill)))
+ (if (or allout-former-auto-filler allout-use-hanging-indents)
+ (funcall use-auto-fill-function)))))
+;;;_ > 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
+ (allout-end-of-prefix)
+ (let* ((new-margin (current-column))
+ excess old-indent-begin old-indent-end
+ ;; 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\\(\\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 (- (- old-indent-end old-indent-begin)
+ 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 (current-column))))))))))
+;;;_ > 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)))
+ from to
+ (backwards (if (< arg 0)
+ (setq arg (* arg -1)))))
+ (while (> arg 0)
+ (save-excursion (allout-back-to-current-heading)
+ (allout-end-of-prefix)
+ (setq from allout-recent-prefix-beginning
+ to allout-recent-prefix-end)
+ (allout-rebullet-heading t ;;; solicit
+ nil ;;; depth
+ nil ;;; number-control
+ nil ;;; index
+ t) ;;; do-successors
+ (run-hook-with-args 'allout-exposure-change-hook
+ from to t))
+ (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-doublechecked)
+ (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.
+
+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.
+
+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 forth 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 allout-make-topic-prefix.
+
+Fifth arg DO-SUCCESSORS t means re-resolve count on succeeding
+siblings.
+
+Cf vars `allout-stylish-prefixes', `allout-old-style-prefixes',
+and `allout-numbered-bullet', which all affect the behavior of
+this function."
+
+ (let* ((current-depth (allout-depth))
+ (new-depth (or new-depth current-depth))
+ (mb allout-recent-prefix-beginning)
+ (me allout-recent-prefix-end)
+ (current-bullet (buffer-substring-no-properties (- me 1) me))
+ (new-prefix (allout-make-topic-prefix current-bullet
+ nil
+ new-depth
+ solicit
+ number-control
+ index)))
+
+ ;; 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:
+ (allout-unprotected (delete-region mb me))
+ (goto-char mb)
+ ; Dispense with number if
+ ; numbered-bullet prefix:
+ (if (and allout-numbered-bullet
+ (string= allout-numbered-bullet current-bullet)
+ (looking-at "[0-9]+"))
+ (allout-unprotected
+ (delete-region (match-beginning 0)(match-end 0))))
+
+ ; Put in new prefix:
+ (allout-unprotected (insert new-prefix))
+
+ ;; Reindent the body if elected, margin changed, and not encrypted body:
+ (if (and allout-reindent-bodies
+ (not (= new-depth current-depth))
+ (not (allout-encrypted-topic-p)))
+ (allout-reindent-body current-depth new-depth))
+
+ ;; 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 &optional sans-offspring)
+ "Rebullet the visible topic containing point and all contained subtopics.
+
+Descends into invisible as well as visible topics, however.
+
+When optional sans-offspring is non-nil, subtopics are not
+shifted. \(Shifting a topic outwards without shifting its
+offspring is disallowed, since this would create a \"containment
+discontinuity\", where the depth difference between a topic and
+its immediate offspring is greater than one.)
+
+With repeat count, shift topic depth by that amount."
+ (interactive "P")
+ (let ((start-col (current-column)))
+ (save-excursion
+ ;; Normalize arg:
+ (cond ((null arg) (setq arg 0))
+ ((listp arg) (setq arg (car arg))))
+ ;; Fill the user in, in case we're shifting a big topic:
+ (if (not (zerop arg)) (message "Shifting..."))
+ (allout-back-to-current-heading)
+ (if (<= (+ allout-recent-depth arg) 0)
+ (error "Attempt to shift topic below level 1"))
+ (allout-rebullet-topic-grunt arg nil nil nil nil sans-offspring)
+ (if (not (zerop arg)) (message "Shifting... done.")))
+ (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
+ sans-offspring)
+ "Like `allout-rebullet-topic', but on nearest containing topic
+\(visible or not).
+
+See `allout-rebullet-heading' for rebulleting behavior.
+
+All arguments are optional.
+
+First arg RELATIVE-DEPTH means to shift the depth of the entire
+topic that amount.
+
+Several subsequent args are for internal recursive use by the function
+itself: STARTING-DEPTH, STARTING-POINT, and INDEX.
+
+Finally, if optional SANS-OFFSPRING is non-nil then the offspring
+are not shifted. \(Shifting a topic outwards without shifting
+its offspring is disallowed, since this would create a
+\"containment discontinuity\", where the depth difference between
+a topic and its immediate offspring is greater than one..)"
+
+ ;; XXX the recursion here is peculiar, and in general the routine may
+ ;; need simplification with refactoring.
+
+ (if (and sans-offspring
+ relative-depth
+ (< relative-depth 0))
+ (error (concat "Attempt to shift topic outwards without offspring,"
+ " would cause containment discontinuity.")))
+
+ (let* ((relative-depth (or relative-depth 0))
+ (new-depth (allout-depth))
+ (starting-depth (or starting-depth new-depth))
+ (on-starting-call (null starting-point))
+ (index (or index
+ ;; Leave index null on starting call, so rebullet-heading
+ ;; calculates it at what might be new depth:
+ (and (or (zerop relative-depth)
+ (not on-starting-call))
+ (allout-sibling-index))))
+ (starting-index index)
+ (moving-outwards (< 0 relative-depth))
+ (starting-point (or starting-point (point)))
+ (local-point (point)))
+
+ ;; Sanity check for excessive promotion done only on starting call:
+ (and on-starting-call
+ moving-outwards
+ (> 0 (+ starting-depth relative-depth))
+ (error "Attempt to shift topic out beyond level 1"))
+
+ (cond ((= starting-depth new-depth)
+ ;; We're at depth to work on this one.
+
+ ;; When shifting out we work on the children before working on
+ ;; the parent to avoid interim `allout-aberrant-container-p'
+ ;; aberrancy, and vice-versa when shifting in:
+ (if (>= relative-depth 0)
+ (allout-rebullet-heading nil
+ (+ starting-depth relative-depth)
+ nil ;;; number
+ index
+ nil)) ;;; do-successors
+ (when (not sans-offspring)
+ ;; ... and work on subsequent ones which are at greater depth:
+ (setq index 0)
+ (allout-next-heading)
+ (while (and (not (eobp))
+ (< starting-depth (allout-depth)))
+ (setq index (1+ index))
+ (allout-rebullet-topic-grunt relative-depth
+ (1+ starting-depth)
+ starting-point
+ index)))
+ (when (< relative-depth 0)
+ (save-excursion
+ (goto-char local-point)
+ (allout-rebullet-heading nil ;;; solicit
+ (+ starting-depth relative-depth)
+ nil ;;; number
+ starting-index
+ nil)))) ;;; do-successors
+
+ ((< starting-depth new-depth)
+ ;; Rare case - subtopic more than one level deeper than parent.
+ ;; Treat this one at an even deeper level:
+ (allout-rebullet-topic-grunt relative-depth
+ new-depth
+ starting-point
+ index
+ sans-offspring)))
+
+ (if on-starting-call
+ (progn
+ ;; Rectify numbering of former siblings of the adjusted topic,
+ ;; if topic has changed depth
+ (if (or do-successors
+ (and (not (zerop relative-depth))
+ (or (= allout-recent-depth starting-depth)
+ (= allout-recent-depth (+ starting-depth
+ relative-depth)))))
+ (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))
+ (allout-rebullet-heading nil nil nil nil t)))))
+ )
+ )
+;;;_ > allout-renumber-to-depth (&optional depth)
+(defun allout-renumber-to-depth (&optional depth)
+ "Renumber siblings at current depth.
+
+Affects superior topics if optional arg DEPTH is less than current depth.
+
+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
+ (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
+ (allout-rebullet-heading use-bullet ;;; solicit
+ depth ;;; depth
+ t ;;; number-control
+ index ;;; index
+ nil) ;;; do-successors
+ (if index (setq index (1+ index)))
+ (setq more (allout-next-sibling depth nil))))))
+;;;_ > allout-shift-in (arg)
+(defun allout-shift-in (arg)
+ "Increase depth of current heading and any items collapsed within it.
+
+With a negative argument, the item is shifted out using
+`allout-shift-out', instead.
+
+With an argument greater than one, shift-in the item but not its
+offspring, making the item into a sibling of its former children,
+and a child of sibling that formerly preceeded it.
+
+You are not allowed to shift the first offspring of a topic
+inwards, because that would yield a \"containment
+discontinuity\", where the depth difference between a topic and
+its immediate offspring is greater than one. The first topic in
+the file can be adjusted to any positive depth, however."
+
+ (interactive "p")
+ (if (< arg 0)
+ (allout-shift-out (* arg -1))
+ ;; refuse to create a containment discontinuity:
+ (save-excursion
+ (allout-back-to-current-heading)
+ (if (not (bobp))
+ (let* ((current-depth allout-recent-depth)
+ (start-point (point))
+ (predecessor-depth (progn
+ (forward-char -1)
+ (allout-goto-prefix-doublechecked)
+ (if (< (point) start-point)
+ allout-recent-depth
+ 0))))
+ (if (and (> predecessor-depth 0)
+ (> (1+ current-depth)
+ (1+ predecessor-depth)))
+ (error (concat "Disallowed shift deeper than"
+ " containing topic's children."))))))
+ (let ((where (point)))
+ (allout-rebullet-topic 1 (and (> arg 1) 'sans-offspring))
+ (run-hook-with-args 'allout-structure-shifted-hook arg where))))
+;;;_ > allout-shift-out (arg)
+(defun allout-shift-out (arg)
+ "Decrease depth of current heading and any topics collapsed within it.
+This will make the item a sibling of its former container.
+
+With a negative argument, the item is shifted in using
+`allout-shift-in', instead.
+
+With an argument greater than one, shift-out the item's offspring
+but not the item itself, making the former children siblings of
+the item.
+
+With an argument greater than 1, the item's offspring are shifted
+out without shifting the item. This will make the immediate
+subtopics into siblings of the item."
+ (interactive "p")
+ (if (< arg 0)
+ (allout-shift-in (* arg -1))
+ ;; Get proper exposure in this area:
+ (save-excursion (if (allout-ascend)
+ (allout-show-children)))
+ ;; Show collapsed children if there's a successor which will become
+ ;; their sibling:
+ (if (and (allout-current-topic-collapsed-p)
+ (save-excursion (allout-next-sibling)))
+ (allout-show-children))
+ (let ((where (and (allout-depth) allout-recent-prefix-beginning)))
+ (save-excursion
+ (if (> arg 1)
+ ;; Shift the offspring but not the topic:
+ (let ((children-chart (allout-chart-subtree 1)))
+ (if (listp (car children-chart))
+ ;; whoops:
+ (setq children-chart (allout-flatten children-chart)))
+ (save-excursion
+ (dolist (child-point children-chart)
+ (goto-char child-point)
+ (allout-shift-out 1))))
+ (allout-rebullet-topic (* arg -1))))
+ (run-hook-with-args 'allout-structure-shifted-hook (* arg -1) where))))
+;;;_ : 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 (or (not (allout-mode-p))
+ (not (bolp))
+ (not (looking-at allout-regexp)))
+ ;; Just do a regular kill:
+ (kill-line arg)
+ ;; Ah, have to watch out for adjustments:
+ (let* ((beg (point))
+ end
+ (beg-hidden (allout-hidden-p))
+ (end-hidden (save-excursion (allout-end-of-current-line)
+ (setq end (point))
+ (allout-hidden-p)))
+ (depth (allout-depth)))
+
+ (allout-annotate-hidden beg end)
+
+ (if (and (not beg-hidden) (not end-hidden))
+ (allout-unprotected (kill-line arg))
+ (kill-line arg))
+ (if allout-numbered-bullet
+ (save-excursion ; Renumber subsequent topics if needed:
+ (if (not (looking-at allout-regexp))
+ (allout-next-heading))
+ (allout-renumber-to-depth depth)))
+ (run-hook-with-args 'allout-structure-deleted-hook depth (point)))))
+;;;_ > allout-copy-line-as-kill ()
+(defun allout-copy-line-as-kill ()
+ "Like allout-kill-topic, but save to kill ring instead of deleting."
+ (interactive)
+ (let ((buffer-read-only t))
+ (condition-case nil
+ (allout-kill-line)
+ (buffer-read-only nil))))
+;;;_ > allout-kill-topic ()
+(defun allout-kill-topic ()
+ "Kill topic together with subtopics.
+
+Trailing whitespace is killed with a topic if that whitespace:
+
+ - would separate the topic from a subsequent sibling
+ - would separate the topic from the end of buffer
+ - would not be added to whitespace already separating the topic from the
+ previous one.
+
+Topic exposure is marked with text-properties, to be used by
+allout-yank-processing for exposure recovery."
+
+ (interactive)
+ (let* ((inhibit-field-text-motion t)
+ (beg (prog1 (allout-back-to-current-heading) (beginning-of-line)))
+ (depth allout-recent-depth))
+ (allout-end-of-current-subtree)
+ (if (and (/= (current-column) 0) (not (eobp)))
+ (forward-char 1))
+ (if (not (eobp))
+ (if (and (looking-at "\n")
+ (or (save-excursion
+ (or (not (allout-next-heading))
+ (= depth allout-recent-depth)))
+ (and (> (- beg (point-min)) 3)
+ (string= (buffer-substring (- beg 2) beg) "\n\n"))))
+ (forward-char 1)))
+
+ (allout-annotate-hidden beg (point))
+
+ (allout-unprotected (kill-region beg (point)))
+ (save-excursion
+ (allout-renumber-to-depth depth))
+ (run-hook-with-args 'allout-structure-deleted-hook depth (point))))
+;;;_ > allout-copy-topic-as-kill ()
+(defun allout-copy-topic-as-kill ()
+ "Like allout-kill-topic, but save to kill ring instead of deleting."
+ (interactive)
+ (let ((buffer-read-only t))
+ (condition-case nil
+ (allout-kill-topic)
+ (buffer-read-only (message "Topic copied...")))))
+;;;_ > allout-annotate-hidden (begin end)
+(defun allout-annotate-hidden (begin end)
+ "Qualify text with properties to indicate exposure status."
+
+ (let ((was-modified (buffer-modified-p))
+ (buffer-read-only nil))
+ (allout-unprotected
+ (remove-text-properties begin end '(allout-was-hidden t)))
+ (save-excursion
+ (goto-char begin)
+ (let (done next prev overlay)
+ (while (not done)
+ ;; at or advance to start of next hidden region:
+ (if (not (allout-hidden-p))
+ (setq next
+ (max (1+ (point))
+ (next-single-char-property-change (point)
+ 'invisible
+ nil end))))
+ (if (or (not next) (eq prev next))
+ ;; still not at start of hidden area - must not be any left.
+ (setq done t)
+ (goto-char next)
+ (setq prev next)
+ (if (not (allout-hidden-p))
+ ;; still not at start of hidden area.
+ (setq done t)
+ (setq overlay (allout-get-invisibility-overlay))
+ (setq next (overlay-end overlay)
+ prev next)
+ ;; advance to end of this hidden area:
+ (when next
+ (goto-char next)
+ (allout-unprotected
+ (put-text-property (overlay-start overlay) next
+ 'allout-was-hidden t))))))))
+ (set-buffer-modified-p was-modified)))
+;;;_ > allout-hide-by-annotation (begin end)
+(defun allout-hide-by-annotation (begin end)
+ "Translate text properties indicating exposure status into actual exposure."
+ (save-excursion
+ (goto-char begin)
+ (let ((was-modified (buffer-modified-p))
+ done next prev)
+ (while (not done)
+ ;; at or advance to start of next annotation:
+ (if (not (get-text-property (point) 'allout-was-hidden))
+ (setq next (next-single-char-property-change (point)
+ 'allout-was-hidden
+ nil end)))
+ (if (or (not next) (eq prev next))
+ ;; no more or not advancing - must not be any left.
+ (setq done t)
+ (goto-char next)
+ (setq prev next)
+ (if (not (get-text-property (point) 'allout-was-hidden))
+ ;; still not at start of annotation.
+ (setq done t)
+ ;; advance to just after end of this annotation:
+ (setq next (next-single-char-property-change (point)
+ 'allout-was-hidden
+ nil end))
+ (overlay-put (make-overlay prev next)
+ 'category 'allout-exposure-category)
+ (allout-unprotected
+ (remove-text-properties prev next '(allout-was-hidden t)))
+ (setq prev next)
+ (if next (goto-char next)))))
+ (set-buffer-modified-p was-modified))))
+;;;_ > allout-remove-exposure-annotation (begin end)
+(defun allout-remove-exposure-annotation (begin end)
+ "Remove text properties indicating exposure status."
+ (remove-text-properties begin end '(allout-was-hidden t)))
+
+;;;_ > allout-yank-processing ()
+(defun allout-yank-processing (&optional arg)
+
+ "Incidental allout-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
+ topic prefix.
+
+Also, adjusts numbering of subsequent siblings when appropriate.
+
+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.
+
+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, non-allout-specific yanks."
+
+ (interactive "*P")
+ ; Get to beginning, leaving
+ ; region around subject:
+ (if (< (allout-mark-marker t) (point))
+ (exchange-point-and-mark))
+ (allout-unprotected
+ (let* ((subj-beg (point))
+ (into-bol (bolp))
+ (subj-end (allout-mark-marker t))
+ ;; 'resituate' if yanking an entire topic into topic header:
+ (resituate (and (allout-e-o-prefix-p)
+ (looking-at allout-regexp)
+ (allout-prefix-data)))
+ ;; `rectify-numbering' if resituating (where several topics may
+ ;; be resituating) or yanking a topic into a topic slot (bol):
+ (rectify-numbering (or resituate
+ (and into-bol (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))
+ allout-recent-depth)))
+ (more t))
+ (setq rectify-numbering allout-numbered-bullet)
+ (if adjust-to-depth
+ ; Do the adjustment:
+ (progn
+ (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))
+ (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))))))
+ ;; 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 (allout-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")
+ ; ... and renumber, in case necessary:
+ (goto-char subj-beg)
+ (if (allout-goto-prefix-doublechecked)
+ (allout-rebullet-heading nil ;;; solicit
+ (allout-depth) ;;; depth
+ nil ;;; number-control
+ nil ;;; index
+ t))
+ (message ""))))
+ (if (or into-bol resituate)
+ (allout-hide-by-annotation (point) (allout-mark-marker t))
+ (allout-remove-exposure-annotation (allout-mark-marker t) (point)))
+ (if (not resituate)
+ (exchange-point-and-mark))
+ (run-hook-with-args 'allout-structure-added-hook subj-beg subj-end))))
+;;;_ > 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)
+ (allout-unprotected
+ (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")
+ (setq this-command 'yank)
+ (yank-pop arg)
+ (if (allout-mode-p)
+ (allout-yank-processing)))
+
+;;;_ - 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 allout-file-xref-bullet)
+ (error
+ "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 ((inhibit-field-text-motion t)
+ file-name)
+ (save-excursion
+ (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)
+ (buffer-substring (match-beginning 1) (match-end 1))))))
+ (setq file-name (expand-file-name file-name))
+ (if (or (file-exists-p file-name)
+ (if (file-writable-p file-name)
+ (y-or-n-p (format "%s not there, create one? "
+ file-name))
+ (error "%s not found and can't be created" file-name)))
+ (condition-case failure
+ (find-file-other-window file-name)
+ (error failure))
+ (error "%s not found" file-name))
+ )
+ )
+ )
+ )
+
+;;;_ #6 Exposure Control
+
+;;;_ - Fundamental
+;;;_ > allout-flag-region (from to flag)
+(defun allout-flag-region (from to flag)
+ "Conceal text between FROM and TO if FLAG is non-nil, else reveal it.
+
+Exposure-change hook `allout-exposure-change-hook' is run with the same
+arguments as this function, after the exposure changes are made. \(The old
+`allout-view-change-hook' is being deprecated, and eventually will not be
+invoked.\)"
+
+ ;; We use outline invisibility spec.
+ (remove-overlays from to 'category 'allout-exposure-category)
+ (when flag
+ (let ((o (make-overlay from to)))
+ (overlay-put o 'category 'allout-exposure-category)
+ (when (featurep 'xemacs)
+ (let ((props (symbol-plist 'allout-exposure-category)))
+ (while props
+ (overlay-put o (pop props) (pop props)))))))
+ (run-hooks 'allout-view-change-hook)
+ (run-hook-with-args 'allout-exposure-change-hook from to flag))
+;;;_ > allout-flag-current-subtree (flag)
+(defun allout-flag-current-subtree (flag)
+ "Conceal currently-visible topic's subtree if FLAG non-nil, else reveal it."
+
+ (save-excursion
+ (allout-back-to-current-heading)
+ (let ((inhibit-field-text-motion t))
+ (end-of-line))
+ (allout-flag-region (point)
+ ;; Exposing must not leave trailing blanks hidden,
+ ;; but can leave them exposed when hiding, so we
+ ;; can use flag's inverse as the
+ ;; include-trailing-blank cue:
+ (allout-end-of-current-subtree (not flag))
+ flag)))
+
+;;;_ - Topic-specific
+;;;_ > allout-show-entry ()
+(defun allout-show-entry ()
+ "Like `allout-show-current-entry', but reveals entries 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-show-offshoot' should be used after the peek to rectify
+the exposure."
+
+ (interactive)
+ (save-excursion
+ (let (beg end)
+ (allout-goto-prefix-doublechecked)
+ (setq beg (if (allout-hidden-p) (1- (point)) (point)))
+ (setq end (allout-pre-next-prefix))
+ (allout-flag-region beg end nil)
+ (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 ((start-point (point)))
+ (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:
+ (allout-show-children level t))
+
+ (save-excursion
+ (allout-beginning-of-current-line)
+ (save-restriction
+ (let* (depth
+ (chart (allout-chart-subtree (or level 1)))
+ (to-reveal (or (allout-chart-to-reveal chart (or level 1))
+ ;; interactive, show discontinuous children:
+ (and chart
+ (interactive-p)
+ (save-excursion
+ (allout-back-to-current-heading)
+ (setq depth (allout-current-depth))
+ (and (allout-next-heading)
+ (> allout-recent-depth
+ (1+ depth))))
+ (message
+ "Discontinuous offspring; use `%s %s'%s."
+ (substitute-command-keys
+ "\\[universal-argument]")
+ (substitute-command-keys
+ "\\[allout-shift-out]")
+ " to elevate them.")
+ (allout-chart-to-reveal
+ chart (- allout-recent-depth depth))))))
+ (goto-char start-point)
+ (when (and strict (allout-hidden-p))
+ ;; Concealed root would already have been taken care of,
+ ;; unless strict was set.
+ (allout-flag-region (point) (allout-snug-back) nil)
+ (when allout-show-bodies
+ (goto-char (car to-reveal))
+ (allout-show-current-entry)))
+ (while to-reveal
+ (goto-char (car to-reveal))
+ (allout-flag-region (save-excursion (allout-snug-back) (point))
+ (progn (search-forward "\n" nil t)
+ (1- (point)))
+ nil)
+ (when allout-show-bodies
+ (goto-char (car to-reveal))
+ (allout-show-current-entry))
+ (setq to-reveal (cdr to-reveal)))))))
+ ;; Compensate for `save-excursion's maintenance of point
+ ;; within invisible text:
+ (goto-char start-point)))
+;;;_ > allout-show-to-offshoot ()
+(defun allout-show-to-offshoot ()
+ "Like `allout-show-entry', but reveals all concealed ancestors, as well.
+
+Useful for coherently exposing to a random point in a hidden region."
+ (interactive)
+ (save-excursion
+ (let ((inhibit-field-text-motion t)
+ (orig-pt (point))
+ (orig-pref (allout-goto-prefix-doublechecked))
+ (last-at (point))
+ bag-it)
+ (while (or bag-it (allout-hidden-p))
+ (while (allout-hidden-p)
+ (move-beginning-of-line 1)
+ (if (allout-hidden-p) (forward-char -1)))
+ (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
+ (let ((inhibit-field-text-motion t))
+ (end-of-line))
+ (allout-flag-region (point)
+ (progn (allout-end-of-entry) (point))
+ t)))
+;;;_ > allout-show-current-entry (&optional arg)
+(defun allout-show-current-entry (&optional arg)
+ "Show body following current heading, or hide entry with universal argument."
+
+ (interactive "P")
+ (if arg
+ (allout-hide-current-entry)
+ (save-excursion (allout-show-to-offshoot))
+ (save-excursion
+ (allout-flag-region (point)
+ (progn (allout-end-of-entry t) (point))
+ nil)
+ )))
+;;;_ > 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) nil))
+ (allout-beginning-of-current-line)
+ (if (not arg)
+ (allout-flag-current-subtree nil)
+ (allout-beginning-of-level)
+ (allout-expose-topic '(* :))))))
+;;;_ > allout-current-topic-collapsed-p (&optional include-single-liners)
+(defun allout-current-topic-collapsed-p (&optional include-single-liners)
+ "True if the currently visible containing topic is already collapsed.
+
+Single line topics intrinsically can be considered as being both
+collapsed and uncollapsed. If optional INCLUDE-SINGLE-LINERS is
+true, then single-line topics are considered to be collapsed. By
+default, they are treated as being uncollapsed."
+ (save-excursion
+ (and
+ ;; Is the topic all on one line (allowing for trailing blank line)?
+ (>= (progn (allout-back-to-current-heading)
+ (move-end-of-line 1)
+ (point))
+ (allout-end-of-current-subtree (not (looking-at "\n\n"))))
+
+ (or include-single-liners
+ (progn (backward-char 1) (allout-hidden-p))))))
+;;;_ > 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 close the parent or
+siblings, even if the target topic is already closed."
+
+ (interactive)
+ (let* ((from (point))
+ (sibs-msg "Top-level topic already closed - closing siblings...")
+ (current-exposed (not (allout-current-topic-collapsed-p t))))
+ (cond (current-exposed (allout-flag-current-subtree t))
+ (just-close nil)
+ ((allout-ascend) (allout-hide-current-subtree))
+ (t (goto-char 0)
+ (message sibs-msg)
+ (allout-goto-prefix-doublechecked)
+ (allout-expose-topic '(0 :))
+ (message (concat sibs-msg " Done."))))
+ (goto-char from)))
+;;;_ > allout-show-current-branches ()
+(defun allout-show-current-branches ()
+ "Show all subheadings of this heading, but not their bodies."
+ (interactive)
+ (let ((inhibit-field-text-motion t))
+ (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) nil)
+ (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))
+ (let ((inhibit-field-text-motion t))
+ (while (not (eobp))
+ (end-of-line)
+ (allout-flag-region (point) (allout-end-of-entry) t)
+ (if (not (eobp))
+ (forward-char
+ (if (looking-at "\n\n")
+ 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)
+ (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) (not (allout-hidden-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)
+
+ "Deprecated. Use `allout-expose-topic' \(with different schema
+format) instead.
+
+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 ((inhibit-field-text-motion t)
+ (depth (allout-current-depth))
+ 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))
+;;;_ > 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.
+
+Use this instead of obsolete `allout-exposure'.
+
+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-doublechecked)
+ (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*
+ ((inhibit-field-text-motion t)
+ ;; state vars:
+ strings prefix 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-doublechecked) 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
+ (end-of-line)
+ (allout-back-to-visible-text)))
+ strings))
+ (when (< (point) next) ; Resume from after hid text, if any.
+ (line-move 1)
+ (beginning-of-line))
+ (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))))
+;;;_ > my-region-active-p ()
+(defmacro my-region-active-p ()
+ (if (fboundp 'region-active-p)
+ '(region-active-p)
+ 'mark-active))
+;;;_ > 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.
+
+All args are options; default values itemized below.
+
+Apply FUNCTION 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:
+ FUNCTION: `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."
+ (let ((inhibit-field-text-motion t))
+ (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 2))
+ (insert "\\")
+ (setq end (1+ end))
+ (goto-char (1+ (match-end 2)))))))
+;;;_ > 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"
+ ""))
+ (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 nil
+ (eval allout-title)
+ (error "<unnamed buffer>"))
+ "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 Encryption
+;;;_ > allout-toggle-current-subtree-encryption (&optional fetch-pass)
+(defun allout-toggle-current-subtree-encryption (&optional fetch-pass)
+ "Encrypt clear or decrypt encoded text of visibly-containing topic's contents.
+
+Optional FETCH-PASS universal argument provokes key-pair encryption with
+single universal argument. With doubled universal argument \(value = 16),
+it forces prompting for the passphrase regardless of availability from the
+passphrase cache. With no universal argument, the appropriate passphrase
+is obtained from the cache, if available, else from the user.
+
+Currently only GnuPG encryption is supported.
+
+\**NOTE WELL** that the encrypted text must be ascii-armored. For gnupg
+encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file.
+
+Both symmetric-key and key-pair encryption is implemented. Symmetric is
+the default, use a single \(x4) universal argument for keypair mode.
+
+Encrypted topic's bullet is set to a `~' to signal that the contents of the
+topic \(body and subtopics, but not heading) is pending encryption or
+encrypted. `*' asterisk immediately after the bullet signals that the body
+is encrypted, its' absence means the topic is meant to be encrypted but is
+not. When a file with topics pending encryption is saved, topics pending
+encryption are encrypted. See allout-encrypt-unencrypted-on-saves for
+auto-encryption specifics.
+
+\**NOTE WELL** that automatic encryption that happens during saves will
+default to symmetric encryption - you must manually \(re)encrypt key-pair
+encrypted topics if you want them to continue to use the key-pair cipher.
+
+Level-one topics, with prefix consisting solely of an `*' asterisk, cannot be
+encrypted. If you want to encrypt the contents of a top-level topic, use
+\\[allout-shift-in] to increase its depth.
+
+ Passphrase Caching
+
+The encryption passphrase is solicited if not currently available in the
+passphrase cache from a recent encryption action.
+
+The solicited passphrase is retained for reuse in a buffer-specific cache
+for some set period of time \(default, 60 seconds), after which the string
+is nulled. The passphrase cache timeout is customized by setting
+`pgg-passphrase-cache-expiry'.
+
+ Symmetric Passphrase Hinting and Verification
+
+If the file previously had no associated passphrase, or had a different
+passphrase than specified, the user is prompted to repeat the new one for
+corroboration. A random string encrypted by the new passphrase is set on
+the buffer-specific variable `allout-passphrase-verifier-string', for
+confirmation of the passphrase when next obtained, before encrypting or
+decrypting anything with it. This helps avoid mistakenly shifting between
+keys.
+
+If allout customization var `allout-passphrase-verifier-handling' is
+non-nil, an entry for `allout-passphrase-verifier-string' and its value is
+added to an Emacs 'local variables' section at the end of the file, which
+is created if necessary. That setting is for retention of the passphrase
+verifier across emacs sessions.
+
+Similarly, `allout-passphrase-hint-string' stores a user-provided reminder
+about their passphrase, and `allout-passphrase-hint-handling' specifies
+when the hint is presented, or if passphrase hints are disabled. If
+enabled \(see the `allout-passphrase-hint-handling' docstring for details),
+the hint string is stored in the local-variables section of the file, and
+solicited whenever the passphrase is changed."
+ (interactive "P")
+ (save-excursion
+ (allout-back-to-current-heading)
+ (allout-toggle-subtree-encryption fetch-pass)
+ )
+ )
+;;;_ > allout-toggle-subtree-encryption (&optional fetch-pass)
+(defun allout-toggle-subtree-encryption (&optional fetch-pass)
+ "Encrypt clear text or decrypt encoded topic contents \(body and subtopics.)
+
+Optional FETCH-PASS universal argument provokes key-pair encryption with
+single universal argument. With doubled universal argument \(value = 16),
+it forces prompting for the passphrase regardless of availability from the
+passphrase cache. With no universal argument, the appropriate passphrase
+is obtained from the cache, if available, else from the user.
+
+Currently only GnuPG encryption is supported.
+
+\**NOTE WELL** that the encrypted text must be ascii-armored. For gnupg
+encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file.
+
+See `allout-toggle-current-subtree-encryption' for more details."
+
+ (interactive "P")
+ (save-excursion
+ (allout-end-of-prefix t)
+
+ (if (= allout-recent-depth 1)
+ (error (concat "Cannot encrypt or decrypt level 1 topics -"
+ " shift it in to make it encryptable")))
+
+ (let* ((allout-buffer (current-buffer))
+ ;; Asses location:
+ (bullet-pos allout-recent-prefix-beginning)
+ (after-bullet-pos (point))
+ (was-encrypted
+ (progn (if (= (point-max) after-bullet-pos)
+ (error "no body to encrypt"))
+ (allout-encrypted-topic-p)))
+ (was-collapsed (if (not (search-forward "\n" nil t))
+ nil
+ (backward-char 1)
+ (allout-hidden-p)))
+ (subtree-beg (1+ (point)))
+ (subtree-end (allout-end-of-subtree))
+ (subject-text (buffer-substring-no-properties subtree-beg
+ subtree-end))
+ (subtree-end-char (char-after (1- subtree-end)))
+ (subtree-trailing-char (char-after subtree-end))
+ ;; kluge - result-text needs to be nil, but we also want to
+ ;; check for the error condition
+ (result-text (if (or (string= "" subject-text)
+ (string= "\n" subject-text))
+ (error "No topic contents to %scrypt"
+ (if was-encrypted "de" "en"))
+ nil))
+ ;; Assess key parameters:
+ (key-info (or
+ ;; detect the type by which it is already encrypted
+ (and was-encrypted
+ (allout-encrypted-key-info subject-text))
+ (and (member fetch-pass '(4 (4)))
+ '(keypair nil))
+ '(symmetric nil)))
+ (for-key-type (car key-info))
+ (for-key-identity (cadr key-info))
+ (fetch-pass (and fetch-pass (member fetch-pass '(16 (16))))))
+
+ (setq result-text
+ (allout-encrypt-string subject-text was-encrypted
+ (current-buffer)
+ for-key-type for-key-identity fetch-pass))
+
+ ;; Replace the subtree with the processed product.
+ (allout-unprotected
+ (progn
+ (set-buffer allout-buffer)
+ (delete-region subtree-beg subtree-end)
+ (insert result-text)
+ (if was-collapsed
+ (allout-flag-region (1- subtree-beg) (point) t))
+ ;; adjust trailing-blank-lines to preserve topic spacing:
+ (if (not was-encrypted)
+ (if (and (= subtree-end-char ?\n)
+ (= subtree-trailing-char ?\n))
+ (insert subtree-trailing-char)))
+ ;; Ensure that the item has an encrypted-entry bullet:
+ (if (not (string= (buffer-substring-no-properties
+ (1- after-bullet-pos) after-bullet-pos)
+ allout-topic-encryption-bullet))
+ (progn (goto-char (1- after-bullet-pos))
+ (delete-char 1)
+ (insert allout-topic-encryption-bullet)))
+ (if was-encrypted
+ ;; Remove the is-encrypted bullet qualifier:
+ (progn (goto-char after-bullet-pos)
+ (delete-char 1))
+ ;; Add the is-encrypted bullet qualifier:
+ (goto-char after-bullet-pos)
+ (insert "*"))))
+ (run-hook-with-args 'allout-structure-added-hook
+ bullet-pos subtree-end))))
+;;;_ > allout-encrypt-string (text decrypt allout-buffer key-type for-key
+;;; fetch-pass &optional retried verifying
+;;; passphrase)
+(defun allout-encrypt-string (text decrypt allout-buffer key-type for-key
+ fetch-pass &optional retried rejected
+ verifying passphrase)
+ "Encrypt or decrypt message TEXT.
+
+If DECRYPT is true (default false), then decrypt instead of encrypt.
+
+FETCH-PASS (default false) forces fresh prompting for the passphrase.
+
+KEY-TYPE indicates whether to use a 'symmetric or 'keypair cipher.
+
+FOR-KEY is human readable identification of the first of the user's
+eligible secret keys a keypair decryption targets, or else nil.
+
+Optional RETRIED is for internal use - conveys the number of failed keys
+that have been solicited in sequence leading to this current call.
+
+Optional PASSPHRASE enables explicit delivery of the decryption passphrase,
+for verification purposes.
+
+Optional REJECTED is for internal use - conveys the number of
+rejections due to matches against
+`allout-encryption-ciphertext-rejection-regexps', as limited by
+`allout-encryption-ciphertext-rejection-ceiling'.
+
+Returns the resulting string, or nil if the transformation fails."
+
+ (require 'pgg)
+
+ (if (not (fboundp 'pgg-encrypt-symmetric))
+ (error "Allout encryption depends on a newer version of pgg"))
+
+ (let* ((scheme (upcase
+ (format "%s" (or pgg-scheme pgg-default-scheme "GPG"))))
+ (for-key (and (equal key-type 'keypair)
+ (or for-key
+ (split-string (read-string
+ (format "%s message recipients: "
+ scheme))
+ "[ \t,]+"))))
+ (target-prompt-id (if (equal key-type 'keypair)
+ (if (= (length for-key) 1)
+ (car for-key) for-key)
+ (buffer-name allout-buffer)))
+ (target-cache-id (format "%s-%s"
+ key-type
+ (if (equal key-type 'keypair)
+ target-prompt-id
+ (or (buffer-file-name allout-buffer)
+ target-prompt-id))))
+ (strip-plaintext-regexps
+ (if (not decrypt)
+ (allout-get-configvar-values
+ 'allout-encryption-plaintext-sanitization-regexps)))
+ (reject-ciphertext-regexps
+ (if (not decrypt)
+ (allout-get-configvar-values
+ 'allout-encryption-ciphertext-rejection-regexps)))
+ (rejected (or rejected 0))
+ (rejections-left (- allout-encryption-ciphertext-rejection-ceiling
+ rejected))
+ result-text status)
+
+ (if (and fetch-pass (not passphrase))
+ ;; Force later fetch by evicting passphrase from the cache.
+ (pgg-remove-passphrase-from-cache target-cache-id t))
+
+ (catch 'encryption-failed
+
+ ;; Obtain the passphrase if we don't already have one and we're not
+ ;; doing a keypair encryption:
+ (if (not (or passphrase
+ (and (equal key-type 'keypair)
+ (not decrypt))))
+
+ (setq passphrase (allout-obtain-passphrase for-key
+ target-cache-id
+ target-prompt-id
+ key-type
+ allout-buffer
+ retried fetch-pass)))
+
+ (with-temp-buffer
+
+ (insert text)
+
+ (when (and strip-plaintext-regexps (not decrypt))
+ (dolist (re strip-plaintext-regexps)
+ (let ((re (if (listp re) (car re) re))
+ (replacement (if (listp re) (cadr re) "")))
+ (goto-char (point-min))
+ (while (re-search-forward re nil t)
+ (replace-match replacement nil nil)))))
+
+ (cond
+
+ ;; symmetric:
+ ((equal key-type 'symmetric)
+ (setq status
+ (if decrypt
+
+ (pgg-decrypt (point-min) (point-max) passphrase)
+
+ (pgg-encrypt-symmetric (point-min) (point-max)
+ passphrase)))
+
+ (if status
+ (pgg-situate-output (point-min) (point-max))
+ ;; failed - handle passphrase caching
+ (if verifying
+ (throw 'encryption-failed nil)
+ (pgg-remove-passphrase-from-cache target-cache-id t)
+ (error "Symmetric-cipher %scryption failed - %s"
+ (if decrypt "de" "en")
+ "try again with different passphrase."))))
+
+ ;; encrypt 'keypair:
+ ((not decrypt)
+
+ (setq status
+
+ (pgg-encrypt for-key
+ nil (point-min) (point-max) passphrase))
+
+ (if status
+ (pgg-situate-output (point-min) (point-max))
+ (error (pgg-remove-passphrase-from-cache target-cache-id t)
+ (error "encryption failed"))))
+
+ ;; decrypt 'keypair:
+ (t
+
+ (setq status
+ (pgg-decrypt (point-min) (point-max) passphrase))
+
+ (if status
+ (pgg-situate-output (point-min) (point-max))
+ (error (pgg-remove-passphrase-from-cache target-cache-id t)
+ (error "decryption failed")))))
+
+ (setq result-text
+ (buffer-substring-no-properties
+ 1 (- (point-max) (if decrypt 0 1))))
+ )
+
+ ;; validate result - non-empty
+ (cond ((not result-text)
+ (if verifying
+ nil
+ ;; transform was fruitless, retry w/new passphrase.
+ (pgg-remove-passphrase-from-cache target-cache-id t)
+ (allout-encrypt-string text decrypt allout-buffer
+ key-type for-key nil
+ (if retried (1+ retried) 1)
+ rejected verifying nil)))
+
+ ;; Retry (within limit) if ciphertext contains rejections:
+ ((and (not decrypt)
+ ;; Check for disqualification of this ciphertext:
+ (let ((regexps reject-ciphertext-regexps)
+ reject-it)
+ (while (and regexps (not reject-it))
+ (setq reject-it (string-match (car regexps)
+ result-text))
+ (pop regexps))
+ reject-it))
+ (setq rejections-left (1- rejections-left))
+ (if (<= rejections-left 0)
+ (error (concat "Ciphertext rejected too many times"
+ " (%s), per `%s'")
+ allout-encryption-ciphertext-rejection-ceiling
+ 'allout-encryption-ciphertext-rejection-regexps)
+ (allout-encrypt-string text decrypt allout-buffer
+ key-type for-key nil
+ retried (1+ rejected)
+ verifying passphrase)))
+ ;; Barf if encryption yields extraordinary control chars:
+ ((and (not decrypt)
+ (string-match "[\C-a\C-k\C-o-\C-z\C-@]"
+ result-text))
+ (error (concat "Encryption produced non-armored text, which"
+ "conflicts with allout mode - reconfigure!")))
+
+ ;; valid result and just verifying or non-symmetric:
+ ((or verifying (not (equal key-type 'symmetric)))
+ (if (or verifying decrypt)
+ (pgg-add-passphrase-to-cache target-cache-id
+ passphrase t))
+ result-text)
+
+ ;; valid result and regular symmetric - "register"
+ ;; passphrase with mnemonic aids/cache.
+ (t
+ (set-buffer allout-buffer)
+ (if passphrase
+ (pgg-add-passphrase-to-cache target-cache-id
+ passphrase t))
+ (allout-update-passphrase-mnemonic-aids for-key passphrase
+ allout-buffer)
+ result-text)
+ )
+ )
+ )
+ )
+;;;_ > allout-obtain-passphrase (for-key cache-id prompt-id key-type
+;;; allout-buffer retried fetch-pass)
+(defun allout-obtain-passphrase (for-key cache-id prompt-id key-type
+ allout-buffer retried fetch-pass)
+ "Obtain passphrase for a key from the cache or else from the user.
+
+When obtaining from the user, symmetric-cipher passphrases are verified
+against either, if available and enabled, a random string that was
+encrypted against the passphrase, or else against repeated entry by the
+user for corroboration.
+
+FOR-KEY is the key for which the passphrase is being obtained.
+
+CACHE-ID is the cache id of the key for the passphrase.
+
+PROMPT-ID is the id for use when prompting the user.
+
+KEY-TYPE is either 'symmetric or 'keypair.
+
+ALLOUT-BUFFER is the buffer containing the entry being en/decrypted.
+
+RETRIED is the number of this attempt to obtain this passphrase.
+
+FETCH-PASS causes the passphrase to be solicited from the user, regardless
+of the availability of a cached copy."
+
+ (if (not (equal key-type 'symmetric))
+ ;; do regular passphrase read on non-symmetric passphrase:
+ (pgg-read-passphrase (format "%s passphrase%s: "
+ (upcase (format "%s" (or pgg-scheme
+ pgg-default-scheme
+ "GPG")))
+ (if prompt-id
+ (format " for %s" prompt-id)
+ ""))
+ cache-id t)
+
+ ;; Symmetric hereon:
+
+ (save-excursion
+ (set-buffer allout-buffer)
+ (let* ((hint (if (and (not (string= allout-passphrase-hint-string ""))
+ (or (equal allout-passphrase-hint-handling 'always)
+ (and (equal allout-passphrase-hint-handling
+ 'needed)
+ retried)))
+ (format " [%s]" allout-passphrase-hint-string)
+ ""))
+ (retry-message (if retried (format " (%s retry)" retried) ""))
+ (prompt-sans-hint (format "'%s' symmetric passphrase%s: "
+ prompt-id retry-message))
+ (full-prompt (format "'%s' symmetric passphrase%s%s: "
+ prompt-id hint retry-message))
+ (prompt full-prompt)
+ (verifier-string (allout-get-encryption-passphrase-verifier))
+
+ (cached (and (not fetch-pass)
+ (pgg-read-passphrase-from-cache cache-id t)))
+ (got-pass (or cached
+ (pgg-read-passphrase full-prompt cache-id t)))
+ confirmation)
+
+ (if (not got-pass)
+ nil
+
+ ;; Duplicate our handle on the passphrase so it's not clobbered by
+ ;; deactivate-passwd memory clearing:
+ (setq got-pass (copy-sequence got-pass))
+
+ (cond (verifier-string
+ (save-window-excursion
+ (if (allout-encrypt-string verifier-string 'decrypt
+ allout-buffer 'symmetric
+ for-key nil 0 0 'verifying
+ (copy-sequence got-pass))
+ (setq confirmation (format "%s" got-pass))))
+
+ (if (and (not confirmation)
+ (if (yes-or-no-p
+ (concat "Passphrase differs from established"
+ " - use new one instead? "))
+ ;; deactivate password for subsequent
+ ;; confirmation:
+ (progn
+ (pgg-remove-passphrase-from-cache cache-id t)
+ (setq prompt prompt-sans-hint)
+ nil)
+ t))
+ (progn (pgg-remove-passphrase-from-cache cache-id t)
+ (error "Wrong passphrase."))))
+ ;; No verifier string - force confirmation by repetition of
+ ;; (new) passphrase:
+ ((or fetch-pass (not cached))
+ (pgg-remove-passphrase-from-cache cache-id t))))
+ ;; confirmation vs new input - doing pgg-read-passphrase will do the
+ ;; right thing, in either case:
+ (if (not confirmation)
+ (setq confirmation
+ (pgg-read-passphrase (concat prompt
+ " ... confirm spelling: ")
+ cache-id t)))
+ (prog1
+ (if (equal got-pass confirmation)
+ confirmation
+ (if (yes-or-no-p (concat "spelling of original and"
+ " confirmation differ - retry? "))
+ (progn (setq retried (if retried (1+ retried) 1))
+ (pgg-remove-passphrase-from-cache cache-id t)
+ ;; recurse to this routine:
+ (pgg-read-passphrase prompt-sans-hint cache-id t))
+ (pgg-remove-passphrase-from-cache cache-id t)
+ (error "Confirmation failed."))))))))
+;;;_ > allout-encrypted-topic-p ()
+(defun allout-encrypted-topic-p ()
+ "True if the current topic is encryptable and encrypted."
+ (save-excursion
+ (allout-end-of-prefix t)
+ (and (string= (buffer-substring-no-properties (1- (point)) (point))
+ allout-topic-encryption-bullet)
+ (looking-at "\\*"))
+ )
+ )
+;;;_ > allout-encrypted-key-info (text)
+;; XXX gpg-specific, alas
+(defun allout-encrypted-key-info (text)
+ "Return a pair of the key type and identity of a recipient's secret key.
+
+The key type is one of 'symmetric or 'keypair.
+
+if 'keypair, and some of the user's secret keys are among those for which
+the message was encoded, return the identity of the first. otherwise,
+return nil for the second item of the pair.
+
+An error is raised if the text is not encrypted."
+ (require 'pgg-parse)
+ (save-excursion
+ (with-temp-buffer
+ (insert text)
+ (let* ((parsed-armor (pgg-parse-armor-region (point-min) (point-max)))
+ (type (if (pgg-gpg-symmetric-key-p parsed-armor)
+ 'symmetric
+ 'keypair))
+ secret-keys first-secret-key for-key-owner)
+ (if (equal type 'keypair)
+ (setq secret-keys (pgg-gpg-lookup-all-secret-keys)
+ first-secret-key (pgg-gpg-select-matching-key parsed-armor
+ secret-keys)
+ for-key-owner (and first-secret-key
+ (pgg-gpg-lookup-key-owner
+ first-secret-key))))
+ (list type (pgg-gpg-key-id-from-key-owner for-key-owner))
+ )
+ )
+ )
+ )
+;;;_ > allout-create-encryption-passphrase-verifier (passphrase)
+(defun allout-create-encryption-passphrase-verifier (passphrase)
+ "Encrypt random message for later validation of symmetric key's passphrase."
+ ;; use 20 random ascii characters, across the entire ascii range.
+ (random t)
+ (let ((spew (make-string 20 ?\0)))
+ (dotimes (i (length spew))
+ (aset spew i (1+ (random 254))))
+ (allout-encrypt-string spew nil (current-buffer) 'symmetric
+ nil nil 0 0 passphrase))
+ )
+;;;_ > allout-update-passphrase-mnemonic-aids (for-key passphrase
+;;; outline-buffer)
+(defun allout-update-passphrase-mnemonic-aids (for-key passphrase
+ outline-buffer)
+ "Update passphrase verifier and hint strings if necessary.
+
+See `allout-passphrase-verifier-string' and `allout-passphrase-hint-string'
+settings.
+
+PASSPHRASE is the passphrase being mnemonicized
+
+OUTLINE-BUFFER is the buffer of the outline being adjusted.
+
+These are used to help the user keep track of the passphrase they use for
+symmetric encryption in the file.
+
+Behavior is governed by `allout-passphrase-verifier-handling',
+`allout-passphrase-hint-handling', and also, controlling whether the values
+are preserved on Emacs local file variables,
+`allout-enable-file-variable-adjustment'."
+
+ ;; If passphrase doesn't agree with current verifier:
+ ;; - adjust the verifier
+ ;; - if passphrase hint handling is enabled, adjust the passphrase hint
+ ;; - if file var settings are enabled, adjust the file vars
+
+ (let* ((new-verifier-needed (not (allout-verify-passphrase
+ for-key passphrase outline-buffer)))
+ (new-verifier-string
+ (if new-verifier-needed
+ ;; Collapse to a single line and enclose in string quotes:
+ (subst-char-in-string
+ ?\n ?\C-a (allout-create-encryption-passphrase-verifier
+ passphrase))))
+ new-hint)
+ (when new-verifier-string
+ ;; do the passphrase hint first, since it's interactive
+ (when (and allout-passphrase-hint-handling
+ (not (equal allout-passphrase-hint-handling 'disabled)))
+ (setq new-hint
+ (read-from-minibuffer "Passphrase hint to jog your memory: "
+ allout-passphrase-hint-string))
+ (when (not (string= new-hint allout-passphrase-hint-string))
+ (setq allout-passphrase-hint-string new-hint)
+ (allout-adjust-file-variable "allout-passphrase-hint-string"
+ allout-passphrase-hint-string)))
+ (when allout-passphrase-verifier-handling
+ (setq allout-passphrase-verifier-string new-verifier-string)
+ (allout-adjust-file-variable "allout-passphrase-verifier-string"
+ allout-passphrase-verifier-string))
+ )
+ )
+ )
+;;;_ > allout-get-encryption-passphrase-verifier ()
+(defun allout-get-encryption-passphrase-verifier ()
+ "Return text of the encrypt passphrase verifier, unmassaged, or nil if none.
+
+Derived from value of `allout-passphrase-verifier-string'."
+
+ (let ((verifier-string (and (boundp 'allout-passphrase-verifier-string)
+ allout-passphrase-verifier-string)))
+ (if verifier-string
+ ;; Return it uncollapsed
+ (subst-char-in-string ?\C-a ?\n verifier-string))
+ )
+ )
+;;;_ > allout-verify-passphrase (key passphrase allout-buffer)
+(defun allout-verify-passphrase (key passphrase allout-buffer)
+ "True if passphrase successfully decrypts verifier, nil otherwise.
+
+\"Otherwise\" includes absence of passphrase verifier."
+ (save-excursion
+ (set-buffer allout-buffer)
+ (and (boundp 'allout-passphrase-verifier-string)
+ allout-passphrase-verifier-string
+ (allout-encrypt-string (allout-get-encryption-passphrase-verifier)
+ 'decrypt allout-buffer 'symmetric
+ key nil 0 0 'verifying passphrase)
+ t)))
+;;;_ > allout-next-topic-pending-encryption (&optional except-mark)
+(defun allout-next-topic-pending-encryption (&optional except-mark)
+ "Return the point of the next topic pending encryption, or nil if none.
+
+EXCEPT-MARK identifies a point whose containing topics should be excluded
+from encryption. This supports 'except-current mode of
+`allout-encrypt-unencrypted-on-saves'.
+
+Such a topic has the allout-topic-encryption-bullet without an
+immediately following '*' that would mark the topic as being encrypted. It
+must also have content."
+ (let (done got content-beg)
+ (while (not done)
+
+ (if (not (re-search-forward
+ (format "\\(\\`\\|\n\\)%s *%s[^*]"
+ (regexp-quote allout-header-prefix)
+ (regexp-quote allout-topic-encryption-bullet))
+ nil t))
+ (setq got nil
+ done t)
+ (goto-char (setq got (match-beginning 0)))
+ (if (looking-at "\n")
+ (forward-char 1))
+ (setq got (point)))
+
+ (cond ((not got)
+ (setq done t))
+
+ ((not (search-forward "\n"))
+ (setq got nil
+ done t))
+
+ ((eobp)
+ (setq got nil
+ done t))
+
+ (t
+ (setq content-beg (point))
+ (backward-char 1)
+ (allout-end-of-subtree)
+ (if (or (<= (point) content-beg)
+ (and except-mark
+ (<= content-beg except-mark)
+ (>= (point) except-mark)))
+ ;; Continue looking
+ (setq got nil)
+ ;; Got it!
+ (setq done t)))
+ )
+ )
+ (if got
+ (goto-char got))
+ )
+ )
+;;;_ > allout-encrypt-decrypted (&optional except-mark)
+(defun allout-encrypt-decrypted (&optional except-mark)
+ "Encrypt topics pending encryption except those containing exemption point.
+
+EXCEPT-MARK identifies a point whose containing topics should be excluded
+from encryption. This supports 'except-current mode of
+`allout-encrypt-unencrypted-on-saves'.
+
+If a topic that is currently being edited was encrypted, we return a list
+containing the location of the topic and the location of the cursor just
+before the topic was encrypted. This can be used, eg, to decrypt the topic
+and exactly resituate the cursor if this is being done as part of a file
+save. See `allout-encrypt-unencrypted-on-saves' for more info."
+
+ (interactive "p")
+ (save-excursion
+ (let* ((current-mark (point-marker))
+ (current-mark-position (marker-position current-mark))
+ was-modified
+ bo-subtree
+ editing-topic editing-point)
+ (goto-char (point-min))
+ (while (allout-next-topic-pending-encryption except-mark)
+ (setq was-modified (buffer-modified-p))
+ (when (save-excursion
+ (and (boundp 'allout-encrypt-unencrypted-on-saves)
+ allout-encrypt-unencrypted-on-saves
+ (setq bo-subtree (re-search-forward "$"))
+ (not (allout-hidden-p))
+ (>= current-mark (point))
+ (allout-end-of-current-subtree)
+ (<= current-mark (point))))
+ (setq editing-topic (point)
+ ;; we had to wait for this 'til now so prior topics are
+ ;; encrypted, any relevant text shifts are in place:
+ editing-point (- current-mark-position
+ (count-trailing-whitespace-region
+ bo-subtree current-mark-position))))
+ (allout-toggle-subtree-encryption)
+ (if (not was-modified)
+ (set-buffer-modified-p nil))
+ )
+ (if (not was-modified)
+ (set-buffer-modified-p nil))
+ (if editing-topic (list editing-topic editing-point))
+ )
+ )
+ )
+
+;;;_ #9 miscellaneous
+;;;_ : Mode:
+;;;_ > outlineify-sticky ()
+;; outlinify-sticky is correct spelling; provide this alias for sticklers:
+;;;###autoload
+(defalias 'outlinify-sticky 'outlineify-sticky)
+;;;###autoload
+(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'."))
+ (allout-adjust-file-variable
+ "allout-layout" (or allout-layout '(-1 : 0))))))
+;;;_ > allout-file-vars-section-data ()
+(defun allout-file-vars-section-data ()
+ "Return data identifying the file-vars section, or nil if none.
+
+Returns list `(beginning-point prefix-string suffix-string)'."
+ ;; minimally gleaned from emacs 21.4 files.el hack-local-variables function.
+ (let (beg prefix suffix)
+ (save-excursion
+ (goto-char (point-max))
+ (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move)
+ (if (let ((case-fold-search t))
+ (not (search-forward "Local Variables:" nil t)))
+ nil
+ (setq beg (- (point) 16))
+ (setq suffix (buffer-substring-no-properties
+ (point)
+ (progn (if (search-forward "\n" nil t)
+ (forward-char -1))
+ (point))))
+ (setq prefix (buffer-substring-no-properties
+ (progn (if (search-backward "\n" nil t)
+ (forward-char 1))
+ (point))
+ beg))
+ (list beg prefix suffix))
+ )
+ )
+ )
+;;;_ > allout-adjust-file-variable (varname value)
+(defun allout-adjust-file-variable (varname value)
+ "Adjust the setting of an emacs file variable named VARNAME to VALUE.
+
+This activity is inhibited if either `enable-local-variables'
+`allout-enable-file-variable-adjustment' are nil.
+
+When enabled, an entry for the variable is created if not already present,
+or changed if established with a different value. The section for the file
+variables, itself, is created if not already present. When created, the
+section lines \(including the section line) exist as second-level topics in
+a top-level topic at the end of the file.
+
+enable-local-variables must be true for any of this to happen."
+ (if (not (and enable-local-variables
+ allout-enable-file-variable-adjustment))
+ nil
+ (save-excursion
+ (let ((inhibit-field-text-motion t)
+ (section-data (allout-file-vars-section-data))
+ beg prefix suffix)
+ (if section-data
+ (setq beg (car section-data)
+ prefix (cadr section-data)
+ suffix (car (cddr section-data)))
+ ;; create the section
+ (goto-char (point-max))
+ (open-line 1)
+ (allout-open-topic 0)
+ (end-of-line)
+ (insert "Local emacs vars.\n")
+ (allout-open-topic 1)
+ (setq beg (point)
+ suffix ""
+ prefix (buffer-substring-no-properties (progn
+ (beginning-of-line)
+ (point))
+ beg))
+ (goto-char beg)
+ (insert "Local variables:\n")
+ (allout-open-topic 0)
+ (insert "End:\n")
+ )
+ ;; look for existing entry or create one, leaving point for insertion
+ ;; of new value:
+ (goto-char beg)
+ (allout-show-to-offshoot)
+ (if (search-forward (concat "\n" prefix varname ":") nil t)
+ (let* ((value-beg (point))
+ (line-end (progn (if (search-forward "\n" nil t)
+ (forward-char -1))
+ (point)))
+ (value-end (- line-end (length suffix))))
+ (if (> value-end value-beg)
+ (delete-region value-beg value-end)))
+ (end-of-line)
+ (open-line 1)
+ (forward-line 1)
+ (insert (concat prefix varname ":")))
+ (insert (format " %S%s" value suffix))
+ )
+ )
+ )
+ )
+;;;_ > allout-get-configvar-values (varname)
+(defun allout-get-configvar-values (configvar-name)
+ "Return a list of values of the symbols in list bound to CONFIGVAR-NAME.
+
+The user is prompted for removal of symbols that are unbound, and they
+otherwise are ignored.
+
+CONFIGVAR-NAME should be the name of the configuration variable,
+not its value."
+
+ (let ((configvar-value (symbol-value configvar-name))
+ got)
+ (dolist (sym configvar-value)
+ (if (not (boundp sym))
+ (if (yes-or-no-p (format "%s entry `%s' is unbound - remove it? "
+ configvar-name sym))
+ (delq sym (symbol-value configvar-name)))
+ (push (symbol-value sym) got)))
+ (reverse got)))
+;;;_ : Topics:
+;;;_ > allout-mark-topic ()
+(defun allout-mark-topic ()
+ "Put the region around topic currently containing point."
+ (interactive)
+ (let ((inhibit-field-text-motion t))
+ (beginning-of-line))
+ (allout-goto-prefix-doublechecked)
+ (push-mark (point))
+ (allout-end-of-current-subtree)
+ (exchange-point-and-mark))
+;;;_ : UI:
+;;;_ > 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.
+
+Optional arg DO-DEFAULTING indicates to accept empty input (CR)."
+
+ (let ((new-prompt prompt)
+ got)
+
+ (while (not got)
+ (message "%s" new-prompt)
+
+ ;; We do our own reading here, so we can circumvent, eg, special
+ ;; treatment for `?' character. (Oughta use minibuffer keymap instead.)
+ (setq got
+ (char-to-string (let ((cursor-in-echo-area nil)) (read-char))))
+
+ (setq 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)
+ )
+;;;_ : Strings:
+;;;_ > 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.
+
+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))))
+;;;_ > count-trailing-whitespace-region (beg end)
+(defun count-trailing-whitespace-region (beg end)
+ "Return number of trailing whitespace chars between BEG and END.
+
+If BEG is bigger than END we return 0."
+ (if (> beg end)
+ 0
+ (save-excursion
+ (goto-char beg)
+ (let ((count 0))
+ (while (re-search-forward "[ ][ ]*$" end t)
+ (goto-char (1+ (match-beginning 2)))
+ (setq count (1+ count)))
+ count))))
+;;;_ > allout-format-quote (string)
+(defun allout-format-quote (string)
+ "Return a copy of string with all \"%\" characters doubled."
+ (apply 'concat
+ (mapcar (lambda (char) (if (= char ?%) "%%" (char-to-string char)))
+ string)))
+;;;_ : lists
+;;;_ > allout-flatten (list)
+(defun allout-flatten (list)
+ "Return a list of all atoms in list."
+ ;; classic.
+ (cond ((null list) nil)
+ ((atom (car list)) (cons (car list) (allout-flatten (cdr list))))
+ (t (append (allout-flatten (car list)) (allout-flatten (cdr list))))))
+;;;_ : Compatability:
+;;;_ > allout-mark-marker to accommodate divergent emacsen:
+(defun allout-mark-marker (&optional force buffer)
+ "Accommodate the different signature for `mark-marker' across Emacsen.
+
+XEmacs takes two optional args, while mainline GNU Emacs does not,
+so pass them along when appropriate."
+ (if (featurep 'xemacs)
+ (apply 'mark-marker force buffer)
+ (mark-marker)))
+;;;_ > subst-char-in-string if necessary
+(if (not (fboundp 'subst-char-in-string))
+ (defun subst-char-in-string (fromchar tochar string &optional inplace)
+ "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
+Unless optional argument INPLACE is non-nil, return a new string."
+ (let ((i (length string))
+ (newstr (if inplace string (copy-sequence string))))
+ (while (> i 0)
+ (setq i (1- i))
+ (if (eq (aref newstr i) fromchar)
+ (aset newstr i tochar)))
+ newstr)))
+;;;_ > wholenump if necessary
+(if (not (fboundp 'wholenump))
+ (defalias 'wholenump 'natnump))
+;;;_ > remove-overlays if necessary
+(if (not (fboundp 'remove-overlays))
+ (defun remove-overlays (&optional beg end name val)
+ "Clear BEG and END of overlays whose property NAME has value VAL.
+Overlays might be moved and/or split.
+BEG and END default respectively to the beginning and end of buffer."
+ (unless beg (setq beg (point-min)))
+ (unless end (setq end (point-max)))
+ (if (< end beg)
+ (setq beg (prog1 end (setq end beg))))
+ (save-excursion
+ (dolist (o (overlays-in beg end))
+ (when (eq (overlay-get o name) val)
+ ;; Either push this overlay outside beg...end
+ ;; or split it to exclude beg...end
+ ;; or delete it entirely (if it is contained in beg...end).
+ (if (< (overlay-start o) beg)
+ (if (> (overlay-end o) end)
+ (progn
+ (move-overlay (copy-overlay o)
+ (overlay-start o) beg)
+ (move-overlay o end (overlay-end o)))
+ (move-overlay o (overlay-start o) beg))
+ (if (> (overlay-end o) end)
+ (move-overlay o end (overlay-end o))
+ (delete-overlay o)))))))
+ )
+;;;_ > copy-overlay if necessary - xemacs ~ 21.4
+(if (not (fboundp 'copy-overlay))
+ (defun copy-overlay (o)
+ "Return a copy of overlay O."
+ (let ((o1 (make-overlay (overlay-start o) (overlay-end o)
+ ;; FIXME: there's no easy way to find the
+ ;; insertion-type of the two markers.
+ (overlay-buffer o)))
+ (props (overlay-properties o)))
+ (while props
+ (overlay-put o1 (pop props) (pop props)))
+ o1)))
+;;;_ > add-to-invisibility-spec if necessary - xemacs ~ 21.4
+(if (not (fboundp 'add-to-invisibility-spec))
+ (defun add-to-invisibility-spec (element)
+ "Add ELEMENT to `buffer-invisibility-spec'.
+See documentation for `buffer-invisibility-spec' for the kind of elements
+that can be added."
+ (if (eq buffer-invisibility-spec t)
+ (setq buffer-invisibility-spec (list t)))
+ (setq buffer-invisibility-spec
+ (cons element buffer-invisibility-spec))))
+;;;_ > remove-from-invisibility-spec if necessary - xemacs ~ 21.4
+(if (not (fboundp 'remove-from-invisibility-spec))
+ (defun remove-from-invisibility-spec (element)
+ "Remove ELEMENT from `buffer-invisibility-spec'."
+ (if (consp buffer-invisibility-spec)
+ (setq buffer-invisibility-spec (delete element
+ buffer-invisibility-spec)))))
+;;;_ > move-beginning-of-line if necessary - older emacs, xemacs
+(if (not (fboundp 'move-beginning-of-line))
+ (defun move-beginning-of-line (arg)
+ "Move point to beginning of current line as displayed.
+\(This disregards invisible newlines such as those
+which are part of the text that an image rests on.)
+
+With argument ARG not nil or 1, move forward ARG - 1 lines first.
+If point reaches the beginning or end of buffer, it stops there.
+To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (if (/= arg 1)
+ (condition-case nil (line-move (1- arg)) (error nil)))
+
+ ;; Move to beginning-of-line, ignoring fields and invisibles.
+ (skip-chars-backward "^\n")
+ (while (and (not (bobp)) (line-move-invisible-p (1- (point))))
+ (goto-char (if (featurep 'xemacs)
+ (previous-property-change (point))
+ (previous-char-property-change (point))))
+ (skip-chars-backward "^\n"))
+ (vertical-motion 0))
+)
+;;;_ > move-end-of-line if necessary - older emacs, xemacs
+(if (not (fboundp 'move-end-of-line))
+ (defun move-end-of-line (arg)
+ "Move point to end of current line as displayed.
+\(This disregards invisible newlines such as those
+which are part of the text that an image rests on.)
+
+With argument ARG not nil or 1, move forward ARG - 1 lines first.
+If point reaches the beginning or end of buffer, it stops there.
+To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
+ (interactive "p")
+ (or arg (setq arg 1))
+ (let (done)
+ (while (not done)
+ (let ((newpos
+ (save-excursion
+ (let ((goal-column 0))
+ (and (condition-case nil
+ (or (line-move arg) t)
+ (error nil))
+ (not (bobp))
+ (progn
+ (while (and (not (bobp))
+ (line-move-invisible-p (1- (point))))
+ (goto-char
+ (previous-char-property-change (point))))
+ (backward-char 1)))
+ (point)))))
+ (goto-char newpos)
+ (if (and (> (point) newpos)
+ (eq (preceding-char) ?\n))
+ (backward-char 1)
+ (if (and (> (point) newpos) (not (eobp))
+ (not (eq (following-char) ?\n)))
+ ;; If we skipped something intangible
+ ;; and now we're not really at eol,
+ ;; keep going.
+ (setq arg 1)
+ (setq done t)))))))
+ )
+;;;_ > line-move-invisible-p if necessary
+(if (not (fboundp 'line-move-invisible-p))
+ (defun line-move-invisible-p (pos)
+ "Return non-nil if the character after POS is currently invisible."
+ (let ((prop
+ (get-char-property pos 'invisible)))
+ (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec))))))
+
+;;;_ #10 Unfinished
+;;;_ > 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)))
+
+;;;_ #11 Unit tests - this should be last item before "Provide"
+;;;_ > allout-run-unit-tests ()
+(defun allout-run-unit-tests ()
+ "Run the various allout unit tests."
+ (message "Running allout tests...")
+ (allout-test-resumptions)
+ (message "Running allout tests... Done.")
+ (sit-for .5))
+;;;_ : test resumptions:
+;;;_ > allout-tests-obliterate-variable (name)
+(defun allout-tests-obliterate-variable (name)
+ "Completely unbind variable with NAME."
+ (if (local-variable-p name) (kill-local-variable name))
+ (while (boundp name) (makunbound name)))
+;;;_ > allout-test-resumptions ()
+(defvar allout-tests-globally-unbound nil
+ "Fodder for allout resumptions tests - defvar just for byte compiler.")
+(defvar allout-tests-globally-true nil
+ "Fodder for allout resumptions tests - defvar just just for byte compiler.")
+(defvar allout-tests-locally-true nil
+ "Fodder for allout resumptions tests - defvar just for byte compiler.")
+(defun allout-test-resumptions ()
+ "Exercise allout resumptions."
+ ;; for each resumption case, we also test that the right local/global
+ ;; scopes are affected during resumption effects:
+
+ ;; ensure that previously unbound variables return to the unbound state.
+ (with-temp-buffer
+ (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
+ (allout-add-resumptions '(allout-tests-globally-unbound t))
+ (assert (not (default-boundp 'allout-tests-globally-unbound)))
+ (assert (local-variable-p 'allout-tests-globally-unbound))
+ (assert (boundp 'allout-tests-globally-unbound))
+ (assert (equal allout-tests-globally-unbound t))
+ (allout-do-resumptions)
+ (assert (not (local-variable-p 'allout-tests-globally-unbound)))
+ (assert (not (boundp 'allout-tests-globally-unbound))))
+
+ ;; ensure that variable with prior global value is resumed
+ (with-temp-buffer
+ (allout-tests-obliterate-variable 'allout-tests-globally-true)
+ (setq allout-tests-globally-true t)
+ (allout-add-resumptions '(allout-tests-globally-true nil))
+ (assert (equal (default-value 'allout-tests-globally-true) t))
+ (assert (local-variable-p 'allout-tests-globally-true))
+ (assert (equal allout-tests-globally-true nil))
+ (allout-do-resumptions)
+ (assert (not (local-variable-p 'allout-tests-globally-true)))
+ (assert (boundp 'allout-tests-globally-true))
+ (assert (equal allout-tests-globally-true t)))
+
+ ;; ensure that prior local value is resumed
+ (with-temp-buffer
+ (allout-tests-obliterate-variable 'allout-tests-locally-true)
+ (set (make-local-variable 'allout-tests-locally-true) t)
+ (assert (not (default-boundp 'allout-tests-locally-true))
+ nil (concat "Test setup mistake - variable supposed to"
+ " not have global binding, but it does."))
+ (assert (local-variable-p 'allout-tests-locally-true)
+ nil (concat "Test setup mistake - variable supposed to have"
+ " local binding, but it lacks one."))
+ (allout-add-resumptions '(allout-tests-locally-true nil))
+ (assert (not (default-boundp 'allout-tests-locally-true)))
+ (assert (local-variable-p 'allout-tests-locally-true))
+ (assert (equal allout-tests-locally-true nil))
+ (allout-do-resumptions)
+ (assert (boundp 'allout-tests-locally-true))
+ (assert (local-variable-p 'allout-tests-locally-true))
+ (assert (equal allout-tests-locally-true t))
+ (assert (not (default-boundp 'allout-tests-locally-true))))
+
+ ;; ensure that last of multiple resumptions holds, for various scopes.
+ (with-temp-buffer
+ (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
+ (allout-tests-obliterate-variable 'allout-tests-globally-true)
+ (setq allout-tests-globally-true t)
+ (allout-tests-obliterate-variable 'allout-tests-locally-true)
+ (set (make-local-variable 'allout-tests-locally-true) t)
+ (allout-add-resumptions '(allout-tests-globally-unbound t)
+ '(allout-tests-globally-true nil)
+ '(allout-tests-locally-true nil))
+ (allout-add-resumptions '(allout-tests-globally-unbound 2)
+ '(allout-tests-globally-true 3)
+ '(allout-tests-locally-true 4))
+ ;; reestablish many of the basic conditions are maintained after re-add:
+ (assert (not (default-boundp 'allout-tests-globally-unbound)))
+ (assert (local-variable-p 'allout-tests-globally-unbound))
+ (assert (equal allout-tests-globally-unbound 2))
+ (assert (default-boundp 'allout-tests-globally-true))
+ (assert (local-variable-p 'allout-tests-globally-true))
+ (assert (equal allout-tests-globally-true 3))
+ (assert (not (default-boundp 'allout-tests-locally-true)))
+ (assert (local-variable-p 'allout-tests-locally-true))
+ (assert (equal allout-tests-locally-true 4))
+ (allout-do-resumptions)
+ (assert (not (local-variable-p 'allout-tests-globally-unbound)))
+ (assert (not (boundp 'allout-tests-globally-unbound)))
+ (assert (not (local-variable-p 'allout-tests-globally-true)))
+ (assert (boundp 'allout-tests-globally-true))
+ (assert (equal allout-tests-globally-true t))
+ (assert (boundp 'allout-tests-locally-true))
+ (assert (local-variable-p 'allout-tests-locally-true))
+ (assert (equal allout-tests-locally-true t))
+ (assert (not (default-boundp 'allout-tests-locally-true))))
+
+ ;; ensure that deliberately unbinding registered variables doesn't foul things
+ (with-temp-buffer
+ (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
+ (allout-tests-obliterate-variable 'allout-tests-globally-true)
+ (setq allout-tests-globally-true t)
+ (allout-tests-obliterate-variable 'allout-tests-locally-true)
+ (set (make-local-variable 'allout-tests-locally-true) t)
+ (allout-add-resumptions '(allout-tests-globally-unbound t)
+ '(allout-tests-globally-true nil)
+ '(allout-tests-locally-true nil))
+ (allout-tests-obliterate-variable 'allout-tests-globally-unbound)
+ (allout-tests-obliterate-variable 'allout-tests-globally-true)
+ (allout-tests-obliterate-variable 'allout-tests-locally-true)
+ (allout-do-resumptions))
+ )
+;;;_ % Run unit tests if `allout-run-unit-tests-after-load' is true:
+(when allout-run-unit-tests-on-load
+ (allout-run-unit-tests))
+
+;;;_ #12 Provide
+(provide 'allout)
+
+;;;_* Local emacs vars.
+;; 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
HCoop / bpt / emacs.git / blobdiff