emacs: lisp/allout.el comparison

comparison lisp/allout.el @ 83548:c71725faff1a

Merged from emacs@sv.gnu.org. Last-minute emacsclient rewrites be damned! Patches applied: * emacs@sv.gnu.org/emacs--devo--0--patch-490 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-491 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-492 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-493 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-494 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-495 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-496 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-497 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-498 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-499 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-500 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-501 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-502 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-503 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-504 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-505 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-506 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-507 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-508 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-509 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-510 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-511 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-512 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-513 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-514 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-515 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-516 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-517 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-518 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-519 Update from CVS: etc/TUTORIAL.cn: Updated. * emacs@sv.gnu.org/emacs--devo--0--patch-520 Merge from erc--emacs--22 * emacs@sv.gnu.org/emacs--devo--0--patch-521 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-522 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-523 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-524 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-525 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-526 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-527 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-528 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-529 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-530 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-531 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-532 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-533 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-534 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-535 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-161 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-162 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-163 Merge from emacs--devo--0 * emacs@sv.gnu.org/gnus--rel--5.10--patch-164 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-165 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-166 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-167 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-168 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-169 Merge from emacs--devo--0 * emacs@sv.gnu.org/gnus--rel--5.10--patch-170 Update from CVS git-archimport-id: lorentey@elte.hu--2004/emacs--multi-tty--0--patch-588

author	Karoly Lorentey <lorentey@elte.hu>
date	Sun, 03 Dec 2006 15:03:30 +0000
parents	2d56e13fd23d cce8c092567f
children	17e0dd217877

comparison

equal deleted inserted replaced

