* allout bug fixes
@ 2006-08-22 23:24 Ken Manheimer
0 siblings, 0 replies; only message in thread
From: Ken Manheimer @ 2006-08-22 23:24 UTC (permalink / raw)
[-- Attachment #1: Type: text/plain, Size: 3099 bytes --]
all bug fixes.
the ChangeLog entry is below and the patch is attached.
2006-08-22 Ken Manheimer <ken.manheimer@gmail.com>
* allout.el (allout-regexp, allout-line-boundary-regexp)
(allout-bob-regexp): Correct grouping and boundaries to fix
backwards traversal.
(allout-depth-specific-regexp, allout-depth-one-regexp): New
versions that exploit \\{M\\} regexp syntax, to avoid O(N^2)
behavior in allout-ascend.
(allout-hotspot-key-handler): Correctly handle multiple-key
strokes.
(allout-mode-leaders): Clarify that mode-specific comment-start
will be used
(set-allout-regexp): Correctly regexp-quote allout regexps to
properly accept alternative header-leads and primary bullets with
regexp-specific characters (eg, C "/*", mathematica "(*").
Include new regular expressions among those configured.
(allout-mode): Make allout-old-style-prefixes (ie, enabling use with
outline.el outlines) functional again. Change the primary bullet
along with the header-lead - level 1 new-style bullets now work.
(allout-chart-subtree): Use start rather than end of prefix in
charts.
(allout-beginning-of-current-entry): Position correctly.
(allout-ascend): Use new allout-depth-specific-regexp and
allout-depth-one-regexp for linear instead of O(N^2) or worse
behavior.
(allout-ascend-to-depth, allout-up-current-level): Depend on
allout-ascend, rather than reimplementing with a separate
algorithm.
(allout-next-sibling): Resort to routine that uses allout-ascend,
to avoid arbitrarily large numbers of intermediate traversals
according to the number of hidden items.
(allout-next-sibling-leap): Specialized version of
allout-next-sibling that uses allout-ascend cleverly, to depend on
a regexp search to leap large numbers of contained topics, rather
than arbitrarily many one-by-one traversals.
(allout-previous-visible-heading): Position consistently when
interactive.
(allout-forward-current-level): Base on allout-previous-sibling
rather than (differently) reimplmenting the algorithm.
(allout-solicit-alternate-bullet): Present default choice stripped
of text properties.
(allout-rebullet-heading): Use bullet stripped of text properties.
(allout-shift-in): With universal-argument, make topic a peer of
it's former offspring. Simplify the code by separating out
allout-shift-out functionality.
(allout-shift-out): With universal-argument, make offspring peers
of their former container, and its siblings. Implement the
functionality here, rather than inappropriately muddling the
implementation of allout-shift-in.
(allout-rebullet-topic): Respect additional argument for new
parent-child separation function.
(allout-yank-processing): Use allout-ascend directly.
(allout-show-to-offshoot): Remove obsolete and incorrect comment.
(allout-hide-current-subtree): Use allout-ascend directly.
(allout-toggle-subtree-encryption): Run allout-exposure-change-hook.
(allout-encrypt-string): Strip text properties.
Rearranged order and outline-headings for some of the
miscellaneous functions.
--
ken
ken.manheimer@gmail.com
http://myriadicity.net
[-- Attachment #2: allout-patch.txt --]
[-- Type: text/plain, Size: 46835 bytes --]
--- allout.el 13 Aug 2006 10:45:15 -0400 1.81
+++ allout.el 22 Aug 2006 19:08:39 -0400
@@ -847,6 +847,28 @@
(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.
@@ -961,7 +983,9 @@
"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:
@@ -996,14 +1020,69 @@
;; 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:
+
+ ;; Produce the new allout-regexps:
(setq allout-regexp (concat "\\("
(regexp-quote allout-header-prefix)
- "[ \t]*["
- allout-bullets-string
- "]\\)\\|"
- (regexp-quote allout-primary-bullet)
- "+\\|\^l"))
+ "[ \t]*"
+ ;; already regexp-quoted in a custom way:
+ (concat "[" allout-bullets-string "]")
+ (concat "\\|"
+ (regexp-quote allout-primary-bullet)
+ "+\\|\^l")
+ "\\)"))
+
+ (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 "]"))
+ "\\)"
+ ))
+
(setq allout-line-boundary-regexp
(concat "\\(\n\\)\\(" allout-regexp "\\)"))
(setq allout-bob-regexp
@@ -1813,7 +1892,7 @@
(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)
@@ -2065,9 +2144,9 @@
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.
@@ -2076,8 +2155,8 @@
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
@@ -2149,8 +2228,8 @@
(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))
)
@@ -2261,6 +2340,7 @@
(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)
@@ -2324,11 +2404,8 @@
;;;_ " 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.
+;;; 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)
@@ -2348,12 +2425,12 @@
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
@@ -2383,7 +2460,7 @@
(< 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)
@@ -2580,7 +2657,7 @@
(if (re-search-forward allout-line-boundary-regexp nil 'move)
(prog1 (goto-char (match-beginning 0))
- (allout-prefix-data (match-beginning 2)(match-end 2)))))
+ (allout-prefix-data (match-beginning 2)(match-end 2)))))
;;;_ > 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.
@@ -2629,6 +2706,9 @@
(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))
@@ -2676,24 +2756,31 @@
(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))))
-;;;_ > allout-ascend ()
-(defun allout-ascend ()
- "Ascend one level, returning t if successful, nil if not."
- (prog1
- (if (allout-beginning-of-level)
- (allout-previous-heading))
- (if (interactive-p) (allout-end-of-prefix))))
+ (let ((last-good (point))
+ 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 (&optional forward)
+(defun allout-ascend (&optional forward)
+ "Ascend one level to this topic's container, returning point or nil if none.
+
+If optional parameter FORWARD is non-nil, then move to the next
+topic of a lower depth. That topic may be more than one level
+lower, since subsequent topics do not contain prior ones."
+ (allout-goto-prefix)
+ (let* ((search-whitespace-regexp nil)
+ (target-depth (1- (allout-depth)))
+ (depth-biased (- target-depth 2))
+ (expression (if (<= target-depth 1)
+ allout-depth-one-regexp
+ (format allout-depth-specific-regexp
+ depth-biased depth-biased))))
+ (prog1
+ (re-search-backward expression nil t)
+ (if (interactive-p) (allout-end-of-prefix)))))
;;;_ > allout-descend-to-depth (depth)
(defun allout-descend-to-depth (depth)
"Descend to depth DEPTH within current topic.
@@ -2712,40 +2799,15 @@
(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)
@@ -2756,24 +2818,95 @@
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 (if backward
+ (re-search-backward expression nil t)
+ (forward-char 1)
+ (re-search-forward expression nil t))))
+ (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.
@@ -2845,7 +2978,8 @@
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.
@@ -2863,31 +2997,21 @@
(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'."
@@ -2977,34 +3101,43 @@
Returns the qualifying command, if any, else nil."
(interactive)
- (let* ((key-num (cond ((numberp last-command-char) last-command-char)
+ (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
+ assoced-binding
(on-bullet (eq (point) (allout-current-bullet-pos))))
(if (zerop key-num)
nil
- (if (and (<= 33 key-num)
- (setq mapped-binding
+ (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"
+ (if (and (<= 97 key-num) ; "a"
(>= 122 key-num)) ; "z"
(- key-num 96) key-num)))
- t)))
- ;; Qualified with the allout prefix - do hot-spot operation.
+ 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 (read-key-sequence-vector nil t))))
+ (lookup-key mapped-binding (vector (read-char)))))
(if mapped-binding
(setq this-command mapped-binding)))))
@@ -3036,7 +3169,7 @@
(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 "")
@@ -3507,16 +3640,21 @@
(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
@@ -3573,7 +3711,7 @@
(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
@@ -3627,11 +3765,17 @@
) ; 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)))
@@ -3644,7 +3788,7 @@
(allout-back-to-current-heading)
(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 ...)
@@ -3652,7 +3796,8 @@
starting-depth
starting-point
index
- do-successors)
+ do-successors
+ sans-offspring)
"Like `allout-rebullet-topic', but on nearest containing topic
\(visible or not).
@@ -3663,8 +3808,20 @@
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..)"
+
+ (if (and sans-offspring
+ relative-depth
+ (< relative-depth 0))
+ (error (concat "Attempt to shift topic outwards without offspring,"
+ " causing containment discontinuity.")))
(let* ((relative-depth (or relative-depth 0))
(new-depth (allout-depth))
@@ -3683,7 +3840,7 @@
(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:
@@ -3696,24 +3853,26 @@
;; 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
+ (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-recent-depth)))
+ (setq index (1+ index))
+ (allout-rebullet-topic-grunt relative-depth
+ (1+ starting-depth)
+ starting-point
+ index))))
((< 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
@@ -3794,55 +3953,81 @@
(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)
- ;; 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)
- (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.")))))))
- (let ((where (point))
- has-successor)
- (if (and (< arg 0)
- (allout-current-topic-collapsed-p)
- (save-excursion (allout-next-sibling)))
- (setq has-successor t))
- (allout-rebullet-topic arg)
- (when (< arg 0)
- (save-excursion
- (if (allout-ascend)
- (allout-show-children)))
- (if has-successor
- (allout-show-children)))
- (run-hook-with-args 'allout-structure-shifted-hook arg where)))
+ (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)
+ (if (< (point) start-point)
+ (allout-recent-depth)
+ 0))))
+ (if (and (> predecessor-depth 0)
+ (> (1+ current-depth)
+ (1+ predecessor-depth)))
+ (error (concat "Disallowed shift deeper than"
+ " containing topic's children."))))))
+ (let ((where (point)))
+ (allout-rebullet-topic 1 (and (> arg 1) 'sans-offspring))
+ (run-hook-with-args 'allout-structure-shifted-hook arg where))))
;;;_ > allout-shift-out (arg)
(defun allout-shift-out (arg)
"Decrease depth of current heading and any topics collapsed within it.
+This will make the item a sibling of its former container.
+
+With a negative argument, the item is shifted in using
+`allout-shift-in', instead.
-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 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")
- (allout-shift-in (* arg -1)))
+ (if (< arg 0)
+ (allout-shift-in (* arg -1))
+ ;; Get proper exposure in this area:
+ (save-excursion (if (allout-ascend)
+ (allout-show-children)))
+ ;; Show collapsed children if there's a successor which will become
+ ;; their sibling:
+ (if (and (allout-current-topic-collapsed-p)
+ (save-excursion (allout-next-sibling)))
+ (allout-show-children))
+ (let ((where (and (allout-depth) allout-recent-prefix-beginning)))
+ (save-excursion
+ (if (> arg 1)
+ ;; Shift the offspring but not the topic:
+ (let ((children-chart (allout-chart-subtree 1)))
+ (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)
@@ -4006,7 +4191,7 @@
(while more
(allout-back-to-current-heading)
; go as high as we can in each bunch:
- (while (allout-ascend-to-depth (1- (allout-depth))))
+ (while (allout-ascend))
(save-excursion
(allout-rebullet-topic-grunt (- adjust-to-depth
subj-depth))
@@ -4272,9 +4457,7 @@
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
@@ -4286,9 +4469,9 @@
(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)))
@@ -4368,7 +4551,7 @@
(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)
@@ -5297,6 +5480,7 @@
(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)
@@ -5362,12 +5546,9 @@
(delete-char 1))
;; Add the is-encrypted bullet qualifier:
(goto-char after-bullet-pos)
- (insert "*"))
- )
- )
- )
- )
- )
+ (insert "*"))))
+ (run-hook-with-args 'allout-exposure-change-hook
+ bullet-pos subtree-end nil))))
;;;_ > allout-encrypt-string (text decrypt allout-buffer key-type for-key
;;; fetch-pass &optional retried verifying
;;; passphrase)
@@ -5512,7 +5693,8 @@
(error "decryption failed")))))
(setq result-text
- (buffer-substring 1 (- (point-max) (if decrypt 0 1))))
+ (buffer-substring-no-properties
+ 1 (- (point-max) (if decrypt 0 1))))
)
;; validate result - non-empty
@@ -5924,17 +6106,8 @@
)
;;;_ #9 miscellaneous
-;;;_ > 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)
- (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)
@@ -5958,7 +6131,7 @@
"`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.
@@ -5986,7 +6159,7 @@
)
)
)
-;;;_ > 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.
@@ -6050,7 +6223,38 @@
)
)
)
-;;;_ > 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)
+ (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.
@@ -6083,7 +6287,8 @@
;; 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.
@@ -6106,7 +6311,7 @@
(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.
@@ -6120,26 +6325,14 @@
(goto-char (1+ (match-beginning 0)))
(setq count (1+ count)))
count))))
-;;;_ > 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)))
-;;;_ > 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)))
+;;;_ : Compatability:
+;;;_ > allout-mark-marker to accommodate divergent emacsen:
(defun allout-mark-marker (&optional force buffer)
"Accommodate the different signature for `mark-marker' across Emacsen.
@@ -6148,7 +6341,7 @@
(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.
@@ -6160,10 +6353,10 @@
(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.
@@ -6190,7 +6383,7 @@
(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."
@@ -6202,7 +6395,7 @@
(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'.
@@ -6212,14 +6405,14 @@
(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.
@@ -6243,7 +6436,7 @@
(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.
@@ -6283,7 +6476,7 @@
(setq arg 1)
(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."
[-- Attachment #3: Type: text/plain, Size: 142 bytes --]
_______________________________________________
Emacs-devel mailing list
Emacs-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/emacs-devel
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2006-08-22 23:24 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2006-08-22 23:24 allout bug fixes Ken Manheimer
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).