--- 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."