;; 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.
;; - 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-current-buffer in allout.el; but
+;; 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
;; and more.
;;
;; See the `allout-mode' function's docstring for an introduction to the
-;; mode. The development version and helpful notes are available at
+;; 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
;; 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.
+;; Just `ESC-x eval-buffer' to give it a whirl.
;; ken manheimer (ken dot manheimer at gmail dot com)
;;;_* Dependency autoloads
(require 'overlay)
-(eval-when-compile (progn (require 'pgg)
- (require 'pgg-gpg)
- (require 'overlay)
- ))
-(autoload 'pgg-gpg-symmetric-key-p "pgg-gpg"
- "True if decoded armor MESSAGE-KEYS has symmetric encryption indicator.")
+(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:
: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'. Many
-outlines start at level 2 to avoid this discrepancy."
+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.
: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.
: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.
: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'
-and/or comment-start string, if any, to lead the topic prefix string,
-so topic headers look like comments in the programming language.
+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 they stand.
+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 \(`.').
Set to the symbol for either of `allout-mode-leaders' or
`comment-start' to use only one of them, respectively.
-Value nil means to always use the default \(`.').
-
-comment-start strings that do not end in spaces are tripled, and an
-`_' underscore is tacked on the end, to distinguish them from regular
-comment strings. comment-start strings that do end in spaces are not
-tripled, but an underscore is substituted for the space. [This
-presumes that the space is for appearance, not comment syntax. You
-can use `allout-mode-leaders' to override this behavior, when
-incorrect.]"
+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.
-Entries will be used instead or in lieu of mode-specific
-comment-start strings. See also `allout-use-mode-specific-leader'.
+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 bol.")
+from regular comments that start at the beginning-of-line.")
;;;_ = allout-old-style-prefixes
(defcustom allout-old-style-prefixes nil
: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.
: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 "#"
: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."
: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
: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)
- :group 'allout)
+ :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
- :group 'allout)
+ :version "22.0"
+ :group 'allout-encryption)
(make-variable-buffer-local 'allout-passphrase-verifier-handling)
;;;_ = allout-passphrase-hint-handling
(defcustom allout-passphrase-hint-handling 'always
:type '(choice (const always)
(const needed)
(const disabled))
- :group 'allout)
+ :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
:type '(choice (const :tag "Yes" t)
(const :tag "All except current topic" except-current)
(const :tag "No" nil))
- :group 'allout)
+ :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
("=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.
: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
: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
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 (listp x) (symbolp x))))
+(put 'allout-layout 'safe-local-variable
+ '(lambda (x) (or (numberp x) (listp x) (memq x '(: * + -)))))
;;;_ : Topic header format
;;;_ = allout-regexp
(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 when `allout-regexp' is produced by
-`set-allout-regexp', so that (match-beginning 2) and (match-end
-2) delimit the prefix.")
+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.
-\(match-beginning 2) and \(match-end 2) delimit the prefix.")
+ "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))
"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."
(setq allout-reindent-bodies nil)
(allout-reset-header-lead header-lead)
header-lead)
-;;;_ > allout-infer-header-lead ()
-(defun allout-infer-header-lead ()
- "Determine appropriate `allout-header-prefix'.
+;;;_ > 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:
"_")))))))
(if (not leader)
nil
- (if (string= leader allout-header-prefix)
- nil ; no change, nothing to do.
- (setq allout-header-prefix leader)
- allout-header-prefix))))
+ (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'.
"Generate proper topic-header regexp form for outline functions.
Works with respect to `allout-plain-bullets-string' and
-`allout-distinctive-bullets-string'."
+`allout-distinctive-bullets-string'.
+
+Also refresh various data structures that hinge on the regexp."
(interactive)
;; Derive allout-bullets-string from user configured components:
;; Derive next for repeated use in allout-pending-bullet:
(setq allout-plain-bullets-string-len (length allout-plain-bullets-string))
(setq allout-header-subtraction (1- (length allout-header-prefix)))
- ;; Produce the new allout-regexp:
- (setq allout-regexp (concat "\\(\\"
- allout-header-prefix
- "[ \t]*["
- allout-bullets-string
- "]\\)\\|\\"
- allout-primary-bullet
- "+\\|\^l"))
- (setq allout-line-boundary-regexp
- (concat "\\(\n\\)\\(" allout-regexp "\\)"))
- (setq allout-bob-regexp
- (concat "\\(\\`\\)\\(" allout-regexp "\\)"))
- )
+
+ (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.")
(car (cdr cell)))))))
keymap-list)
map))
-;;;_ = allout-prior-bindings - being deprecated.
-(defvar allout-prior-bindings nil
- "Variable for use in V18, with allout-added-bindings, for
-resurrecting, on mode deactivation, bindings that existed before
-activation. Being deprecated.")
-;;;_ = allout-added-bindings - being deprecated
-(defvar allout-added-bindings nil
- "Variable for use in V18, with allout-prior-bindings, for
-resurrecting, on mode deactivation, bindings that existed before
-activation. Being deprecated.")
;;;_ : Menu bar
(defvar allout-mode-exposure-menu)
(defvar allout-mode-editing-menu)
"----"
["Set Header Lead" allout-reset-header-lead t]
["Set New Exposure" allout-expose-topic t])))
-;;;_ : Mode-Specific Variable Maintenance Utilities
+;;;_ : 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.")
-(make-variable-buffer-local 'allout-mode-prior-settings)
-;;;_ > allout-resumptions (name &optional value)
-(defun allout-resumptions (name &optional value)
-
- "Registers or resumes settings over `allout-mode' activation/deactivation.
-
-First arg is NAME of variable affected. Optional second arg is list
-containing allout-mode-specific VALUE to be imposed on named
-variable, and to be registered. \(It's a list so you can specify
-registrations of null values.) If no value is specified, the
-registered value is returned (encapsulated in the list, so the caller
-can distinguish nil vs no value), and the registration is popped
-from the list."
-
- (let ((on-list (assq name allout-mode-prior-settings))
- prior-capsule ; By `capsule' i mean a list
- ; containing a value, so we can
- ; distinguish nil from no value.
- )
-
- (if value
+ "Internal `allout-mode' use; settings to be resumed on mode deactivation.
- ;; 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 allout-mode-prior-settings
- (cons (list name
- (if (boundp name) (list (symbol-value name))))
- allout-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 allout-mode-prior-settings
- (if (not (eq (car allout-mode-prior-settings)
- on-list))
- (setq rebuild
- (cons (car allout-mode-prior-settings)
- rebuild)))
- (setq allout-mode-prior-settings
- (cdr allout-mode-prior-settings)))
- (setq allout-mode-prior-settings rebuild)))))
- )
+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 t))
+ `(let ((inhibit-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-overlay-category
-(defvar allout-overlay-category nil
- "Symbol for use in allout invisible-text overlays as the category.")
-;;;_ = allout-view-change-hook
+;;;_ = 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
- "*Hook that's run after allout outline visibility changes.")
+ "*\(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.
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 ""
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)
-(put 'allout-passphrase-hint-string 'safe-local-variable 'stringp)
(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:
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!
(setq cur (car menus)
menus (cdr menus))
(easy-menu-add cur))))
-;;;_ > allout-set-overlay-category
-(defun allout-set-overlay-category ()
- "Set the properties of the allout invisible-text overlay."
- (setplist 'allout-overlay-category nil)
- (put 'allout-overlay-category 'invisible 'allout)
- (put 'allout-overlay-category 'evaporate t)
+;;;_ > 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-overlay-category 'isearch-open-invisible
+ (put 'allout-exposure-category 'isearch-open-invisible
'allout-isearch-end-handler)
(if (featurep 'xemacs)
- (put 'allout-overlay-category 'start-open t)
- (put 'allout-overlay-category 'insert-in-front-hooks
+ (put 'allout-exposure-category 'start-open t)
+ (put 'allout-exposure-category 'insert-in-front-hooks
'(allout-overlay-insert-in-front-handler)))
- (if (featurep 'xemacs)
- (progn (make-variable-buffer-local 'before-change-functions)
- (add-hook 'before-change-functions
- 'allout-before-change-handler))
- (put 'allout-overlay-category 'modification-hooks
- '(allout-overlay-interior-modification-handler))))
+ (put 'allout-exposure-category 'modification-hooks
+ '(allout-overlay-interior-modification-handler)))
;;;_ > allout-mode (&optional toggle)
;;;_ : Defun:
;;;###autoload
; active state or *de*activation
; specifically requested:
(setq allout-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 (function
- (lambda (cell)
- (if (eq (lookup-key curr-loc (car cell))
- (car (cdr cell)))
- (define-key curr-loc (car cell)
- (assq (car cell) allout-prior-bindings)))))
- allout-added-bindings)
- (allout-resumptions 'allout-added-bindings)
- (allout-resumptions 'allout-prior-bindings)))
- (if allout-old-style-prefixes
- (progn
- (allout-resumptions 'allout-primary-bullet)
- (allout-resumptions 'allout-old-style-prefixes)))
- ;;(allout-resumptions 'selective-display)
+ (allout-do-resumptions)
+
(remove-from-invisibility-spec '(allout . t))
- (set write-file-hook-var-name
- (delq 'allout-write-file-hook-handler
- (symbol-value write-file-hook-var-name)))
- (setq auto-save-hook
- (delq 'allout-auto-save-hook-handler
- auto-save-hook))
- (allout-resumptions 'paragraph-start)
- (allout-resumptions 'paragraph-separate)
- (allout-resumptions 'auto-fill-function)
- (allout-resumptions 'normal-auto-fill-function)
- (allout-resumptions 'allout-former-auto-filler)
- (setq allout-mode nil))
+ (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
- (progn ; Inhibit all the fancy formatting:
- (allout-resumptions 'allout-primary-bullet '("*"))
- (allout-resumptions 'allout-old-style-prefixes '(()))))
+ ;; Inhibit all the fancy formatting:
+ (allout-add-resumptions '(allout-primary-bullet "*")))
- (allout-set-overlay-category) ; Doesn't hurt to redo this.
+ (allout-overlay-preparations) ; Doesn't hurt to redo this.
- (allout-infer-header-lead)
+ (allout-infer-header-lead-and-primary-bullet)
(allout-infer-body-reindent)
(set-allout-regexp)
-
- ; Produce map from current version
- ; of allout-keybindings-list:
- (if (boundp 'minor-mode-map-alist)
-
- (progn ; V19, and maybe lucid and
- ; epoch, minor-mode key bindings:
- (setq allout-mode-map
- (produce-allout-mode-map allout-keybindings-list))
- (produce-allout-mode-menubar-entries)
- (fset 'allout-mode-map allout-mode-map)
- ; Include on minor-mode-map-alist,
- ; if not already there:
- (if (not (member '(allout-mode . allout-mode-map)
- minor-mode-map-alist))
- (setq minor-mode-map-alist
- (cons '(allout-mode . allout-mode-map)
- minor-mode-map-alist))))
-
- ; V18 minor-mode key bindings:
- ; Stash record of added bindings
- ; for later revocation:
- (allout-resumptions 'allout-added-bindings
- (list allout-keybindings-list))
- (allout-resumptions 'allout-prior-bindings
- (list (current-local-map)))
- ; and add them:
- (use-local-map (produce-allout-mode-map allout-keybindings-list
- (current-local-map)))
- )
+ (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))
- (make-local-variable 'line-move-ignore-invisible)
- (setq line-move-ignore-invisible t)
- (add-hook 'pre-command-hook 'allout-pre-command-business)
- (add-hook 'post-command-hook 'allout-post-command-business)
- (add-hook 'isearch-mode-end-hook 'allout-isearch-end-handler)
- (add-hook write-file-hook-var-name 'allout-write-file-hook-handler)
- (add-hook 'auto-save-hook 'allout-auto-save-hook-handler)
- ; Custom auto-fill func, to support
- ; respect for topic headline,
- ; hanging-indents, etc:
- ;; Register prevailing fill func for use by allout-auto-fill:
- (allout-resumptions 'allout-former-auto-filler (list auto-fill-function))
- ;; Register allout-auto-fill to be used if filling is active:
- (allout-resumptions 'auto-fill-function '(allout-auto-fill))
- (allout-resumptions 'allout-outside-normal-auto-fill-function
- (list normal-auto-fill-function))
- (allout-resumptions 'normal-auto-fill-function '(allout-auto-fill))
- ;; Paragraphs are broken by topic headlines.
- (make-local-variable 'paragraph-start)
- (allout-resumptions 'paragraph-start
- (list (concat paragraph-start "\\|^\\("
- allout-regexp "\\)")))
- (make-local-variable 'paragraph-separate)
- (allout-resumptions 'paragraph-separate
- (list (concat paragraph-separate "\\|^\\("
- allout-regexp "\\)")))
-
+ (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)))
(if allout-layout
(setq do-layout t))
- (run-hooks 'allout-mode-hook)
- (setq allout-mode t))
+ (setq allout-mode t)
+ (run-hooks 'allout-mode-hook))
;; Reactivation:
((setq do-layout t)
(allout-infer-body-reindent))
- ) ; cond
+ ) ;; end of activation-mode cases.
+ ;; Do auto layout if warranted:
(let ((use-layout (if (listp allout-layout)
allout-layout
allout-default-layout)))
;;;_ > allout-hidden-p (&optional pos)
(defsubst allout-hidden-p (&optional pos)
"Non-nil if the character after point is invisible."
- (get-char-property (or pos (point)) 'invisible))
+ (eq (get-char-property (or pos (point)) 'invisible) 'allout))
;;;_ > allout-overlay-insert-in-front-handler (ol after beg end
;;; &optional prelen)
(let ((start (point))
(ol-start (overlay-start ol))
(ol-end (overlay-end ol))
- (msg "Change within concealed text disallowed.")
- opened
first)
(goto-char beg)
(while (< (point) end)
(save-excursion (forward-char 1)
(allout-show-to-offshoot)))
(when (not first)
- (setq opened t)
(setq first (point))))
(goto-char (if (featurep 'xemacs)
(next-property-change (1+ (point)) nil end)
This before-change handler is used only where modification-hooks
overlay property is not supported."
- (if (not (allout-mode-p))
- nil
- (allout-overlay-interior-modification-handler nil nil beg end nil)))
+
+ (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.
(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 (beg end)
-(defmacro allout-prefix-data (beg end)
- "Register allout-prefix state data - BEGINNING and END of prefix.
+;;;_ > 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 ,end
- allout-recent-prefix-beginning ,beg))
+ (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 ()
-(defmacro 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
`allout-recent-prefix-end' if successful. This function uses those settings
to return the current depth."
- '(max 1 (- allout-recent-prefix-end
- allout-recent-prefix-beginning
- allout-header-subtraction)))
+ allout-recent-depth)
;;;_ > allout-recent-prefix ()
-(defmacro 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 depth."
- '(buffer-substring allout-recent-prefix-beginning
- allout-recent-prefix-end))
+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.
headings set the variables `allout-recent-prefix-beginning' and
`allout-recent-prefix-end' if successful. This function uses those settings
to return the current depth of the most recently matched topic."
- '(buffer-substring (1- allout-recent-prefix-end)
- allout-recent-prefix-end))
+ '(buffer-substring-no-properties (1- allout-recent-prefix-end)
+ allout-recent-prefix-end))
;;;_ #4 Navigation
(save-excursion
(allout-beginning-of-current-line)
(and (looking-at allout-regexp)
- (allout-prefix-data (match-beginning 0) (match-end 0)))))
+ (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 (beginning-of-line)
+ (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 ()
(let ((start-point (point)))
(if (and (allout-goto-prefix)
(not (< start-point (point))))
- (allout-recent-depth)
+ allout-recent-depth
(progn
- ;; Oops, no prefix, zero prefix data:
- (allout-prefix-data (point)(point))
+ ;; Oops, no prefix, nullify it:
+ (nullify-allout-prefix-data)
;; ... and return 0:
0)))))
;;;_ > allout-current-depth ()
(condition-case nil
(save-excursion
(allout-back-to-current-heading)
- (buffer-substring (- allout-recent-prefix-end 1)
- allout-recent-prefix-end))
+ (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))
+ (args-out-of-range nil))
)
;;;_ > allout-get-prefix-bullet (prefix)
(defun allout-get-prefix-bullet (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 0)) (match-end 0))))
+ (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.
(cond ((and depth (<= depth 0) 0))
((or (not depth) (= depth (allout-depth)))
(let ((index 1))
- (while (allout-previous-sibling (allout-recent-depth) nil)
+ (while (allout-previous-sibling allout-recent-depth nil)
(setq index (1+ index)))
index))
- ((< depth (allout-recent-depth))
+ ((< depth allout-recent-depth)
(allout-ascend-to-depth depth)
(allout-sibling-index))
(0))))
(defun allout-beginning-of-current-line ()
"Like beginning of line, but to visible text."
- ;; XXX We would use `(move-beginning-of-line 1)', but it gets
- ;; stuck on some hidden newlines, eg at column 80, as of GNU Emacs 22.0.50.
- ;; Conversely, `beginning-of-line' can make no progress in other
- ;; situations. Both are necessary, in the order used below.
- (move-beginning-of-line 1)
- (beginning-of-line)
- (while (or (not (bolp)) (allout-hidden-p))
+ ;; 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)
- (if (or (allout-hidden-p) (not (bolp)))
- (forward-char -1))))
+ (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'.
- (end-of-line)
- (while (allout-hidden-p)
+ (let ((inhibit-field-text-motion t))
(end-of-line)
- (if (allout-hidden-p) (forward-char 1))))
+ (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) before this one.
+ "Move to the heading for the topic \(possibly invisible) after this one.
-Returns the location of the heading, or nil if none found."
+Returns the location of the heading, or nil if none found.
- (if (and (bobp) (not (eobp)))
- (forward-char 1))
+We skip anomolous low-level topics, a la `allout-aberrant-container-p'."
+ (if (looking-at allout-regexp)
+ (forward-char 1))
- (if (re-search-forward allout-line-boundary-regexp nil 0)
- (allout-prefix-data ; Got valid location state - set vars:
- (goto-char (or (match-beginning 2)
- allout-recent-prefix-beginning))
- (or (match-end 2) allout-recent-prefix-end))))
+ (when (re-search-forward allout-line-boundary-regexp nil 0)
+ (allout-prefix-data)
+ (and (<= allout-recent-depth allout-doublecheck-at-and-shallower)
+ ;; register non-aberrant or disqualifying offspring as allout-recent-*
+ (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)) (allout-next-heading)))
+ (if (not (allout-goto-prefix-doublechecked)) (allout-next-heading)))
;;;_ > allout-previous-heading ()
-(defmacro allout-previous-heading ()
+(defsubst allout-previous-heading ()
"Move to the prior \(possibly invisible) heading line.
-Return the location of the beginning of the heading, or nil if not found."
-
- '(if (bobp)
- nil
- (allout-goto-prefix)
- (if
- ;; searches are unbounded and return nil if failed:
- (or (re-search-backward allout-line-boundary-regexp nil 0)
- (looking-at allout-bob-regexp))
- (progn ; Got valid location state - set vars:
- (allout-prefix-data
- (goto-char (or (match-beginning 2)
- allout-recent-prefix-beginning))
- (or (match-end 2) allout-recent-prefix-end))))))
+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)
+ (goto-char start-point)
+ ;; recalibrate allout-recent-*:
+ (allout-depth)))
+ (point)))))
;;;_ > allout-get-invisibility-overlay ()
(defun allout-get-invisibility-overlay ()
"Return the overlay at point that dictates allout invisibility."
got)
(while (and overlays (not got))
(if (equal (overlay-get (car overlays) 'invisible) 'allout)
- (setq got (car overlays))))
+ (setq got (car overlays))
+ (pop overlays)))
got))
;;;_ > allout-back-to-visible-text ()
(defun allout-back-to-visible-text ()
;;;_ " These routines either produce or assess charts, which are
;;; nested lists of the locations of topics within a subtree.
;;;
-;;; Use of charts enables efficient navigation of subtrees, by
-;;; requiring only a single regexp-search based traversal, to scope
-;;; out the subtopic locations. The chart then serves as the basis
-;;; for assessment or adjustment of the subtree, without redundant
-;;; traversal of the structure.
-
-;;;_ > allout-chart-subtree (&optional levels orig-depth prev-depth)
-(defun allout-chart-subtree (&optional levels orig-depth prev-depth)
+;;; 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. Subsequent optional args are not for public
-use.
+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.
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 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
; position to first offspring:
(progn (setq orig-depth (allout-depth))
(or prev-depth (setq prev-depth (1+ orig-depth)))
- (allout-next-heading)))
+ (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
(while (and (not (eobp))
; Still within original topic?
- (< orig-depth (setq curr-depth (allout-recent-depth)))
+ (< orig-depth (setq curr-depth allout-recent-depth))
(cond ((= prev-depth curr-depth)
;; Register this one and move on:
- (setq chart (cons (point) chart))
+ (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))
- (allout-next-heading))))
- (allout-next-heading)))
+ 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)
(setq chart
(cons (allout-chart-subtree (and levels
(1- levels))
- orig-depth
- curr-depth)
+ visible
+ orig-depth
+ curr-depth)
chart))
;; ... then continue with this one.
)
Effectively a top-level chart of siblings. See `allout-chart-subtree'
for an explanation of charts."
(save-excursion
- (if (allout-goto-prefix)
- (let ((chart (list (point))))
- (while (allout-next-sibling)
- (setq chart (cons (point) chart)))
- (if chart (setq chart (nreverse chart)))))))
+ (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)
(search-backward "\n" nil 1))
(forward-char 1)
(if (looking-at allout-regexp)
- (setq done (allout-prefix-data (match-beginning 0)
- (match-end 0)))
+ (setq done (allout-prefix-data))
(forward-char -1)))
(if (bobp)
(cond ((looking-at allout-regexp)
- (allout-prefix-data (match-beginning 0)(match-end 0)))
+ (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))
+ (if (not (allout-goto-prefix-doublechecked))
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))
+ (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 ()
(if (not (allout-current-depth))
nil
- (1- (match-end 0))))
+ (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.
(progn (while (allout-hidden-p)
(allout-beginning-of-current-line)
(if (not (looking-at allout-regexp))
- (re-search-backward (concat
- "^\\(" allout-regexp "\\)")
+ (re-search-backward allout-regexp
nil 'move)))
- (allout-prefix-data (match-beginning 1)
- (match-end 1)))))
+ (allout-prefix-data))))
(if (interactive-p)
(allout-end-of-prefix)
(point))))
Returns that character position."
(if (re-search-forward allout-line-boundary-regexp nil 'move)
- (prog1 (goto-char (match-beginning 0))
- (allout-prefix-data (match-beginning 2)(match-end 2)))))
+ (goto-char (1- (allout-prefix-data)))))
;;;_ > 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.
(interactive "P")
(if current
(allout-back-to-current-heading)
- (allout-goto-prefix))
- (let ((level (allout-recent-depth)))
+ (allout-goto-prefix-doublechecked))
+ (let ((level allout-recent-depth))
(allout-next-heading)
(while (and (not (eobp))
- (> (allout-recent-depth) level))
+ (> allout-recent-depth level))
(allout-next-heading))
- (and (not (eobp)) (forward-char -1))
+ (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))))
(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))
(defun allout-ascend-to-depth (depth)
"Ascend to depth DEPTH, returning depth if successful, nil if not."
(if (and (> depth 0)(<= depth (allout-depth)))
- (let ((last-good (point)))
- (while (and (< depth (allout-depth))
- (setq last-good (point))
- (allout-beginning-of-level)
- (allout-previous-heading)))
- (if (= (allout-recent-depth) depth)
- (progn (goto-char allout-recent-prefix-beginning)
- depth)
- (goto-char last-good)
- nil))
- (if (interactive-p) (allout-end-of-prefix))))
+ (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."
(start-depth (allout-depth)))
(while
(and (> (allout-depth) 0)
- (not (= depth (allout-recent-depth))) ; ... not there yet
+ (not (= depth allout-recent-depth)) ; ... not there yet
(allout-next-heading) ; ... go further
- (< start-depth (allout-recent-depth)))) ; ... still in topic
+ (< start-depth allout-recent-depth))) ; ... still in topic
(if (and (> (allout-depth) 0)
- (= (allout-recent-depth) depth))
+ (= allout-recent-depth depth))
depth
(goto-char start-point)
nil))
)
-;;;_ > allout-up-current-level (arg &optional dont-complain)
-(defun allout-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."
+;;;_ > allout-up-current-level (arg)
+(defun allout-up-current-level (arg)
+ "Move out ARG levels from current visible topic."
(interactive "p")
(allout-back-to-current-heading)
- (let ((present-level (allout-recent-depth))
- (last-good (point))
- failed)
- ;; Loop for iterating arg:
- (while (and (> (allout-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 (< (allout-recent-depth) present-level))
- (or (allout-previous-visible-heading 1)
- (not (setq failed present-level)))))
- (setq present-level (allout-current-depth))
- (setq arg (- arg 1)))
- (if (or failed
- (> arg 0))
- (progn (goto-char last-good)
- (if (interactive-p) (allout-end-of-prefix))
- (if (not dont-complain)
- (error "Can't ascend past outermost level")
- (if (interactive-p) (allout-end-of-prefix))
- nil))
- (if (interactive-p) (allout-end-of-prefix))
- allout-recent-prefix-beginning)))
+ (if (not (allout-ascend))
+ (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)
Go backward if optional arg BACKWARD is non-nil.
-Return depth if successful, nil otherwise."
+Return the start point of the new topic if successful, nil otherwise."
- (if (and backward (bobp))
+ (if (if backward (bobp) (eobp))
nil
- (let ((start-depth (or depth (allout-depth)))
+ (let ((target-depth (or depth (allout-depth)))
(start-point (point))
+ (count 0)
+ leaping
last-depth)
- (while (and (not (if backward (bobp) (eobp)))
- (if backward (allout-previous-heading)
- (allout-next-heading))
- (> (setq last-depth (allout-recent-depth)) start-depth)))
- (if (and (not (eobp))
- (and (> (or last-depth (allout-depth)) 0)
- (= (allout-recent-depth) start-depth)))
- allout-recent-prefix-beginning
- (goto-char start-point)
- (if depth (allout-depth) start-depth)
- nil))))
+ (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.
(let ((depth (allout-depth)))
(while (allout-previous-sibling depth nil))
- (prog1 (allout-recent-depth)
+ (prog1 allout-recent-depth
(if (interactive-p) (allout-end-of-prefix)))))
;;;_ > allout-next-visible-heading (arg)
(defun allout-next-visible-heading (arg)
Move to buffer limit in indicated direction if headings are exhausted."
(interactive "p")
- (let* ((backward (if (< arg 0) (setq arg (* -1 arg))))
+ (let* ((inhibit-field-text-motion t)
+ (backward (if (< arg 0) (setq arg (* -1 arg))))
(step (if backward -1 1))
prev got)
- (while (> arg 0) ; limit condition
- (while (and (not (if backward (bobp)(eobp))) ; boundary condition
- ;; Move, skipping over all those concealed lines:
- (prog1 (condition-case nil (or (line-move step) t)
- (error nil))
- (allout-beginning-of-current-line))
- (not (setq got (looking-at allout-regexp)))))
+ (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-prefix-data (match-beginning 0) (match-end 0))
- (allout-end-of-prefix))
+ (allout-end-of-prefix))
(prev ; Last move wasn't, but prev was:
- (allout-prefix-data (match-beginning 0) (match-end 0)))
+ (goto-char prev)
+ (allout-end-of-prefix))
((not backward) (end-of-line) nil))))
;;;_ > allout-previous-visible-heading (arg)
(defun allout-previous-visible-heading (arg)
A heading line is one that starts with a `*' (or that `allout-regexp'
matches)."
(interactive "p")
- (allout-next-visible-heading (- arg)))
+ (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.
(interactive "p")
(let ((start-depth (allout-current-depth))
(start-arg arg)
- (backward (> 0 arg))
- last-depth
- (last-good (point))
- at-boundary)
+ (backward (> 0 arg)))
(if (= 0 start-depth)
(error "No siblings, not in a topic..."))
(if backward (setq arg (* -1 arg)))
- (while (not (or (zerop arg)
- at-boundary))
- (while (and (not (if backward (bobp) (eobp)))
- (if backward (allout-previous-visible-heading 1)
- (allout-next-visible-heading 1))
- (> (setq last-depth (allout-recent-depth)) start-depth)))
- (if (and last-depth (= last-depth start-depth)
- (not (if backward (bobp) (eobp))))
- (setq last-good (point)
- arg (1- arg))
- (setq at-boundary t)))
- (if (and (not (eobp))
- (= arg 0)
- (and (> (or last-depth (allout-depth)) 0)
- (= (allout-recent-depth) start-depth)))
- allout-recent-prefix-beginning
- (goto-char last-good)
- (if (not (interactive-p))
- nil
- (allout-end-of-prefix)
- (error "Hit %s level %d topic, traversed %d of %d requested"
- (if backward "first" "last")
- (allout-recent-depth)
- (- (abs start-arg) arg)
- (abs start-arg))))))
+ (allout-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'."
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.
allout-after-save-decrypt)
(allout-after-saves-handler))
- ;; Implement -post-goto-bullet, if set:
+ ;; Implement allout-post-goto-bullet, if set:
(if (and allout-post-goto-bullet
(allout-current-bullet-pos))
(progn (goto-char (allout-current-bullet-pos))
;;;_ > allout-pre-command-business ()
(defun allout-pre-command-business ()
"Outline `pre-command-hook' function for outline buffers.
-Implements special behavior when cursor is on bullet character.
+
+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
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
+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
(if (not (allout-mode-p))
nil
- ;; Hot-spot navigation provisions:
+ ;; 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)))
- (let* ((this-key-num (cond
- ((numberp last-command-char)
- last-command-char)
- ;; Only xemacs has characterp.
- ((and (fboundp 'characterp)
- (apply 'characterp
- (list last-command-char)))
- (apply 'char-to-int (list last-command-char)))
- (t 0)))
- mapped-binding)
- (if (zerop this-key-num)
- nil
- ; Map upper-register literals
- ; to lower register:
- (if (<= 96 this-key-num)
- (setq this-key-num (- this-key-num 32)))
- ; Check if we have a literal:
- (if (and (<= 64 this-key-num)
- (>= 96 this-key-num))
- (setq mapped-binding
- (lookup-key 'allout-mode-map
- (concat allout-command-prefix
- (char-to-string (- this-key-num
- 64))))))
- (if mapped-binding
- (setq allout-post-goto-bullet t
- this-command mapped-binding)))))))
+ (allout-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'.
(setq choice (solicit-char-in-string
(format "Select bullet: %s ('%s' default): "
sans-escapes
- default-bullet)
+ (substring-no-properties default-bullet))
sans-escapes
t)))
(message "")
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
from there."
(allout-beginning-of-current-line)
- (let* ((depth (+ (allout-current-depth) relative-depth))
+ (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
(allout-ascend-to-depth depth))
((>= relative-depth 1) nil)
(t (allout-back-to-current-heading)))
- (setq ref-depth (allout-recent-depth))
+ (setq ref-depth allout-recent-depth)
(setq ref-bullet
(if (> allout-recent-prefix-end 1)
(allout-recent-bullet)
allout-numbered-bullet))))
(point)))
dbl-space
- doing-beginning)
+ doing-beginning
+ start end)
(if (not opening-on-blank)
; Positioning and vertical
(setq dbl-space t))
(if (save-excursion
(allout-next-heading)
- (when (> (allout-recent-depth) ref-depth)
+ (when (> allout-recent-depth ref-depth)
;; This is an offspring.
(forward-line -1)
(looking-at "^\\s-*$")))
(if (and dbl-space (not (> relative-depth 0)))
(newline 1))
(if (and (not (eobp))
- (not (bolp)))
+ (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)
(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)
Maintains outline hanging topic indentation if
`allout-use-hanging-indents' is set."
- (let ((fill-prefix (if allout-use-hanging-indents
- ;; Check for topic header indentation:
- (save-excursion
- (beginning-of-line)
- (if (looking-at allout-regexp)
- ;; ... construct indentation to account for
- ;; length of topic prefix:
- (make-string (progn (allout-end-of-prefix)
- (current-column))
- ?\ )))))
- (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))))
+
+ (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.
(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
+ 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)
+ (allout-goto-prefix-doublechecked)
(allout-next-visible-heading -1))))
(message "Done.")
(cond (on-bullet (goto-char (allout-current-bullet-pos)))
(new-depth (or new-depth current-depth))
(mb allout-recent-prefix-beginning)
(me allout-recent-prefix-end)
- (current-bullet (buffer-substring (- me 1) me))
+ (current-bullet (buffer-substring-no-properties (- me 1) me))
(new-prefix (allout-make-topic-prefix current-bullet
nil
new-depth
) ; let* ((current-depth (allout-depth))...)
) ; defun
;;;_ > allout-rebullet-topic (arg)
-(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)))
;; 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)
+ (if (<= (+ allout-recent-depth arg) 0)
(error "Attempt to shift topic below level 1"))
- (allout-rebullet-topic-grunt arg)
+ (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 ...)
+;;;_ > allout-rebullet-topic-grunt (&optional relative-depth ...)
(defun allout-rebullet-topic-grunt (&optional relative-depth
starting-depth
starting-point
index
- do-successors)
+ do-successors
+ sans-offspring)
"Like `allout-rebullet-topic', but on nearest containing topic
\(visible or not).
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."
+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))
(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))))
+ (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")) ;;; ====>
+ (error "Attempt to shift topic out beyond level 1"))
(cond ((= starting-depth new-depth)
- ;; We're at depth to work on this one:
- (allout-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)
- (allout-next-heading)
- (while (and (not (eobp))
- (< starting-depth (allout-recent-depth)))
- (setq index (1+ index))
- (allout-rebullet-topic-grunt relative-depth ;;; relative-depth
- (1+ starting-depth);;;starting-depth
- starting-point ;;; starting-point
- index))) ;;; index
+ ;; 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 ;;; relative-depth
- new-depth ;;; starting-depth
- starting-point ;;; starting-point
- index))) ;;; index
+ (allout-rebullet-topic-grunt relative-depth
+ new-depth
+ starting-point
+ index
+ sans-offspring)))
(if on-starting-call
(progn
;; 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
+ (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,
was-eobp)
(while (and (not (eobp))
(allout-depth)
- (>= (allout-recent-depth) 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-recent-depth ascender))
(allout-next-heading))
; Prime ascender for ascension:
- (setq ascender (1- (allout-recent-depth)))
- (if (>= (allout-recent-depth) depth)
+ (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-recent-depth)
;;;_ > allout-number-siblings (&optional denumber)
(defun allout-number-siblings (&optional denumber)
"Assign numbered topic prefix to this topic and its siblings.
(save-excursion
(allout-back-to-current-heading)
(allout-beginning-of-level)
- (let ((depth (allout-recent-depth))
+ (let ((depth allout-recent-depth)
(index (if (not denumber) 1))
(use-bullet (equal '(16) denumber))
(more t))
(setq more (allout-next-sibling depth nil))))))
;;;_ > allout-shift-in (arg)
(defun allout-shift-in (arg)
- "Increase depth of current heading and any topics collapsed within it.
+ "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."
-We disallow shifts that would result in the topic having a depth more than
-one level greater than the immediately previous topic, to avoid containment
-discontinuity. The first topic in the file can be adjusted to any positive
-depth, however."
(interactive "p")
- (if (> arg 0)
- (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)
- (if (< (point) start-point)
- (allout-recent-depth)
- 0))))
- (if (and (> predecessor-depth 0)
- (> (+ current-depth arg)
- (1+ predecessor-depth)))
- (error (concat "Disallowed shift deeper than"
- " containing topic's children.")))))))
- (allout-rebullet-topic arg))
+ (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.
-We disallow shifts that would result in the topic having a depth more than
-one level greater than the immediately previous topic, to avoid containment
-discontinuity. The first topic in the file can be adjusted to any positive
-depth, however."
+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)))
- (allout-rebullet-topic (* arg -1)))
+ (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 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))
- (collapsed (allout-current-topic-collapsed-p)))
+ (depth (allout-depth)))
- (if collapsed
- (put-text-property beg (1+ beg) 'allout-was-collapsed t)
- (remove-text-properties beg (1+ beg) '(allout-was-collapsed t)))
+ (allout-annotate-hidden beg end)
(if (and (not beg-hidden) (not end-hidden))
(allout-unprotected (kill-line arg))
(kill-line arg))
- ; Provide some feedback:
- (sit-for 0)
(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))))))
+ (allout-renumber-to-depth depth)))
+ (run-hook-with-args 'allout-structure-deleted-hook depth (point)))))
;;;_ > allout-kill-topic ()
(defun allout-kill-topic ()
"Kill topic together with subtopics.
- would not be added to whitespace already separating the topic from the
previous one.
-Completely collapsed topics are marked as such, for re-collapse
-when yank with allout-yank into an outline as a heading."
-
- ;; Some finagling is done to make complex topic kills appear faster
- ;; than they actually are. A redisplay is performed immediately
- ;; after the region is deleted, though the renumbering process
- ;; has yet to be performed. This means that there may appear to be
- ;; a lag *after* a kill has been performed.
+Topic exposure is marked with text-properties, to be used by
+allout-yank-processing for exposure recovery."
(interactive)
- (let* ((collapsed (allout-current-topic-collapsed-p))
+ (let* ((inhibit-field-text-motion t)
(beg (prog1 (allout-back-to-current-heading) (beginning-of-line)))
- (depth (allout-recent-depth)))
+ (depth allout-recent-depth))
(allout-end-of-current-subtree)
(if (and (/= (current-column) 0) (not (eobp)))
(forward-char 1))
(if (and (looking-at "\n")
(or (save-excursion
(or (not (allout-next-heading))
- (= depth (allout-recent-depth))))
+ (= depth allout-recent-depth)))
(and (> (- beg (point-min)) 3)
(string= (buffer-substring (- beg 2) beg) "\n\n"))))
(forward-char 1)))
- (if collapsed
- (put-text-property beg (1+ beg) 'allout-was-collapsed t)
- (remove-text-properties beg (1+ beg) '(allout-was-collapsed t)))
+ (allout-annotate-hidden beg (point))
+
(allout-unprotected (kill-region beg (point)))
- (sit-for 0)
(save-excursion
- (allout-renumber-to-depth depth))))
+ (allout-renumber-to-depth depth))
+ (run-hook-with-args 'allout-structure-deleted-hook depth (point))))
+;;;_ > 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)))
+ (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
+ (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)
; region around subject:
(if (< (allout-mark-marker t) (point))
(exchange-point-and-mark))
- (let* ((subj-beg (point))
- (into-bol (bolp))
- (subj-end (allout-mark-marker t))
- (was-collapsed (get-text-property subj-beg 'allout-was-collapsed))
- ;; 'resituate' if yanking an entire topic into topic header:
- (resituate (and (allout-e-o-prefix-p)
- (looking-at (concat "\\(" allout-regexp "\\)"))
- (allout-prefix-data (match-beginning 1)
- (match-end 1))))
- ;; `rectify-numbering' if resituating (where several topics may
- ;; be resituating) or yanking a topic into a topic slot (bol):
- (rectify-numbering (or resituate
- (and into-bol (looking-at allout-regexp)))))
- (if resituate
+ (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 (match-beginning 0)
- (match-end 0)))
- (allout-recent-depth))))
- (more t))
- (setq rectify-numbering allout-numbered-bullet)
- (if adjust-to-depth
+ (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
- (message "... yanking") (sit-for 0)
- (save-restriction
- (narrow-to-region subj-beg subj-end)
+ (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)))
+ (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)
+ (while more
+ (allout-back-to-current-heading)
; go as high as we can in each bunch:
- (while (allout-ascend-to-depth (1- (allout-depth))))
- (save-excursion
- (allout-rebullet-topic-grunt (- adjust-to-depth
+ (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))))))
- (message "")
- ;; Preserve new bullet if it's a distinctive one, otherwise
- ;; use old one:
- (if (string-match (regexp-quote prefix-bullet)
- allout-distinctive-bullets-string)
+ (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))
+ (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)))
+ (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
+ (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)
+ (message "... reconciling numbers")
; ... and renumber, in case necessary:
- (goto-char subj-beg)
- (if (allout-goto-prefix)
- (allout-rebullet-heading nil ;;; solicit
+ (goto-char subj-beg)
+ (if (allout-goto-prefix-doublechecked)
+ (allout-rebullet-heading nil ;;; solicit
(allout-depth) ;;; depth
- nil ;;; number-control
- nil ;;; index
+ nil ;;; number-control
+ nil ;;; index
t))
- (message ""))))
- (when (and (or into-bol resituate) was-collapsed)
- (remove-text-properties subj-beg (1+ subj-beg) '(allout-was-collapsed))
- (allout-hide-current-subtree))
- (if (not resituate)
- (exchange-point-and-mark))))
+ (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.
(interactive "*P")
(setq this-command 'yank)
- (yank arg)
+ (allout-unprotected
+ (yank arg))
(if (allout-mode-p)
- (allout-yank-processing))
-)
+ (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.
(if (not (string= (allout-current-bullet) allout-file-xref-bullet))
(error "Current heading lacks cross-reference bullet `%s'"
allout-file-xref-bullet)
- (let (file-name)
+ (let ((inhibit-field-text-motion t)
+ file-name)
(save-excursion
(let* ((text-start allout-recent-prefix-end)
(heading-end (progn (end-of-line) (point))))
(error "%s not found and can't be created" file-name)))
(condition-case failure
(find-file-other-window file-name)
- ('error failure))
+ (error failure))
(error "%s not found" file-name))
)
)
;;;_ - Fundamental
;;;_ > allout-flag-region (from to flag)
(defun allout-flag-region (from to flag)
- "Conceal text from FROM to TO if FLAG is non-nil, else reveal it.
+ "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.\)"
-Text is shown if flag is nil and hidden otherwise."
;; We use outline invisibility spec.
- (remove-overlays from to 'category 'allout-overlay-category)
+ (remove-overlays from to 'category 'allout-exposure-category)
(when flag
(let ((o (make-overlay from to)))
- (overlay-put o 'category 'allout-overlay-category)
+ (overlay-put o 'category 'allout-exposure-category)
(when (featurep 'xemacs)
- (let ((props (symbol-plist 'allout-overlay-category)))
+ (let ((props (symbol-plist 'allout-exposure-category)))
(while props
(overlay-put o (pop props) (pop props)))))))
- (run-hooks 'allout-view-change-hook))
+ (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)
- (end-of-line)
+ (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
flag)))
;;;_ - Topic-specific
-;;;_ > allout-show-entry (&optional inclusive)
-(defun allout-show-entry (&optional inclusive)
- "Like `allout-show-current-entry', reveals entries nested in hidden topics.
+;;;_ > 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
(interactive)
(save-excursion
(let (beg end)
- (allout-goto-prefix)
+ (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)
(save-excursion
(allout-beginning-of-current-line)
(save-restriction
- (let* ((chart (allout-chart-subtree (or level 1)))
- (to-reveal (allout-chart-to-reveal chart (or level 1))))
+ (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,
Useful for coherently exposing to a random point in a hidden region."
(interactive)
(save-excursion
- (let ((orig-pt (point))
- (orig-pref (allout-goto-prefix))
+ (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)
- ;; XXX We would use `(move-beginning-of-line 1)', but it gets
- ;; stuck on hidden newlines at column 80, as of GNU Emacs 22.0.50.
- (beginning-of-line)
+ (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
(beep)
(message "%s: %s"
"allout-show-to-offshoot: "
- "Aberrant nesting encountered.")))
- (allout-show-children)
- (goto-char orig-pref))
+ "Aberrant nesting encountered."))
+ (allout-show-children)
+ (goto-char orig-pref)))
(goto-char orig-pt)))
(if (allout-hidden-p)
(allout-show-entry)))
(interactive)
(allout-back-to-current-heading)
(save-excursion
- (end-of-line)
+ (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")
(defun allout-current-topic-collapsed-p (&optional include-single-liners)
"True if the currently visible containing topic is already collapsed.
-If optional INCLUDE-SINGLE-LINERS is true, then include single-line
-topics \(which intrinsically can be considered both collapsed and
-not\), as collapsed. Otherwise they are considered uncollapsed."
+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
- (= (progn (allout-back-to-current-heading)
- (move-end-of-line 1)
- (point))
- (allout-end-of-current-subtree))
- (or include-single-liners
- (progn (backward-char 1) (allout-hidden-p))))))
+ (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.
(current-exposed (not (allout-current-topic-collapsed-p t))))
(cond (current-exposed (allout-flag-current-subtree t))
(just-close nil)
- ((allout-up-current-level 1 t) (allout-hide-current-subtree))
+ ((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)))
(defun allout-show-current-branches ()
"Show all subheadings of this heading, but not their bodies."
(interactive)
- (beginning-of-line)
+ (let ((inhibit-field-text-motion t))
+ (beginning-of-line))
(allout-show-children t))
;;;_ > allout-hide-current-leaves ()
(defun allout-hide-current-leaves ()
(save-restriction
(narrow-to-region start end)
(goto-char (point-min))
- (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)))))))
+ (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)
Optional FOLLOWERS arguments dictate exposure for succeeding siblings."
(interactive "xExposure spec: ")
- (let ((depth (allout-current-depth))
+ (let ((inhibit-field-text-motion t)
+ (depth (allout-current-depth))
max-pos)
(cond ((null spec) nil)
((symbolp spec)
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)
+ '(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))))
(interactive "r")
(save-excursion
(let*
- ;; state vars:
- (strings prefix result depth new-depth out gone-out bullet beg
+ ((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) start)
+ (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,
+ (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 new-depth allout-recent-depth)
(setq gone-out out
out (< new-depth depth))
(beginning-of-line)
Adjust line contents so it is unaltered \(from the original line)
across LaTeX processing, within the context of a `verbatim'
environment. Leaves point at the end of the line."
- (beginning-of-line)
- (let ((beg (point))
- (end (progn (end-of-line)(point))))
- (goto-char beg)
- (while (re-search-forward "\\\\"
- ;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#"
- end ; bounded by end-of-line
- 1) ; no matches, move to end & return nil
- (goto-char (match-beginning 0))
- (insert "\\")
- (setq end (1+ end))
- (goto-char (1+ (match-end 0))))))
+ (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."
(allout-latex-verb-quote (if allout-title
(condition-case nil
(eval allout-title)
- ('error "<unnamed buffer>"))
+ (error "<unnamed buffer>"))
"Unnamed Outline"))
"}\n"
"\\end{center}\n\n"))
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-1 topics, with prefix consisting solely of an `*' asterisk, cannot be
+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.
(save-excursion
(allout-end-of-prefix t)
- (if (= (allout-recent-depth) 1)
+ (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)
(delete-char 1))
;; Add the is-encrypted bullet qualifier:
(goto-char after-bullet-pos)
- (insert "*"))
- )
- )
- )
- )
- )
+ (insert "*"))))
+ (run-hook-with-args 'allout-exposure-changed-hook
+ bullet-pos subtree-end nil))))
;;;_ > 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 verifying
- passphrase)
+ fetch-pass &optional retried rejected
+ verifying passphrase)
"Encrypt or decrypt message TEXT.
If DECRYPT is true (default false), then decrypt instead of encrypt.
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)
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))
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:
(if verifying
(throw 'encryption-failed nil)
(pgg-remove-passphrase-from-cache target-cache-id t)
- (error "Symmetric-cipher encryption failed - %s"
+ (error "Symmetric-cipher %scryption failed - %s"
+ (if decrypt "de" "en")
"try again with different passphrase."))))
;; encrypt 'keypair:
(if status
(pgg-situate-output (point-min) (point-max))
(error (pgg-remove-passphrase-from-cache target-cache-id t)
- (error "decryption failed"))))
- )
+ (error "decryption failed")))))
(setq result-text
- (buffer-substring 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 allout-buffer decrypt nil
- (if retried (1+ retried) 1)
- 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 unusable"
- " non-armored text - 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)
- )
+ (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)
+ )
)
)
)
(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)
;; Duplicate our handle on the passphrase so it's not clobbered by
;; deactivate-passwd memory clearing:
- (setq got-pass (format "%s" got-pass))
+ (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 'verifying
- got-pass)
+ for-key nil 0 0 'verifying
+ (copy-sequence got-pass))
(setq confirmation (format "%s" got-pass))))
(if (and (not confirmation)
;; recurse to this routine:
(pgg-read-passphrase prompt-sans-hint cache-id t))
(pgg-remove-passphrase-from-cache cache-id t)
- (error "Confirmation failed.")))
- ;; reduce opportunity for memory cherry-picking by zeroing duplicate:
- (dotimes (i (length got-pass))
- (aset got-pass i 0))
- )
- )
- )
- )
- )
+ (error "Confirmation failed."))))))))
;;;_ > allout-encrypted-topic-p ()
(defun allout-encrypted-topic-p ()
"True if the current topic is encryptable and encrypted."
(dotimes (i (length spew))
(aset spew i (1+ (random 254))))
(allout-encrypt-string spew nil (current-buffer) 'symmetric
- nil nil 0 passphrase))
+ nil nil 0 0 passphrase))
)
;;;_ > allout-update-passphrase-mnemonic-aids (for-key passphrase
;;; outline-buffer)
allout-passphrase-verifier-string
(allout-encrypt-string (allout-get-encryption-passphrase-verifier)
'decrypt allout-buffer 'symmetric
- key nil 0 'verifying passphrase)
+ key nil 0 0 'verifying passphrase)
t)))
;;;_ > allout-next-topic-pending-encryption (&optional except-mark)
(defun allout-next-topic-pending-encryption (&optional except-mark)
)
;;;_ #9 miscellaneous
-;;;_ > allout-mark-topic ()
-(defun allout-mark-topic ()
- "Put the region around topic currently containing point."
- (interactive)
- (beginning-of-line)
- (allout-goto-prefix)
- (push-mark (point))
- (allout-end-of-current-subtree)
- (exchange-point-and-mark))
-;;;_ > outlineify-sticky ()
+;;;_ : Mode:
+;;;_ > outlineify-sticky ()
;; outlinify-sticky is correct spelling; provide this alias for sticklers:
;;;###autoload
(defalias 'outlinify-sticky 'outlineify-sticky)
"`allout-mode' docstring: `^Hm'."))
(allout-adjust-file-variable
"allout-layout" (or allout-layout '(-1 : 0))))))
-;;;_ > allout-file-vars-section-data ()
+;;;_ > allout-file-vars-section-data ()
(defun allout-file-vars-section-data ()
"Return data identifying the file-vars section, or nil if none.
)
)
)
-;;;_ > allout-adjust-file-variable (varname value)
+;;;_ > 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.
allout-enable-file-variable-adjustment))
nil
(save-excursion
- (let ((section-data (allout-file-vars-section-data))
+ (let ((inhibit-field-text-motion t)
+ (section-data (allout-file-vars-section-data))
beg prefix suffix)
(if section-data
(setq beg (car section-data)
)
)
)
-;;;_ > solicit-char-in-string (prompt string &optional do-defaulting)
+;;;_ > 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.
;; got something out of loop - return it:
got)
)
-;;;_ > regexp-sans-escapes (string)
+;;;_ : Strings:
+;;;_ > regexp-sans-escapes (string)
(defun regexp-sans-escapes (regexp &optional successive-backslashes)
"Return a copy of REGEXP with all character escapes stripped out.
(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)
+;;;_ > count-trailing-whitespace-region (beg end)
(defun count-trailing-whitespace-region (beg end)
"Return number of trailing whitespace chars between BEG and END.
(goto-char beg)
(let ((count 0))
(while (re-search-forward "[ ][ ]*$" end t)
- (goto-char (1+ (match-beginning 0)))
+ (goto-char (1+ (match-beginning 2)))
(setq count (1+ count)))
count))))
-;;;_ > allout-mark-marker to accommodate divergent emacsen:
+;;;_ > 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) (flatten (cdr list))))
+ (t (append (flatten (car list)) (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.
(if (featurep 'xemacs)
(apply 'mark-marker force buffer)
(mark-marker)))
-;;;_ > subst-char-in-string if necessary
+;;;_ > 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.
(if (eq (aref newstr i) fromchar)
(aset newstr i tochar)))
newstr)))
-;;;_ > wholenump if necessary
+;;;_ > wholenump if necessary
(if (not (fboundp 'wholenump))
(defalias 'wholenump 'natnump))
-;;;_ > remove-overlays if necessary
+;;;_ > 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.
(move-overlay o end (overlay-end o))
(delete-overlay o)))))))
)
-;;;_ > copy-overlay if necessary - xemacs ~ 21.4
+;;;_ > copy-overlay if necessary - xemacs ~ 21.4
(if (not (fboundp 'copy-overlay))
(defun copy-overlay (o)
"Return a copy of overlay O."
(while props
(overlay-put o1 (pop props) (pop props)))
o1)))
-;;;_ > add-to-invisibility-spec if necessary - xemacs ~ 21.4
+;;;_ > 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'.
(setq buffer-invisibility-spec (list t)))
(setq buffer-invisibility-spec
(cons element buffer-invisibility-spec))))
-;;;_ > remove-from-invisibility-spec if necessary - xemacs ~ 21.4
+;;;_ > 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
+;;;_ > 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.
(if (/= arg 1)
(condition-case nil (line-move (1- arg)) (error nil)))
- (let ((orig (point)))
- ;; 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)
- (if (/= orig (point))
- (goto-char orig))))
+ ;; 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
+;;;_ > 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.
To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
(interactive "p")
(or arg (setq arg 1))
- (let ((orig (point))
- done)
+ (let (done)
(while (not done)
(let ((newpos
(save-excursion
(error nil))
(not (bobp))
(progn
- (while (and (not (bobp)) (line-move-invisible-p (1- (point))))
- (goto-char (previous-char-property-change (point))))
+ (while (and (not (bobp))
+ (line-move-invisible-p (1- (point))))
+ (goto-char
+ (previous-char-property-change (point))))
(backward-char 1)))
(point)))))
(goto-char newpos)
;; and now we're not really at eol,
;; keep going.
(setq arg 1)
- (setq done t)))))
- (if (/= orig (point))
- (goto-char orig))))
+ (setq done t)))))))
)
-;;;_ > line-move-invisible-p if necessary
+;;;_ > 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."
(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-repeat 'forward)
(isearch-mode t)))
-;;;_ #11 Provide
+;;;_ #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.
HCoop / bpt / emacs.git / blobdiff