Mercurial > emacs
comparison lisp/allout.el @ 74011:cce8c092567f
(allout-doublecheck-at-and-shallower): Clarify docstring.
(allout-inhibit-aberrance-doublecheck): Rename from
allout-during-yank-processing. All callers changed.
(allout-ascend): Provide for unusual case where some topic after
the first in file is at lower depth than the first.
(allout-shift-in): Ensure the offspring of the new containing
topic are exposed.
(allout-encrypt-string): Preserve the coding-system of the text,
according to that of the containing buffer.
(allout-toggle-subtree-encryption): When the text being encrypted
requires a different coding system, offer to preserve the coding
system using a file local var.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Wed, 15 Nov 2006 16:34:20 +0000 |
parents | 89b9e8184350 |
children | cba6f2b24720 c71725faff1a dbe3f29e61d6 |
comparison
equal
deleted
inserted
replaced
74010:ba98b964892a | 74011:cce8c092567f |
---|---|
893 ;;;_ = allout-doublecheck-at-and-shallower | 893 ;;;_ = allout-doublecheck-at-and-shallower |
894 (defconst allout-doublecheck-at-and-shallower 2 | 894 (defconst allout-doublecheck-at-and-shallower 2 |
895 "Validate apparent topics of this depth and shallower as being non-aberrant. | 895 "Validate apparent topics of this depth and shallower as being non-aberrant. |
896 | 896 |
897 Verified with `allout-aberrant-container-p'. This check's usefulness is | 897 Verified with `allout-aberrant-container-p'. This check's usefulness is |
898 limited to shallow prospects, because the determination of aberrance | 898 limited to shallow depths, because the determination of aberrance |
899 depends on the mistaken item being followed by a legitimate item of | 899 is according to the mistaken item being followed by a legitimate item of |
900 excessively greater depth. | 900 excessively greater depth.") |
901 | |
902 A level of 2 is safest, so that yanks, which must ignore | |
903 aberrance while rectifying the yanked text to their new location, | |
904 is least likely to be fooled by aberrant topics in the yanked | |
905 text.") | |
906 ;;;_ X allout-reset-header-lead (header-lead) | 901 ;;;_ X allout-reset-header-lead (header-lead) |
907 (defun allout-reset-header-lead (header-lead) | 902 (defun allout-reset-header-lead (header-lead) |
908 "*Reset the leading string used to identify topic headers." | 903 "*Reset the leading string used to identify topic headers." |
909 (interactive "sNew lead string: ") | 904 (interactive "sNew lead string: ") |
910 (setq allout-header-prefix header-lead) | 905 (setq allout-header-prefix header-lead) |
1509 (if (not was-modified) | 1504 (if (not was-modified) |
1510 (set-buffer-modified-p nil))) | 1505 (set-buffer-modified-p nil))) |
1511 (goto-char (cadr allout-after-save-decrypt)) | 1506 (goto-char (cadr allout-after-save-decrypt)) |
1512 (setq allout-after-save-decrypt nil)) | 1507 (setq allout-after-save-decrypt nil)) |
1513 ) | 1508 ) |
1514 ;;;_ = allout-during-yank-processing nil | 1509 ;;;_ = allout-inhibit-aberrance-doublecheck nil |
1515 ;; XXX allout yanks adjust the level of the topic being pasted to that of | 1510 ;; In some exceptional moments, disparate topic depths need to be allowed |
1516 ;; their target location. aberrance must be inhibited to allow that | 1511 ;; momentarily, eg when one topic is being yanked into another and they're |
1517 ;; reconciliation. (this means that actually aberrant topics won't be | 1512 ;; about to be reconciled. let-binding allout-inhibit-aberrance-doublecheck |
1518 ;; treated specially while being pasted.) | 1513 ;; prevents the aberrance doublecheck to allow, eg, the reconciliation |
1519 (defvar allout-during-yank-processing nil | 1514 ;; processing to happen in the presence of such discrepancies. It should |
1520 "Internal state, inhibits aberrance doublecheck while adjusting yanks.") | 1515 ;; almost never be needed, however. |
1516 (defvar allout-inhibit-aberrance-doublecheck nil | |
1517 "Internal state, for momentarily inhibits aberrance doublecheck. | |
1518 | |
1519 This should only be momentarily let-bound non-nil, not set | |
1520 non-nil in a lasting way.") | |
1521 | 1521 |
1522 ;;;_ #2 Mode activation | 1522 ;;;_ #2 Mode activation |
1523 ;;;_ = allout-explicitly-deactivated | 1523 ;;;_ = allout-explicitly-deactivated |
1524 (defvar allout-explicitly-deactivated nil | 1524 (defvar allout-explicitly-deactivated nil |
1525 "If t, `allout-mode's last deactivation was deliberate. | 1525 "If t, `allout-mode's last deactivation was deliberate. |
2210 (defsubst allout-do-doublecheck () | 2210 (defsubst allout-do-doublecheck () |
2211 "True if current item conditions qualify for checking on topic aberrance." | 2211 "True if current item conditions qualify for checking on topic aberrance." |
2212 (and | 2212 (and |
2213 ;; presume integrity of outline and yanked content during yank - necessary, | 2213 ;; presume integrity of outline and yanked content during yank - necessary, |
2214 ;; to allow for level disparity of yank location and yanked text: | 2214 ;; to allow for level disparity of yank location and yanked text: |
2215 (not allout-during-yank-processing) | 2215 (not allout-inhibit-aberrance-doublecheck) |
2216 ;; allout-doublecheck-at-and-shallower is ceiling for doublecheck: | 2216 ;; allout-doublecheck-at-and-shallower is ceiling for doublecheck: |
2217 (<= allout-recent-depth allout-doublecheck-at-and-shallower))) | 2217 (<= allout-recent-depth allout-doublecheck-at-and-shallower))) |
2218 ;;;_ > allout-aberrant-container-p () | 2218 ;;;_ > allout-aberrant-container-p () |
2219 (defun allout-aberrant-container-p () | 2219 (defun allout-aberrant-container-p () |
2220 "True if topic, or next sibling with children, contains them discontinuously. | 2220 "True if topic, or next sibling with children, contains them discontinuously. |
2889 ;;;_ > allout-ascend () | 2889 ;;;_ > allout-ascend () |
2890 (defun allout-ascend () | 2890 (defun allout-ascend () |
2891 "Ascend one level, returning t if successful, nil if not." | 2891 "Ascend one level, returning t if successful, nil if not." |
2892 (prog1 | 2892 (prog1 |
2893 (if (allout-beginning-of-level) | 2893 (if (allout-beginning-of-level) |
2894 (allout-previous-heading)) | 2894 (let ((bolevel (point)) |
2895 (bolevel-depth allout-recent-depth)) | |
2896 (allout-previous-heading) | |
2897 (if (< allout-recent-depth bolevel-depth) | |
2898 allout-recent-depth | |
2899 ;; some topic after file's first is at lower depth than first: | |
2900 (goto-char bolevel) | |
2901 (allout-depth) | |
2902 nil))) | |
2895 (if (interactive-p) (allout-end-of-prefix)))) | 2903 (if (interactive-p) (allout-end-of-prefix)))) |
2896 ;;;_ > allout-descend-to-depth (depth) | 2904 ;;;_ > allout-descend-to-depth (depth) |
2897 (defun allout-descend-to-depth (depth) | 2905 (defun allout-descend-to-depth (depth) |
2898 "Descend to depth DEPTH within current topic. | 2906 "Descend to depth DEPTH within current topic. |
2899 | 2907 |
3499 the other offspring are exposed, or after the last child if the offspring | 3507 the other offspring are exposed, or after the last child if the offspring |
3500 are hidden. \(The intervening offspring will be exposed in the latter | 3508 are hidden. \(The intervening offspring will be exposed in the latter |
3501 case.) | 3509 case.) |
3502 | 3510 |
3503 If OFFER-RECENT-BULLET is true, offer to use the bullet of the prior sibling. | 3511 If OFFER-RECENT-BULLET is true, offer to use the bullet of the prior sibling. |
3504 | |
3505 Runs | |
3506 | 3512 |
3507 Nuances: | 3513 Nuances: |
3508 | 3514 |
3509 - Creation of new topics is with respect to the visible topic | 3515 - Creation of new topics is with respect to the visible topic |
3510 containing the cursor, regardless of intervening concealed ones. | 3516 containing the cursor, regardless of intervening concealed ones. |
4143 0)))) | 4149 0)))) |
4144 (if (and (> predecessor-depth 0) | 4150 (if (and (> predecessor-depth 0) |
4145 (> (1+ current-depth) | 4151 (> (1+ current-depth) |
4146 (1+ predecessor-depth))) | 4152 (1+ predecessor-depth))) |
4147 (error (concat "Disallowed shift deeper than" | 4153 (error (concat "Disallowed shift deeper than" |
4148 " containing topic's children.")))))) | 4154 " containing topic's children.")) |
4155 (allout-back-to-current-heading) | |
4156 (if (< allout-recent-depth (1+ current-depth)) | |
4157 (allout-show-children)))))) | |
4149 (let ((where (point))) | 4158 (let ((where (point))) |
4150 (allout-rebullet-topic 1 (and (> arg 1) 'sans-offspring)) | 4159 (allout-rebullet-topic 1 (and (> arg 1) 'sans-offspring)) |
4151 (run-hook-with-args 'allout-structure-shifted-hook arg where)))) | 4160 (run-hook-with-args 'allout-structure-shifted-hook arg where)))) |
4152 ;;;_ > allout-shift-out (arg) | 4161 ;;;_ > allout-shift-out (arg) |
4153 (defun allout-shift-out (arg) | 4162 (defun allout-shift-out (arg) |
4380 (interactive "*P") | 4389 (interactive "*P") |
4381 ; Get to beginning, leaving | 4390 ; Get to beginning, leaving |
4382 ; region around subject: | 4391 ; region around subject: |
4383 (if (< (allout-mark-marker t) (point)) | 4392 (if (< (allout-mark-marker t) (point)) |
4384 (exchange-point-and-mark)) | 4393 (exchange-point-and-mark)) |
4385 (let* ( ;; inhibit aberrance doublecheck while reconciling disparate pastes: | 4394 (let* ((subj-beg (point)) |
4386 (allout-during-yank-processing t) | |
4387 (subj-beg (point)) | |
4388 (into-bol (bolp)) | 4395 (into-bol (bolp)) |
4389 (subj-end (allout-mark-marker t)) | 4396 (subj-end (allout-mark-marker t)) |
4390 ;; 'resituate' if yanking an entire topic into topic header: | 4397 ;; 'resituate' if yanking an entire topic into topic header: |
4391 (resituate (and (allout-e-o-prefix-p) | 4398 (resituate (and (let ((allout-inhibit-aberrance-doublecheck t)) |
4399 (allout-e-o-prefix-p)) | |
4392 (looking-at allout-regexp) | 4400 (looking-at allout-regexp) |
4393 (allout-prefix-data))) | 4401 (allout-prefix-data))) |
4394 ;; `rectify-numbering' if resituating (where several topics may | 4402 ;; `rectify-numbering' if resituating (where several topics may |
4395 ;; be resituating) or yanking a topic into a topic slot (bol): | 4403 ;; be resituating) or yanking a topic into a topic slot (bol): |
4396 (rectify-numbering (or resituate | 4404 (rectify-numbering (or resituate |
4397 (and into-bol (looking-at allout-regexp))))) | 4405 (and into-bol (looking-at allout-regexp))))) |
4398 (if resituate | 4406 (if resituate |
4399 ; The yanked stuff is a topic: | 4407 ;; Yanking a topic into the start of a topic - reconcile to fit: |
4400 (let* ((inhibit-field-text-motion t) | 4408 (let* ((inhibit-field-text-motion t) |
4401 (prefix-len (if (not (match-end 1)) | 4409 (prefix-len (if (not (match-end 1)) |
4402 1 | 4410 1 |
4403 (- (match-end 1) subj-beg))) | 4411 (- (match-end 1) subj-beg))) |
4404 (subj-depth allout-recent-depth) | 4412 (subj-depth allout-recent-depth) |
4464 ; leaving old one: | 4472 ; leaving old one: |
4465 (allout-unprotected | 4473 (allout-unprotected |
4466 (progn | 4474 (progn |
4467 (delete-region (point) (+ (point) | 4475 (delete-region (point) (+ (point) |
4468 prefix-len | 4476 prefix-len |
4469 (- adjust-to-depth subj-depth))) | 4477 (- adjust-to-depth |
4478 subj-depth))) | |
4470 ; and delete residual subj | 4479 ; and delete residual subj |
4471 ; prefix digits and space: | 4480 ; prefix digits and space: |
4472 (while (looking-at "[0-9]") (delete-char 1)) | 4481 (while (looking-at "[0-9]") (delete-char 1)) |
4473 (if (looking-at " ") (delete-char 1)))))) | 4482 (if (looking-at " ") (delete-char 1)))))) |
4474 (exchange-point-and-mark)))) | 4483 (exchange-point-and-mark)))) |
5755 (if (= allout-recent-depth 1) | 5764 (if (= allout-recent-depth 1) |
5756 (error (concat "Cannot encrypt or decrypt level 1 topics -" | 5765 (error (concat "Cannot encrypt or decrypt level 1 topics -" |
5757 " shift it in to make it encryptable"))) | 5766 " shift it in to make it encryptable"))) |
5758 | 5767 |
5759 (let* ((allout-buffer (current-buffer)) | 5768 (let* ((allout-buffer (current-buffer)) |
5760 ;; Asses location: | 5769 ;; Assess location: |
5761 (bullet-pos allout-recent-prefix-beginning) | 5770 (bullet-pos allout-recent-prefix-beginning) |
5762 (after-bullet-pos (point)) | 5771 (after-bullet-pos (point)) |
5763 (was-encrypted | 5772 (was-encrypted |
5764 (progn (if (= (point-max) after-bullet-pos) | 5773 (progn (if (= (point-max) after-bullet-pos) |
5765 (error "no body to encrypt")) | 5774 (error "no body to encrypt")) |
5789 (and (member fetch-pass '(4 (4))) | 5798 (and (member fetch-pass '(4 (4))) |
5790 '(keypair nil)) | 5799 '(keypair nil)) |
5791 '(symmetric nil))) | 5800 '(symmetric nil))) |
5792 (for-key-type (car key-info)) | 5801 (for-key-type (car key-info)) |
5793 (for-key-identity (cadr key-info)) | 5802 (for-key-identity (cadr key-info)) |
5794 (fetch-pass (and fetch-pass (member fetch-pass '(16 (16)))))) | 5803 (fetch-pass (and fetch-pass (member fetch-pass '(16 (16))))) |
5804 (was-coding-system buffer-file-coding-system)) | |
5805 | |
5806 (when (not was-encrypted) | |
5807 ;; ensure that non-ascii chars pending encryption are noticed before | |
5808 ;; they're encrypted, so the coding system is set to accomodate | |
5809 ;; them. | |
5810 (setq buffer-file-coding-system | |
5811 (select-safe-coding-system subtree-beg subtree-end)) | |
5812 ;; if the coding system for the text being encrypted is different | |
5813 ;; than that prevailing, then there a real risk that the coding | |
5814 ;; system can't be noticed by emacs when the file is visited. to | |
5815 ;; mitigate that, offer to preserve the coding system using a file | |
5816 ;; local variable. | |
5817 (if (and (not (equal buffer-file-coding-system | |
5818 was-coding-system)) | |
5819 (yes-or-no-p | |
5820 (format (concat "Register coding system %s as file local" | |
5821 " var? Necessary when only encrypted text" | |
5822 " is in that coding system. ") | |
5823 buffer-file-coding-system))) | |
5824 (allout-adjust-file-variable "buffer-file-coding-system" | |
5825 buffer-file-coding-system))) | |
5795 | 5826 |
5796 (setq result-text | 5827 (setq result-text |
5797 (allout-encrypt-string subject-text was-encrypted | 5828 (allout-encrypt-string subject-text was-encrypted |
5798 (current-buffer) | 5829 (current-buffer) |
5799 for-key-type for-key-identity fetch-pass)) | 5830 for-key-type for-key-identity fetch-pass)) |
5878 key-type | 5909 key-type |
5879 (if (equal key-type 'keypair) | 5910 (if (equal key-type 'keypair) |
5880 target-prompt-id | 5911 target-prompt-id |
5881 (or (buffer-file-name allout-buffer) | 5912 (or (buffer-file-name allout-buffer) |
5882 target-prompt-id)))) | 5913 target-prompt-id)))) |
5914 (encoding (with-current-buffer allout-buffer | |
5915 buffer-file-coding-system)) | |
5916 (multibyte (with-current-buffer allout-buffer | |
5917 enable-multibyte-characters)) | |
5883 (strip-plaintext-regexps | 5918 (strip-plaintext-regexps |
5884 (if (not decrypt) | 5919 (if (not decrypt) |
5885 (allout-get-configvar-values | 5920 (allout-get-configvar-values |
5886 'allout-encryption-plaintext-sanitization-regexps))) | 5921 'allout-encryption-plaintext-sanitization-regexps))) |
5887 (reject-ciphertext-regexps | 5922 (reject-ciphertext-regexps |
5913 retried fetch-pass))) | 5948 retried fetch-pass))) |
5914 | 5949 |
5915 (with-temp-buffer | 5950 (with-temp-buffer |
5916 | 5951 |
5917 (insert text) | 5952 (insert text) |
5953 | |
5954 ;; convey the text characteristics of the original buffer: | |
5955 (set-buffer-multibyte multibyte) | |
5956 (when encoding | |
5957 (set-buffer-file-coding-system encoding) | |
5958 (if (not decrypt) | |
5959 (encode-coding-region (point-min) (point-max) encoding))) | |
5918 | 5960 |
5919 (when (and strip-plaintext-regexps (not decrypt)) | 5961 (when (and strip-plaintext-regexps (not decrypt)) |
5920 (dolist (re strip-plaintext-regexps) | 5962 (dolist (re strip-plaintext-regexps) |
5921 (let ((re (if (listp re) (car re) re)) | 5963 (let ((re (if (listp re) (car re) re)) |
5922 (replacement (if (listp re) (cadr re) ""))) | 5964 (replacement (if (listp re) (cadr re) ""))) |