-:0912b745fc75
+:c71725faff1a
 ;; The latest development version and helpful notes are available at
 ;; http://myriadicity.net/Sundry/EmacsAllout .
 ;;
 ;; The outline menubar additions provide quick reference to many of
 ;; the features, and see the docstring of the variable `allout-init'
-;; for instructions on priming your emacs session for automatic
+;; for instructions on priming your Emacs session for automatic
 ;; activation of allout-mode.
 ;;
 ;; See the docstring of the variables `allout-layout' and
 ;; `allout-auto-activation' for details on automatic activation of
 ;; `allout-mode' as a minor mode.  (It has changed since allout
 (defvar allout-plain-bullets-string-len (length allout-plain-bullets-string)
 "Length of `allout-plain-bullets-string', updated by `set-allout-regexp'.")
 (make-variable-buffer-local 'allout-plain-bullets-string-len)
 ;;;_   = allout-doublecheck-at-and-shallower
-(defconst allout-doublecheck-at-and-shallower 3
+(defconst allout-doublecheck-at-and-shallower 2
-"Verify apparent topics of this depth and shallower as being non-aberrant.
+"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
+limited to shallow depths, because the determination of aberrance
-depends on the mistaken item being followed by a legitimate item of
+is according to the mistaken item being followed by a legitimate item of
 excessively greater depth.")
 ;;;_   X allout-reset-header-lead (header-lead)
 (defun allout-reset-header-lead (header-lead)
 "*Reset the leading string used to identify topic headers."
 (interactive "sNew lead string: ")
 itself is \*not* recorded in the file anywhere, and the encrypted contents
 are random binary characters to avoid exposing greater susceptibility to
 search attacks.
 The verifier string is retained as an Emacs file variable, as well as in
-the emacs buffer state, if file variable adjustments are enabled.  See
+the Emacs buffer state, if file variable adjustments are enabled.  See
 `allout-enable-file-variable-adjustment' for details about that.")
 (make-variable-buffer-local 'allout-passphrase-verifier-string)
 ;;;###autoload
 (put 'allout-passphrase-verifier-string 'safe-local-variable 'stringp)
 ;;;_   = allout-passphrase-hint-string
 "Variable used to retain reminder string for file's encryption passphrase.
 See the description of `allout-passphrase-hint-handling' for details about how
 the reminder is deployed.
-The hint is retained as an Emacs file variable, as well as in the emacs buffer
+The hint is retained as an Emacs file variable, as well as in the Emacs buffer
 state, if file variable adjustments are enabled.  See
 `allout-enable-file-variable-adjustment' for details about that.")
 (make-variable-buffer-local 'allout-passphrase-hint-string)
 (setq-default allout-passphrase-hint-string "")
 ;;;###autoload
 (if (not was-modified)
 (set-buffer-modified-p nil)))
 (goto-char (cadr allout-after-save-decrypt))
 (setq allout-after-save-decrypt nil))
 )
+;;;_   = allout-inhibit-aberrance-doublecheck nil
+;; In some exceptional moments, disparate topic depths need to be allowed
+;; momentarily, eg when one topic is being yanked into another and they're
+;; about to be reconciled.  let-binding allout-inhibit-aberrance-doublecheck
+;; prevents the aberrance doublecheck to allow, eg, the reconciliation
+;; processing to happen in the presence of such discrepancies.  It should
+;; almost never be needed, however.
+(defvar allout-inhibit-aberrance-doublecheck nil
+"Internal state, for momentarily inhibits aberrance doublecheck.
+This should only be momentarily let-bound non-nil, not set
+non-nil in a lasting way.")
 ;;;_ #2 Mode activation
 ;;;_  = allout-explicitly-deactivated
 (defvar allout-explicitly-deactivated nil
 "If t, `allout-mode's last deactivation was deliberate.
 ;;;_ #4 Navigation
 ;;;_  - Position Assessment
 ;;;_   : Location Predicates
-;;;_    > allout-on-current-heading-p ()
+;;;_    > allout-do-doublecheck ()
-(defun allout-on-current-heading-p ()
+(defsubst allout-do-doublecheck ()
-"Return non-nil if point is on current visible topics' header line.
+"True if current item conditions qualify for checking on topic aberrance."
+(and
-Actually, returns prefix beginning point."
+;; presume integrity of outline and yanked content during yank - necessary,
-(save-excursion
+;; to allow for level disparity of yank location and yanked text:
-(allout-beginning-of-current-line)
+(not allout-inhibit-aberrance-doublecheck)
-(and (looking-at allout-regexp)
+;; allout-doublecheck-at-and-shallower is ceiling for doublecheck:
-(allout-prefix-data)
+(<= allout-recent-depth allout-doublecheck-at-and-shallower)))
-(or (> allout-recent-depth allout-doublecheck-at-and-shallower)
+;;;_     > allout-aberrant-container-p ()
-(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 ()
 (defun allout-aberrant-container-p ()
 "True if topic, or next sibling with children, contains them discontinuously.
 Discontinuous means an immediate offspring that is nested more
 than one level deeper than the topic.
 (re-search-forward allout-line-boundary-regexp nil 0))
 (allout-prefix-data)
 (goto-char allout-recent-prefix-beginning)
 (cond
 ;; sibling - continue:
 ((eq allout-recent-depth depth))
 ;; first offspring is excessive - aberrant:
 ((> allout-recent-depth (1+ depth))
 (setq done t aberrant t))
 ;; next non-sibling is lower-depth - not aberrant:
 (t (setq done t)))))
 aberrant
 (goto-char start-point)
 ;; 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 ()
 "Return depth of topic most immediately containing point.
 (not (equal last-command this-command)))
 (move-beginning-of-line 1)
 (allout-depth)
 (let ((beginning-of-body
 (save-excursion
-(while (and (<= allout-recent-depth
+(while (and (allout-do-doublecheck)
-allout-doublecheck-at-and-shallower)
 (allout-aberrant-container-p)
 (allout-previous-visible-heading 1)))
 (allout-beginning-of-current-entry)
 (point))))
 (cond ((= (current-column) 0)
 (if (looking-at allout-regexp)
 (forward-char 1))
 (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))
 (goto-char allout-recent-prefix-beginning)))
 ;;;_   > allout-this-or-next-heading
 We skip anomolous low-level topics, a la `allout-aberrant-container-p'."
 (if (bobp)
 nil
-;; allout-goto-prefix-doublechecked calls us, so we can't use it here.
 (let ((start-point (point)))
+;; allout-goto-prefix-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)
 ;; recalibrate allout-recent-*:
 (allout-depth)
 Like `allout-goto-prefix', but shallow topics \(according to
 `allout-doublecheck-at-and-shallower') are checked and
 disqualified for child containment discontinuity, according to
 `allout-aberrant-container-p'."
-(allout-goto-prefix)
+(if (allout-goto-prefix)
-(if (and (<= allout-recent-depth allout-doublecheck-at-and-shallower)
+(if (and (allout-do-doublecheck)
 (allout-aberrant-container-p))
 (allout-previous-heading)
-(point)))
+(point))))
 ;;;_   > allout-end-of-prefix ()
 (defun allout-end-of-prefix (&optional ignore-decorations)
 "Position cursor at beginning of header text.
 Return value of resulting point, unless we started outside
 of (before any) topics, in which case we return nil."
 (allout-beginning-of-current-line)
 (let ((bol-point (point)))
-(allout-goto-prefix-doublechecked)
+(if (allout-goto-prefix-doublechecked)
 (if (<= (point) bol-point)
 (if (interactive-p)
 (allout-end-of-prefix)
 (point))
 (goto-char (point-min))
-nil)))
+nil))))
 ;;;_   > allout-back-to-heading ()
 (defalias 'allout-back-to-heading 'allout-back-to-current-heading)
 ;;;_   > allout-pre-next-prefix ()
 (defun allout-pre-next-prefix ()
 "Skip forward to just before the next heading line.
 ;;;_   > allout-ascend ()
 (defun allout-ascend ()
 "Ascend one level, returning t if successful, nil if not."
 (prog1
 (if (allout-beginning-of-level)
-(allout-previous-heading))
+(let ((bolevel (point))
+(bolevel-depth allout-recent-depth))
+(allout-previous-heading)
+(if (< allout-recent-depth bolevel-depth)
+allout-recent-depth
+;; some topic after file's first is at lower depth than first:
+(goto-char bolevel)
+(allout-depth)
+nil)))
 (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.
 (if (if backward (bobp) (eobp))
 nil
 (let ((target-depth (or depth (allout-depth)))
 (start-point (point))
+(start-prefix-beginning allout-recent-prefix-beginning)
 (count 0)
 leaping
 	  last-depth)
 (while (and
 ;; done too few single steps to resort to the leap routine:
 (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-depth target-depth))
+(not (= start-prefix-beginning
+allout-recent-prefix-beginning)))
 allout-recent-prefix-beginning)
 (t
 (goto-char start-point)
 (if depth (allout-depth) target-depth)
 nil)))))
 ;; Deal with apparent header line:
 (if (not (looking-at allout-regexp))
 ;; not a header line, keep looking:
 t
 (allout-prefix-data)
-(if (and (<= allout-recent-depth
+(if (and (allout-do-doublecheck)
-allout-doublecheck-at-and-shallower)
 (allout-aberrant-container-p))
 ;; skip this aberrant prospective header line:
 t
 ;; this prospective headerline qualifies - register:
 (setq got allout-recent-prefix-beginning)
 the other offspring are exposed, or after the last child if the offspring
 are hidden.  \(The intervening offspring will be exposed in the latter
 case.)
 If OFFER-RECENT-BULLET is true, offer to use the bullet of the prior sibling.
-Runs
 Nuances:
 - Creation of new topics is with respect to the visible topic
 containing the cursor, regardless of intervening concealed ones.
 (let* ((current-depth (allout-depth))
 (new-depth (or new-depth current-depth))
 (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
 solicit
 number-control
 (if (and allout-numbered-bullet
 (string= allout-numbered-bullet current-bullet)
 (looking-at "[0-9]+"))
 	  (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))
 ;; Reindent the body if elected, margin changed, and not encrypted body:
 0))))
 (if (and (> predecessor-depth 0)
 (> (1+ current-depth)
 (1+ predecessor-depth)))
 (error (concat "Disallowed shift deeper than"
-" containing topic's children."))))))
+" containing topic's children."))
+(allout-back-to-current-heading)
+(if (< allout-recent-depth (1+ current-depth))
+(allout-show-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)
 (setq end (point))
 (allout-hidden-p)))
 (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))
 (allout-next-heading))
 (allout-renumber-to-depth depth)))
 allout-yank-processing for exposure recovery."
 (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)))
 (forward-char 1))
 (if (not (eobp))
 (= depth allout-recent-depth)))
 (and (> (- beg (point-min)) 3)
 (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 (point)))
