* allout patch to fix yanked text problem
@ 2006-11-02 2:21 Ken Manheimer
2006-11-04 0:48 ` Kim F. Storm
0 siblings, 1 reply; 2+ messages in thread
From: Ken Manheimer @ 2006-11-02 2:21 UTC (permalink / raw)
[-- Attachment #1: Type: text/plain, Size: 2071 bytes --]
this is an important allout patch, repairing a few problems with
yanked text, including particularly a showstopper when reconciling the
depth of yanked text to that of the context into which it's being
yanked.
the changelog entry is below and also attached, with the patch itself.
ken
2006-11-01 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.
--
ken
ken.manheimer@gmail.com
http://myriadicity.net
[-- Attachment #2: allout-patch.txt --]
[-- Type: text/plain, Size: 23127 bytes --]
Index: allout.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/allout.el,v
retrieving revision 1.86
diff -u -u -r1.86 allout.el
--- allout.el 9 Oct 2006 23:34:11 -0000 1.86
+++ allout.el 2 Nov 2006 02:19:28 -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.
@@ -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
@@ -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-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)))
- (allout-unprotected (kill-region beg (point)))
(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"
[-- Attachment #3: ChangeLog-entry.txt --]
[-- Type: text/plain, Size: 1727 bytes --]
2006-11-01 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.
[-- Attachment #4: 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] 2+ messages in thread
end of thread, other threads:[~2006-11-04 0:48 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2006-11-02 2:21 allout patch to fix yanked text problem Ken Manheimer
2006-11-04 0:48 ` Kim F. Storm
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.