Mercurial > emacs
diff lisp/allout.el @ 73660:4a5c7b0a29cc
2006-11-03 Ken Manheimer <ken.manheimer@gmail.com>
* allout.el (allout-during-yank-processing): Cue for inhibiting
aberrance processing during yanks.
(allout-doublecheck-at-and-shallower): Reduce the limit to reduce
the amount of yanked topics that can be aberrant.
(allout-do-doublecheck): Encapsulate this multiply-used recipe in
a function, and supplement with inihibition of doublechecking
during yanks.
(allout-beginning-of-line, allout-next-heading)
(allout-previous-heading, allout-goto-prefix-doublechecked)
(allout-back-to-current-heading, allout-next-visible-heading)
(allout-next-sibling): Use new allout-do-doublecheck function.
(allout-next-sibling): Ensure we made progress when returning
other than nil.
(allout-rebullet-heading): Preserve text property annotations
indicating the text was hidden, if it was.
(allout-kill-line): Remove any added was-hidden annotations.
(allout-kill-topic): Remove any added was-hidden annotations.
(allout-annotate-hidden): Inhibit adding was-hidden text
properties to the undo list.
(allout-deannotate-hidden): New function to remove was-hidden
annotation.
(allout-hide-by-annotation): Use new allout-deannotate-hidden.
(allout-remove-exposure-annotation): Replaced by
allout-deannotate-hidden.
(allout-yank-processing): Signal that yank processing is happening
with allout-during-yank-processing. Also, wrap
allout-unprotected's closer to the text changes, for easier
debugging. We need to inhibit-field-text-motion explicitly, in
lieu of the encompassing allout-unprotected.
(outlineify-sticky): Adjust criteria for triggering new outline
decorations to presence or absence of any topics, not just a topic
at the beginning of the buffer.
| author | Kim F. Storm <storm@cua.dk> |
|---|---|
| date | Sat, 04 Nov 2006 00:48:31 +0000 |
| parents | df3186ae0953 |
| children | 89b9e8184350 |
line wrap: on
line diff
--- a/lisp/allout.el Sat Nov 04 00:48:05 2006 +0000 +++ b/lisp/allout.el Sat Nov 04 00:48:31 2006 +0000 @@ -891,13 +891,18 @@ (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. +(defconst allout-doublecheck-at-and-shallower 2 + "Validate 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.") +excessively greater depth. + +A level of 2 is safest, so that yanks, which must ignore +aberrance while rectifying the yanked text to their new location, +is least likely to be fooled by aberrant topics in the yanked +text.") ;;;_ X allout-reset-header-lead (header-lead) (defun allout-reset-header-lead (header-lead) "*Reset the leading string used to identify topic headers." @@ -1506,6 +1511,13 @@ (goto-char (cadr allout-after-save-decrypt)) (setq allout-after-save-decrypt nil)) ) +;;;_ = allout-during-yank-processing nil +;; XXX allout yanks adjust the level of the topic being pasted to that of +;; their target location. aberrance must be inhibited to allow that +;; reconciliation. (this means that actually aberrant topics won't be +;; treated specially while being pasted.) +(defvar allout-during-yank-processing nil + "Internal state, inhibits aberrance doublecheck while adjusting yanks.") ;;;_ #2 Mode activation ;;;_ = allout-explicitly-deactivated @@ -2194,27 +2206,16 @@ ;;;_ - Position Assessment ;;;_ : Location Predicates -;;;_ > allout-on-current-heading-p () -(defun allout-on-current-heading-p () - "Return non-nil if point is on current visible topics' header line. - -Actually, returns prefix beginning point." - (save-excursion - (allout-beginning-of-current-line) - (and (looking-at allout-regexp) - (allout-prefix-data) - (or (> allout-recent-depth allout-doublecheck-at-and-shallower) - (not (allout-aberrant-container-p)))))) -;;;_ > allout-on-heading-p () -(defalias 'allout-on-heading-p 'allout-on-current-heading-p) -;;;_ > allout-e-o-prefix-p () -(defun allout-e-o-prefix-p () - "True if point is located where current topic prefix ends, heading begins." - (and (save-excursion (let ((inhibit-field-text-motion t)) - (beginning-of-line)) - (looking-at allout-regexp)) - (= (point)(save-excursion (allout-end-of-prefix)(point))))) -;;;_ > allout-aberrant-container-p () +;;;_ > allout-do-doublecheck () +(defsubst allout-do-doublecheck () + "True if current item conditions qualify for checking on topic aberrance." + (and + ;; presume integrity of outline and yanked content during yank - necessary, + ;; to allow for level disparity of yank location and yanked text: + (not allout-during-yank-processing) + ;; allout-doublecheck-at-and-shallower is ceiling for doublecheck: + (<= allout-recent-depth allout-doublecheck-at-and-shallower))) +;;;_ > allout-aberrant-container-p () (defun allout-aberrant-container-p () "True if topic, or next sibling with children, contains them discontinuously. @@ -2247,7 +2248,7 @@ (goto-char allout-recent-prefix-beginning) (cond ;; sibling - continue: - ((eq allout-recent-depth depth)) + ((eq allout-recent-depth depth)) ;; first offspring is excessive - aberrant: ((> allout-recent-depth (1+ depth)) (setq done t aberrant t)) @@ -2259,6 +2260,26 @@ ;; recalibrate allout-recent-* (allout-depth) nil))) +;;;_ > allout-on-current-heading-p () +(defun allout-on-current-heading-p () + "Return non-nil if point is on current visible topics' header line. + +Actually, returns prefix beginning point." + (save-excursion + (allout-beginning-of-current-line) + (and (looking-at allout-regexp) + (allout-prefix-data) + (or (not (allout-do-doublecheck)) + (not (allout-aberrant-container-p)))))) +;;;_ > allout-on-heading-p () +(defalias 'allout-on-heading-p 'allout-on-current-heading-p) +;;;_ > allout-e-o-prefix-p () +(defun allout-e-o-prefix-p () + "True if point is located where current topic prefix ends, heading begins." + (and (save-excursion (let ((inhibit-field-text-motion t)) + (beginning-of-line)) + (looking-at allout-regexp)) + (= (point)(save-excursion (allout-end-of-prefix)(point))))) ;;;_ : Location attributes ;;;_ > allout-depth () (defun allout-depth () @@ -2390,8 +2411,7 @@ (allout-depth) (let ((beginning-of-body (save-excursion - (while (and (<= allout-recent-depth - allout-doublecheck-at-and-shallower) + (while (and (allout-do-doublecheck) (allout-aberrant-container-p) (allout-previous-visible-heading 1))) (allout-beginning-of-current-entry) @@ -2443,7 +2463,7 @@ (when (re-search-forward allout-line-boundary-regexp nil 0) (allout-prefix-data) - (and (<= allout-recent-depth allout-doublecheck-at-and-shallower) + (and (allout-do-doublecheck) ;; this will set allout-recent-* on the first non-aberrant topic, ;; whether it's the current one or one that disqualifies it: (allout-aberrant-container-p)) @@ -2464,13 +2484,13 @@ (if (bobp) nil - ;; allout-goto-prefix-doublechecked calls us, so we can't use it here. (let ((start-point (point))) + ;; allout-goto-prefix-doublechecked calls us, so we can't use it here. (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) + (if (and (allout-do-doublecheck) (allout-aberrant-container-p)) (or (allout-previous-heading) (and (goto-char start-point) @@ -2705,11 +2725,11 @@ `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))) + (if (allout-goto-prefix) + (if (and (allout-do-doublecheck) + (allout-aberrant-container-p)) + (allout-previous-heading) + (point)))) ;;;_ > allout-end-of-prefix () (defun allout-end-of-prefix (&optional ignore-decorations) @@ -2745,13 +2765,13 @@ (allout-beginning-of-current-line) (let ((bol-point (point))) - (allout-goto-prefix-doublechecked) - (if (<= (point) bol-point) - (if (interactive-p) - (allout-end-of-prefix) - (point)) - (goto-char (point-min)) - nil))) + (if (allout-goto-prefix-doublechecked) + (if (<= (point) bol-point) + (if (interactive-p) + (allout-end-of-prefix) + (point)) + (goto-char (point-min)) + nil)))) ;;;_ > allout-back-to-heading () (defalias 'allout-back-to-heading 'allout-back-to-current-heading) ;;;_ > allout-pre-next-prefix () @@ -2918,6 +2938,7 @@ nil (let ((target-depth (or depth (allout-depth))) (start-point (point)) + (start-prefix-beginning allout-recent-prefix-beginning) (count 0) leaping last-depth) @@ -2941,7 +2962,9 @@ nil))) ((and (not (eobp)) (and (> (or last-depth (allout-depth)) 0) - (= allout-recent-depth target-depth))) + (= allout-recent-depth target-depth)) + (not (= start-prefix-beginning + allout-recent-prefix-beginning))) allout-recent-prefix-beginning) (t (goto-char start-point) @@ -3067,8 +3090,7 @@ ;; not a header line, keep looking: t (allout-prefix-data) - (if (and (<= allout-recent-depth - allout-doublecheck-at-and-shallower) + (if (and (allout-do-doublecheck) (allout-aberrant-container-p)) ;; skip this aberrant prospective header line: t @@ -3480,7 +3502,7 @@ If OFFER-RECENT-BULLET is true, offer to use the bullet of the prior sibling. -Runs +Runs Nuances: @@ -3828,6 +3850,7 @@ (mb allout-recent-prefix-beginning) (me allout-recent-prefix-end) (current-bullet (buffer-substring-no-properties (- me 1) me)) + (has-annotation (get-text-property mb 'allout-was-hidden)) (new-prefix (allout-make-topic-prefix current-bullet nil new-depth @@ -3854,6 +3877,11 @@ (allout-unprotected (delete-region (match-beginning 0)(match-end 0)))) + ;; convey 'allout-was-hidden annotation, if original had it: + (if has-annotation + (put-text-property 0 (length new-prefix) 'allout-was-hidden t + new-prefix)) + ; Put in new prefix: (allout-unprotected (insert new-prefix)) @@ -4183,10 +4211,11 @@ (depth (allout-depth))) (allout-annotate-hidden beg end) - (if (and (not beg-hidden) (not end-hidden)) (allout-unprotected (kill-line arg)) (kill-line arg)) + (allout-deannotate-hidden beg end) + (if allout-numbered-bullet (save-excursion ; Renumber subsequent topics if needed: (if (not (looking-at allout-regexp)) @@ -4218,6 +4247,7 @@ (interactive) (let* ((inhibit-field-text-motion t) (beg (prog1 (allout-back-to-current-heading) (beginning-of-line))) + end (depth allout-recent-depth)) (allout-end-of-current-subtree) (if (and (/= (current-column) 0) (not (eobp))) @@ -4231,9 +4261,13 @@ (string= (buffer-substring (- beg 2) beg) "\n\n")))) (forward-char 1))) - (allout-annotate-hidden beg (point)) - - (allout-unprotected (kill-region beg (point))) + (allout-annotate-hidden beg (setq end (point))) + (unwind-protect + (allout-unprotected (kill-region beg end)) + (if buffer-read-only + ;; eg, during copy-as-kill. + (allout-deannotate-hidden beg end))) + (save-excursion (allout-renumber-to-depth depth)) (run-hook-with-args 'allout-structure-deleted-hook depth (point)))) @@ -4251,8 +4285,7 @@ (let ((was-modified (buffer-modified-p)) (buffer-read-only nil)) - (allout-unprotected - (remove-text-properties begin end '(allout-was-hidden t))) + (allout-deannotate-hidden begin end) (save-excursion (goto-char begin) (let (done next prev overlay) @@ -4279,9 +4312,19 @@ (when next (goto-char next) (allout-unprotected - (put-text-property (overlay-start overlay) next - 'allout-was-hidden t)))))))) + (let ((buffer-undo-list t)) + (put-text-property (overlay-start overlay) next + 'allout-was-hidden t))))))))) (set-buffer-modified-p was-modified))) +;;;_ > allout-deannotate-hidden (begin end) +(defun allout-deannotate-hidden (begin end) + "Remove allout hidden-text annotation between BEGIN and END." + + (allout-unprotected + (let ((inhibit-read-only t) + (buffer-undo-list t)) + ;(remove-text-properties begin end '(allout-was-hidden t)) + ))) ;;;_ > allout-hide-by-annotation (begin end) (defun allout-hide-by-annotation (begin end) "Translate text properties indicating exposure status into actual exposure." @@ -4309,16 +4352,10 @@ nil end)) (overlay-put (make-overlay prev next) 'category 'allout-exposure-category) - (allout-unprotected - (remove-text-properties prev next '(allout-was-hidden t))) + (allout-deannotate-hidden prev next) (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) @@ -4345,108 +4382,117 @@ ; region around subject: (if (< (allout-mark-marker t) (point)) (exchange-point-and-mark)) - (allout-unprotected - (let* ((subj-beg (point)) - (into-bol (bolp)) - (subj-end (allout-mark-marker t)) - ;; 'resituate' if yanking an entire topic into topic header: - (resituate (and (allout-e-o-prefix-p) - (looking-at allout-regexp) - (allout-prefix-data))) - ;; `rectify-numbering' if resituating (where several topics may - ;; be resituating) or yanking a topic into a topic slot (bol): - (rectify-numbering (or resituate - (and into-bol (looking-at allout-regexp))))) - (if resituate + (let* ( ;; inhibit aberrance doublecheck while reconciling disparate pastes: + (allout-during-yank-processing t) + (subj-beg (point)) + (into-bol (bolp)) + (subj-end (allout-mark-marker t)) + ;; 'resituate' if yanking an entire topic into topic header: + (resituate (and (allout-e-o-prefix-p) + (looking-at allout-regexp) + (allout-prefix-data))) + ;; `rectify-numbering' if resituating (where several topics may + ;; be resituating) or yanking a topic into a topic slot (bol): + (rectify-numbering (or resituate + (and into-bol (looking-at allout-regexp))))) + (if resituate ; The yanked stuff is a topic: - (let* ((prefix-len (- (match-end 1) subj-beg)) - (subj-depth allout-recent-depth) - (prefix-bullet (allout-recent-bullet)) - (adjust-to-depth - ;; Nil if adjustment unnecessary, otherwise depth to which - ;; adjustment should be made: - (save-excursion - (and (goto-char subj-end) - (eolp) - (goto-char subj-beg) - (and (looking-at allout-regexp) - (progn - (beginning-of-line) - (not (= (point) subj-beg))) - (looking-at allout-regexp) - (allout-prefix-data)) - allout-recent-depth))) - (more t)) - (setq rectify-numbering allout-numbered-bullet) - (if adjust-to-depth + (let* ((inhibit-field-text-motion t) + (prefix-len (if (not (match-end 1)) + 1 + (- (match-end 1) subj-beg))) + (subj-depth allout-recent-depth) + (prefix-bullet (allout-recent-bullet)) + (adjust-to-depth + ;; Nil if adjustment unnecessary, otherwise depth to which + ;; adjustment should be made: + (save-excursion + (and (goto-char subj-end) + (eolp) + (goto-char subj-beg) + (and (looking-at allout-regexp) + (progn + (beginning-of-line) + (not (= (point) subj-beg))) + (looking-at allout-regexp) + (allout-prefix-data)) + allout-recent-depth))) + (more t)) + (setq rectify-numbering allout-numbered-bullet) + (if adjust-to-depth ; Do the adjustment: - (progn - (save-restriction - (narrow-to-region subj-beg subj-end) + (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)) - (save-excursion + (while (allout-ascend)) + (save-excursion + (allout-unprotected (allout-rebullet-topic-grunt (- adjust-to-depth - subj-depth)) - (allout-depth)) - (if (setq more (not (bobp))) - (progn (widen) - (forward-char -1) - (narrow-to-region subj-beg (point)))))) - ;; Preserve new bullet if it's a distinctive one, otherwise - ;; use old one: - (if (string-match (regexp-quote prefix-bullet) - allout-distinctive-bullets-string) + subj-depth))) + (allout-depth)) + (if (setq more (not (bobp))) + (progn (widen) + (forward-char -1) + (narrow-to-region subj-beg (point)))))) + ;; Preserve new bullet if it's a distinctive one, otherwise + ;; use old one: + (if (string-match (regexp-quote prefix-bullet) + allout-distinctive-bullets-string) ; Delete from bullet of old to ; before bullet of new: - (progn - (beginning-of-line) - (delete-region (point) subj-beg) - (set-marker (allout-mark-marker t) subj-end) - (goto-char subj-beg) - (allout-end-of-prefix)) + (progn + (beginning-of-line) + (allout-unprotected + (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))) + (allout-unprotected + (progn + (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") + (message "... reconciling numbers") ; ... and renumber, in case necessary: - (goto-char subj-beg) - (if (allout-goto-prefix-doublechecked) + (goto-char subj-beg) + (if (allout-goto-prefix-doublechecked) + (allout-unprotected (allout-rebullet-heading nil ;;; solicit - (allout-depth) ;;; depth - nil ;;; number-control - nil ;;; index - t)) - (message "")))) - (if (or into-bol resituate) - (allout-hide-by-annotation (point) (allout-mark-marker t)) - (allout-remove-exposure-annotation (allout-mark-marker t) (point))) - (if (not resituate) - (exchange-point-and-mark)) - (run-hook-with-args 'allout-structure-added-hook subj-beg subj-end)))) + (allout-depth) ;;; depth + nil ;;; number-control + nil ;;; index + t))) + (message "")))) + (if (or into-bol resituate) + (allout-hide-by-annotation (point) (allout-mark-marker t)) + (allout-deannotate-hidden (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. @@ -6356,7 +6402,7 @@ (save-excursion (goto-char (point-min)) - (if (looking-at allout-regexp) + (if (allout-goto-prefix) t (allout-open-topic 2) (insert (concat "Dummy outline topic header - see"