+(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))))
 ;;;_    > allout-copy-topic-as-kill ()
 (defun allout-copy-topic-as-kill ()
 (defun allout-annotate-hidden (begin end)
 "Qualify text with properties to indicate exposure status."
 (let ((was-modified (buffer-modified-p))
 (buffer-read-only nil))
-(allout-unprotected
+(allout-deannotate-hidden begin end)
-(remove-text-properties begin end '(allout-was-hidden t)))
 (save-excursion
 (goto-char begin)
 (let (done next prev overlay)
 (while (not done)
 ;; at or advance to start of next hidden region:
 prev next)
 ;; advance to end of this hidden area:
 (when next
 (goto-char next)
 (allout-unprotected
-(put-text-property (overlay-start overlay) next
+(let ((buffer-undo-list t))
-'allout-was-hidden 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."
 (save-excursion
 (goto-char begin)
 (setq next (next-single-char-property-change (point)
 'allout-was-hidden
 nil end))
 (overlay-put (make-overlay prev next)
 'category 'allout-exposure-category)
-(allout-unprotected
+(allout-deannotate-hidden prev next)
-(remove-text-properties prev next '(allout-was-hidden t)))
 (setq prev next)
 (if next (goto-char next)))))
 (set-buffer-modified-p was-modified))))
-;;;_    > allout-remove-exposure-annotation (begin end)
-(defun allout-remove-exposure-annotation (begin end)
-"Remove text properties indicating exposure status."
-(remove-text-properties begin end '(allout-was-hidden t)))
 ;;;_    > allout-yank-processing ()
 (defun allout-yank-processing (&optional arg)
 "Incidental allout-specific business to be done just after text yanks.
 (interactive "*P")
 					; Get to beginning, leaving
 					; region around subject:
 (if (< (allout-mark-marker t) (point))
 (exchange-point-and-mark))
-(allout-unprotected
+(let* ((subj-beg (point))
-(let* ((subj-beg (point))
+(into-bol (bolp))
-(into-bol (bolp))
+(subj-end (allout-mark-marker t))
-(subj-end (allout-mark-marker t))
+;; 'resituate' if yanking an entire topic into topic header:
-;; 'resituate' if yanking an entire topic into topic header:
+(resituate (and (let ((allout-inhibit-aberrance-doublecheck t))
-(resituate (and (allout-e-o-prefix-p)
+(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:
+;; Yanking a topic into the start of a topic - reconcile to fit:
-(let* ((prefix-len (- (match-end 1) subj-beg))
+(let* ((inhibit-field-text-motion t)
-(subj-depth allout-recent-depth)
+(prefix-len (if (not (match-end 1))
-(prefix-bullet (allout-recent-bullet))
+1
-(adjust-to-depth
+(- (match-end 1) subj-beg)))
-;; Nil if adjustment unnecessary, otherwise depth to which
+(subj-depth allout-recent-depth)
-;; adjustment should be made:
+(prefix-bullet (allout-recent-bullet))
-(save-excursion
+(adjust-to-depth
-(and (goto-char subj-end)
+;; Nil if adjustment unnecessary, otherwise depth to which
-(eolp)
+;; adjustment should be made:
-(goto-char subj-beg)
+(save-excursion
-(and (looking-at allout-regexp)
+(and (goto-char subj-end)
-(progn
+(eolp)
-(beginning-of-line)
+(goto-char subj-beg)
-(not (= (point) subj-beg)))
+(and (looking-at allout-regexp)
-(looking-at allout-regexp)
+(progn
-(allout-prefix-data))
+(beginning-of-line)
-allout-recent-depth)))
+(not (= (point) subj-beg)))
-(more t))
+(looking-at allout-regexp)
-(setq rectify-numbering allout-numbered-bullet)
+(allout-prefix-data))
-(if adjust-to-depth
+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)
 ; Trim off excessive blank
 ; line at end, if any:
 (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)
 ; go as high as we can in each bunch:
 (while (allout-ascend))
 (save-excursion
+(allout-unprotected
 (allout-rebullet-topic-grunt (- adjust-to-depth
-						       subj-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)
 ; Delete from bullet of old to
 ; before bullet of new:
 (progn
 (beginning-of-line)
-(delete-region (point) subj-beg)
+(allout-unprotected
-(set-marker (allout-mark-marker t) subj-end)
+(delete-region (point) subj-beg))
-(goto-char subj-beg)
+(set-marker (allout-mark-marker t) subj-end)
-(allout-end-of-prefix))
+(goto-char subj-beg)
+(allout-end-of-prefix))
 ; Delete base subj prefix,
 ; leaving old one:
-(delete-region (point) (+ (point)
+(allout-unprotected
-prefix-len
+(progn
-(- adjust-to-depth subj-depth)))
+(delete-region (point) (+ (point)
+prefix-len
+(- adjust-to-depth
+subj-depth)))
 ; and delete residual subj
 ; prefix digits and space:
 (while (looking-at "[0-9]") (delete-char 1))
-(if (looking-at " ") (delete-char 1))))
+(if (looking-at " ") (delete-char 1))))))
 (exchange-point-and-mark))))
 (if rectify-numbering
 (progn
 (save-excursion
 ; Give some preliminary feedback:
 (message "... reconciling numbers")
 ; ... and renumber, in case necessary:
 (goto-char subj-beg)
 (if (allout-goto-prefix-doublechecked)
+(allout-unprotected
 (allout-rebullet-heading nil            ;;; solicit
-					  (allout-depth) ;;; depth
+(allout-depth) ;;; depth
-					  nil            ;;; number-control
+nil            ;;; number-control
-					  nil            ;;; index
+nil            ;;; index
-					  t))
+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)))
+(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))))
+(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.
 Non-topic yanks work no differently than normal yanks.
 If allout customization var `allout-passphrase-verifier-handling' is
 non-nil, an entry for `allout-passphrase-verifier-string' and its value is
 added to an Emacs 'local variables' section at the end of the file, which
 is created if necessary.  That setting is for retention of the passphrase
-verifier across emacs sessions.
+verifier across Emacs sessions.
 Similarly, `allout-passphrase-hint-string' stores a user-provided reminder
 about their passphrase, and `allout-passphrase-hint-handling' specifies
 when the hint is presented, or if passphrase hints are disabled.  If
 enabled \(see the `allout-passphrase-hint-handling' docstring for details),
 (if (= allout-recent-depth 1)
 (error (concat "Cannot encrypt or decrypt level 1 topics -"
 " shift it in to make it encryptable")))
 (let* ((allout-buffer (current-buffer))
-;; Asses location:
+;; Assess location:
 (bullet-pos allout-recent-prefix-beginning)
 (after-bullet-pos (point))
 (was-encrypted
 (progn (if (= (point-max) after-bullet-pos)
 (error "no body to encrypt"))
 (and (member fetch-pass '(4 (4)))
 '(keypair nil))
 '(symmetric nil)))
 (for-key-type (car key-info))
 (for-key-identity (cadr key-info))
-(fetch-pass (and fetch-pass (member fetch-pass '(16 (16))))))
+(fetch-pass (and fetch-pass (member fetch-pass '(16 (16)))))
+(was-coding-system buffer-file-coding-system))
+(when (not was-encrypted)
+;; ensure that non-ascii chars pending encryption are noticed before
+;; they're encrypted, so the coding system is set to accomodate
+;; them.
+(setq buffer-file-coding-system
+(select-safe-coding-system subtree-beg subtree-end))
+;; if the coding system for the text being encrypted is different
+;; than that prevailing, then there a real risk that the coding
+;; system can't be noticed by emacs when the file is visited.  to
+;; mitigate that, offer to preserve the coding system using a file
+;; local variable.
+(if (and (not (equal buffer-file-coding-system
+was-coding-system))
+(yes-or-no-p
+(format (concat "Register coding system %s as file local"
+" var?  Necessary when only encrypted text"
+" is in that coding system. ")
+buffer-file-coding-system)))
+(allout-adjust-file-variable "buffer-file-coding-system"
+buffer-file-coding-system)))
 (setq result-text
 (allout-encrypt-string subject-text was-encrypted
 (current-buffer)
 for-key-type for-key-identity fetch-pass))
 key-type
 (if (equal key-type 'keypair)
 target-prompt-id
 (or (buffer-file-name allout-buffer)
 target-prompt-id))))
+(encoding (with-current-buffer allout-buffer
+buffer-file-coding-system))
+(multibyte (with-current-buffer allout-buffer
+enable-multibyte-characters))
 (strip-plaintext-regexps
 (if (not decrypt)
 (allout-get-configvar-values
 'allout-encryption-plaintext-sanitization-regexps)))
 (reject-ciphertext-regexps
 retried fetch-pass)))
 (with-temp-buffer
 (insert text)
+;; convey the text characteristics of the original buffer:
+(set-buffer-multibyte multibyte)
+(when encoding
+(set-buffer-file-coding-system encoding)
+(if (not decrypt)
+(encode-coding-region (point-min) (point-max) encoding)))
 (when (and strip-plaintext-regexps (not decrypt))
 (dolist (re strip-plaintext-regexps)
 (let ((re (if (listp re) (car re) re))
 (replacement (if (listp re) (cadr re) "")))
 (allout-mode t)
 (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"
 "`allout-mode' docstring: `^Hm'."))
 (allout-adjust-file-variable
 )
 )
 )
 ;;;_   > 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.
+"Adjust the setting of an Emacs file variable named VARNAME to VALUE.
 This activity is inhibited if either `enable-local-variables'
 `allout-enable-file-variable-adjustment' are nil.
 When enabled, an entry for the variable is created if not already present,
 or changed if established with a different value.  The section for the file
 variables, itself, is created if not already present.  When created, the
 section lines \(including the section line) exist as second-level topics in
 a top-level topic at the end of the file.
-enable-local-variables must be true for any of this to happen."
+`enable-local-variables' must be true for any of this to happen."
 (if (not (and enable-local-variables
 allout-enable-file-variable-adjustment))
 nil
 (save-excursion
 (let ((inhibit-field-text-motion t)

Mercurial > emacs

comparison lisp/allout.el @ 83548:c71725faff1a