Mercurial > emacs

comparison lisp/allout.el @ 83541:694bbb62a75d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merged from emacs@sv.gnu.org Patches applied: * emacs@sv.gnu.org/emacs--devo--0--patch-371 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-372 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-373 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-374 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-375 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-376 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-377 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-378 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-379 Merge from erc--emacs--21 * emacs@sv.gnu.org/emacs--devo--0--patch-380 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-381 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-382 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-383 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-384 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-385 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-386 Update from erc--emacs--22 * emacs@sv.gnu.org/emacs--devo--0--patch-387 Fix ERC bug introduced in last patch * emacs@sv.gnu.org/emacs--devo--0--patch-388 Update from erc--emacs--22 * emacs@sv.gnu.org/emacs--devo--0--patch-389 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-390 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-391 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-392 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-393 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-394 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-395 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-396 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-397 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-398 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-399 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-400 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-401 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-402 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-403 Rcirc update from Ryan Yeske * emacs@sv.gnu.org/emacs--devo--0--patch-404 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-405 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-406 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-407 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-408 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-409 Update from CVS * emacs@sv.gnu.org/emacs--devo--0--patch-410 Merge from gnus--rel--5.10 * emacs@sv.gnu.org/emacs--devo--0--patch-411 Miscellaneous tq-related fixes. * emacs@sv.gnu.org/emacs--devo--0--patch-412 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-121 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-122 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-123 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-124 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-125 Update from CVS * emacs@sv.gnu.org/gnus--rel--5.10--patch-126 Merge from emacs--devo--0 * emacs@sv.gnu.org/gnus--rel--5.10--patch-127 Update from CVS git-archimport-id: lorentey@elte.hu--2004/emacs--multi-tty--0--patch-581
author Karoly Lorentey <lorentey@elte.hu>
date Sat, 14 Oct 2006 16:56:21 +0000
parents 02e39decdc84 12fa9bdadf0a
children 2d56e13fd23d
comparison
equal deleted inserted replaced
83540:0c89a85addc3 83541:694bbb62a75d
211 (make-variable-buffer-local 'allout-show-bodies) 211 (make-variable-buffer-local 'allout-show-bodies)
212 ;;;###autoload 212 ;;;###autoload
213 (put 'allout-show-bodies 'safe-local-variable 213 (put 'allout-show-bodies 'safe-local-variable
214 (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil))))) 214 (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil)))))
215 215
216 ;;;_ = allout-beginning-of-line-cycles
217 (defcustom allout-beginning-of-line-cycles t
218 "*If non-nil, \\[allout-beginning-of-line] will cycle through smart-placement options.
219
220 Cycling only happens on when the command is repeated, not when it
221 follows a different command.
222
223 Smart-placement means that repeated calls to this function will
224 advance as follows:
225
226 - if the cursor is on a non-headline body line and not on the first column:
227 then it goes to the first column
228 - if the cursor is on the first column of a non-headline body line:
229 then it goes to the start of the headline within the item body
230 - if the cursor is on the headline and not the start of the headline:
231 then it goes to the start of the headline
232 - if the cursor is on the start of the headline:
233 then it goes to the bullet character \(for hotspot navigation\)
234 - if the cursor is on the bullet character:
235 then it goes to the first column of that line \(the headline\)
236 - if the cursor is on the first column of the headline:
237 then it goes to the start of the headline within the item body.
238
239 In this fashion, you can use the beginning-of-line command to do
240 its normal job and then, when repeated, advance through the
241 entry, cycling back to start.
242
243 If this configuration variable is nil, then the cursor is just
244 advanced to the beginning of the line and remains there on
245 repeated calls."
246 :type 'boolean :group 'allout)
247 ;;;_ = allout-end-of-line-cycles
248 (defcustom allout-end-of-line-cycles t
249 "*If non-nil, \\[allout-end-of-line] will cycle through smart-placement options.
250
251 Cycling only happens on when the command is repeated, not when it
252 follows a different command.
253
254 Smart-placement means that repeated calls to this function will
255 advance as follows:
256
257 - if the cursor is not on the end-of-line,
258 then it goes to the end-of-line
259 - if the cursor is on the end-of-line but not the end-of-entry,
260 then it goes to the end-of-entry, exposing it if necessary
261 - if the cursor is on the end-of-entry,
262 then it goes to the end of the head line
263
264 In this fashion, you can use the end-of-line command to do its
265 normal job and then, when repeated, advance through the entry,
266 cycling back to start.
267
268 If this configuration variable is nil, then the cursor is just
269 advanced to the end of the line and remains there on repeated
270 calls."
271 :type 'boolean :group 'allout)
272
216 ;;;_ = allout-header-prefix 273 ;;;_ = allout-header-prefix
217 (defcustom allout-header-prefix "." 274 (defcustom allout-header-prefix "."
275 ;; this string is treated as literal match. it will be `regexp-quote'd, so
276 ;; one cannot use regular expressions to match varying header prefixes.
218 "*Leading string which helps distinguish topic headers. 277 "*Leading string which helps distinguish topic headers.
219 278
220 Outline topic header lines are identified by a leading topic 279 Outline topic header lines are identified by a leading topic
221 header prefix, which mostly have the value of this var at their front. 280 header prefix, which mostly have the value of this var at their front.
222 \(Level 1 topics are exceptions. They consist of only a single 281 Level 1 topics are exceptions. They consist of only a single
223 character, which is typically set to the `allout-primary-bullet'. Many 282 character, which is typically set to the `allout-primary-bullet'."
224 outlines start at level 2 to avoid this discrepancy."
225 :type 'string 283 :type 'string
226 :group 'allout) 284 :group 'allout)
227 (make-variable-buffer-local 'allout-header-prefix) 285 (make-variable-buffer-local 'allout-header-prefix)
228 ;;;###autoload 286 ;;;###autoload
229 (put 'allout-header-prefix 'safe-local-variable 'stringp) 287 (put 'allout-header-prefix 'safe-local-variable 'stringp)
298 356
299 ;;;_ = allout-use-mode-specific-leader 357 ;;;_ = allout-use-mode-specific-leader
300 (defcustom allout-use-mode-specific-leader t 358 (defcustom allout-use-mode-specific-leader t
301 "*When non-nil, use mode-specific topic-header prefixes. 359 "*When non-nil, use mode-specific topic-header prefixes.
302 360
303 Allout outline mode will use the mode-specific `allout-mode-leaders' 361 Allout outline mode will use the mode-specific `allout-mode-leaders' or
304 and/or comment-start string, if any, to lead the topic prefix string, 362 comment-start string, if any, to lead the topic prefix string, so topic
305 so topic headers look like comments in the programming language. 363 headers look like comments in the programming language. It will also use
306 364 the comment-start string, with an '_' appended, for `allout-primary-bullet'.
307 String values are used as they stand. 365
366 String values are used as literals, not regular expressions, so
367 do not escape any regulare-expression characters.
308 368
309 Value t means to first check for assoc value in `allout-mode-leaders' 369 Value t means to first check for assoc value in `allout-mode-leaders'
310 alist, then use comment-start string, if any, then use default \(`.'). 370 alist, then use comment-start string, if any, then use default \(`.').
311 \(See note about use of comment-start strings, below.) 371 \(See note about use of comment-start strings, below.)
312 372
313 Set to the symbol for either of `allout-mode-leaders' or 373 Set to the symbol for either of `allout-mode-leaders' or
314 `comment-start' to use only one of them, respectively. 374 `comment-start' to use only one of them, respectively.
315 375
316 Value nil means to always use the default \(`.'). 376 Value nil means to always use the default \(`.') and leave
317 377 `allout-primary-bullet' unaltered.
318 comment-start strings that do not end in spaces are tripled, and an 378
319 `_' underscore is tacked on the end, to distinguish them from regular 379 comment-start strings that do not end in spaces are tripled in
320 comment strings. comment-start strings that do end in spaces are not 380 the header-prefix, and an `_' underscore is tacked on the end, to
321 tripled, but an underscore is substituted for the space. [This 381 distinguish them from regular comment strings. comment-start
322 presumes that the space is for appearance, not comment syntax. You 382 strings that do end in spaces are not tripled, but an underscore
323 can use `allout-mode-leaders' to override this behavior, when 383 is substituted for the space. [This presumes that the space is
324 incorrect.]" 384 for appearance, not comment syntax. You can use
385 `allout-mode-leaders' to override this behavior, when
386 undesired.]"
325 :type '(choice (const t) (const nil) string 387 :type '(choice (const t) (const nil) string
326 (const allout-mode-leaders) 388 (const allout-mode-leaders)
327 (const comment-start)) 389 (const comment-start))
328 :group 'allout) 390 :group 'allout)
329 ;;;###autoload 391 ;;;###autoload
332 (stringp x)))) 394 (stringp x))))
333 ;;;_ = allout-mode-leaders 395 ;;;_ = allout-mode-leaders
334 (defvar allout-mode-leaders '() 396 (defvar allout-mode-leaders '()
335 "Specific allout-prefix leading strings per major modes. 397 "Specific allout-prefix leading strings per major modes.
336 398
337 Entries will be used instead or in lieu of mode-specific 399 Use this if the mode's comment-start string isn't what you
338 comment-start strings. See also `allout-use-mode-specific-leader'. 400 prefer, or if the mode lacks a comment-start string. See
401 `allout-use-mode-specific-leader' for more details.
339 402
340 If you're constructing a string that will comment-out outline 403 If you're constructing a string that will comment-out outline
341 structuring so it can be included in program code, append an extra 404 structuring so it can be included in program code, append an extra
342 character, like an \"_\" underscore, to distinguish the lead string 405 character, like an \"_\" underscore, to distinguish the lead string
343 from regular comments that start at bol.") 406 from regular comments that start at the beginning-of-line.")
344 407
345 ;;;_ = allout-old-style-prefixes 408 ;;;_ = allout-old-style-prefixes
346 (defcustom allout-old-style-prefixes nil 409 (defcustom allout-old-style-prefixes nil
347 "*When non-nil, use only old-and-crusty `outline-mode' `*' topic prefixes. 410 "*When non-nil, use only old-and-crusty `outline-mode' `*' topic prefixes.
348 411
826 (setq header-lead (read-string 889 (setq header-lead (read-string
827 "String prefix for topic headers: "))) 890 "String prefix for topic headers: ")))
828 (setq allout-reindent-bodies nil) 891 (setq allout-reindent-bodies nil)
829 (allout-reset-header-lead header-lead) 892 (allout-reset-header-lead header-lead)
830 header-lead) 893 header-lead)
831 ;;;_ > allout-infer-header-lead () 894 ;;;_ > allout-infer-header-lead-and-primary-bullet ()
832 (defun allout-infer-header-lead () 895 (defun allout-infer-header-lead-and-primary-bullet ()
833 "Determine appropriate `allout-header-prefix'. 896 "Determine appropriate `allout-header-prefix' and `allout-primary-bullet'.
834 897
835 Works according to settings of: 898 Works according to settings of:
836 899
837 `comment-start' 900 `comment-start'
838 `allout-header-prefix' (default) 901 `allout-header-prefix' (default)
872 (concat comment-start comment-start comment-start)) 935 (concat comment-start comment-start comment-start))
873 ;; ... and append underscore, whichever: 936 ;; ... and append underscore, whichever:
874 "_"))))))) 937 "_")))))))
875 (if (not leader) 938 (if (not leader)
876 nil 939 nil
877 (if (string= leader allout-header-prefix) 940 (setq allout-header-prefix leader)
878 nil ; no change, nothing to do. 941 (if (not allout-old-style-prefixes)
879 (setq allout-header-prefix leader) 942 ;; setting allout-primary-bullet makes the top level topics use -
880 allout-header-prefix)))) 943 ;; actually, be - the special prefix:
944 (setq allout-primary-bullet leader))
945 allout-header-prefix)))
946 (defalias 'allout-infer-header-lead
947 'allout-infer-header-lead-and-primary-bullet)
881 ;;;_ > allout-infer-body-reindent () 948 ;;;_ > allout-infer-body-reindent ()
882 (defun allout-infer-body-reindent () 949 (defun allout-infer-body-reindent ()
883 "Determine proper setting for `allout-reindent-bodies'. 950 "Determine proper setting for `allout-reindent-bodies'.
884 951
885 Depends on default setting of `allout-reindent-bodies' \(which see) 952 Depends on default setting of `allout-reindent-bodies' \(which see)
928 ) 995 )
929 ;; Derive next for repeated use in allout-pending-bullet: 996 ;; Derive next for repeated use in allout-pending-bullet:
930 (setq allout-plain-bullets-string-len (length allout-plain-bullets-string)) 997 (setq allout-plain-bullets-string-len (length allout-plain-bullets-string))
931 (setq allout-header-subtraction (1- (length allout-header-prefix))) 998 (setq allout-header-subtraction (1- (length allout-header-prefix)))
932 ;; Produce the new allout-regexp: 999 ;; Produce the new allout-regexp:
933 (setq allout-regexp (concat "\\(\\" 1000 (setq allout-regexp (concat "\\("
934 allout-header-prefix 1001 (regexp-quote allout-header-prefix)
935 "[ \t]*[" 1002 "[ \t]*["
936 allout-bullets-string 1003 allout-bullets-string
937 "]\\)\\|\\" 1004 "]\\)\\|"
938 allout-primary-bullet 1005 (regexp-quote allout-primary-bullet)
939 "+\\|\^l")) 1006 "+\\|\^l"))
940 (setq allout-line-boundary-regexp 1007 (setq allout-line-boundary-regexp
941 (concat "\\(\n\\)\\(" allout-regexp "\\)")) 1008 (concat "\\(\n\\)\\(" allout-regexp "\\)"))
942 (setq allout-bob-regexp 1009 (setq allout-bob-regexp
943 (concat "\\(\\`\\)\\(" allout-regexp "\\)")) 1010 (concat "\\(\\`\\)\\(" allout-regexp "\\)"))
944 ) 1011 )
963 (append pref key-suff) 1030 (append pref key-suff)
964 key-suff)) 1031 key-suff))
965 (car (cdr cell))))))) 1032 (car (cdr cell)))))))
966 keymap-list) 1033 keymap-list)
967 map)) 1034 map))
968 ;;;_ = allout-prior-bindings - being deprecated.
969 (defvar allout-prior-bindings nil
970 "Variable for use in V18, with allout-added-bindings, for
971 resurrecting, on mode deactivation, bindings that existed before
972 activation. Being deprecated.")
973 ;;;_ = allout-added-bindings - being deprecated
974 (defvar allout-added-bindings nil
975 "Variable for use in V18, with allout-prior-bindings, for
976 resurrecting, on mode deactivation, bindings that existed before
977 activation. Being deprecated.")
978 ;;;_ : Menu bar 1035 ;;;_ : Menu bar
979 (defvar allout-mode-exposure-menu) 1036 (defvar allout-mode-exposure-menu)
980 (defvar allout-mode-editing-menu) 1037 (defvar allout-mode-editing-menu)
981 (defvar allout-mode-navigation-menu) 1038 (defvar allout-mode-navigation-menu)
982 (defvar allout-mode-misc-menu) 1039 (defvar allout-mode-misc-menu)
1048 1105
1049 See `allout-add-resumptions' and `allout-do-resumptions'.") 1106 See `allout-add-resumptions' and `allout-do-resumptions'.")
1050 (make-variable-buffer-local 'allout-mode-prior-settings) 1107 (make-variable-buffer-local 'allout-mode-prior-settings)
1051 ;;;_ > allout-add-resumptions (&rest pairs) 1108 ;;;_ > allout-add-resumptions (&rest pairs)
1052 (defun allout-add-resumptions (&rest pairs) 1109 (defun allout-add-resumptions (&rest pairs)
1053 "Set name/value pairs. 1110 "Set name/value PAIRS.
1054 1111
1055 Old settings are preserved for later resumption using `allout-do-resumptions'. 1112 Old settings are preserved for later resumption using `allout-do-resumptions'.
1056 1113
1114 The new values are set as a buffer local. On resumption, the prior buffer
1115 scope of the variable is restored along with its value. If it was a void
1116 buffer-local value, then it is left as nil on resumption.
1117
1057 The pairs are lists whose car is the name of the variable and car of the 1118 The pairs are lists whose car is the name of the variable and car of the
1058 cdr is the new value: '(some-var some-value)'. 1119 cdr is the new value: '(some-var some-value)'. The pairs can actually be
1059 1120 triples, where the third element qualifies the disposition of the setting,
1060 The new value is set as a buffer local. 1121 as described further below.
1061 1122
1062 If the variable was not previously buffer-local, then that is noted and the 1123 If the optional third element is the symbol 'extend, then the new value
1063 `allout-do-resumptions' will just `kill-local-variable' of that binding. 1124 created by `cons'ing the second element of the pair onto the front of the
1064 1125 existing value.
1065 If it previously was buffer-local, the old value is noted and resurrected 1126
1066 by `allout-do-resumptions'. \(If the local value was previously void, then 1127 If the optional third element is the symbol 'append, then the new value is
1067 it is left as nil on resumption.\) 1128 extended from the existing one by `append'ing a list containing the second
1129 element of the pair onto the end of the existing value.
1130
1131 Extension, and resumptions in general, should not be used for hook
1132 functions - use the 'local mode of `add-hook' for that, instead.
1068 1133
1069 The settings are stored on `allout-mode-prior-settings'." 1134 The settings are stored on `allout-mode-prior-settings'."
1070 (while pairs 1135 (while pairs
1071 (let* ((pair (pop pairs)) 1136 (let* ((pair (pop pairs))
1072 (name (car pair)) 1137 (name (car pair))
1073 (value (cadr pair))) 1138 (value (cadr pair))
1139 (qualifier (if (> (length pair) 2)
1140 (caddr pair)))
1141 prior-value)
1074 (if (not (symbolp name)) 1142 (if (not (symbolp name))
1075 (error "Pair's name, %S, must be a symbol, not %s" 1143 (error "Pair's name, %S, must be a symbol, not %s"
1076 name (type-of name))) 1144 name (type-of name)))
1145 (setq prior-value (condition-case err
1146 (symbol-value name)
1147 (void-variable nil)))
1077 (when (not (assoc name allout-mode-prior-settings)) 1148 (when (not (assoc name allout-mode-prior-settings))
1078 ;; Not already added as a resumption, create the prior setting entry. 1149 ;; Not already added as a resumption, create the prior setting entry.
1079 (if (local-variable-p name) 1150 (if (local-variable-p name)
1080 ;; is already local variable - preserve the prior value: 1151 ;; is already local variable - preserve the prior value:
1081 (push (list name (condition-case err 1152 (push (list name prior-value) allout-mode-prior-settings)
1082 (symbol-value name)
1083 (void-variable nil)))
1084 allout-mode-prior-settings)
1085 ;; wasn't local variable, indicate so for resumption by killing 1153 ;; wasn't local variable, indicate so for resumption by killing
1086 ;; local value, and make it local: 1154 ;; local value, and make it local:
1087 (push (list name) allout-mode-prior-settings) 1155 (push (list name) allout-mode-prior-settings)
1088 (make-local-variable name))) 1156 (make-local-variable name)))
1089 (set name value)))) 1157 (if qualifier
1158 (cond ((eq qualifier 'extend)
1159 (if (not (listp prior-value))
1160 (error "extension of non-list prior value attempted")
1161 (set name (cons value prior-value))))
1162 ((eq qualifier 'append)
1163 (if (not (listp prior-value))
1164 (error "appending of non-list prior value attempted")
1165 (set name (append prior-value (list value)))))
1166 (t (error "unrecognized setting qualifier `%s' encountered"
1167 qualifier)))
1168 (set name value)))))
1090 ;;;_ > allout-do-resumptions () 1169 ;;;_ > allout-do-resumptions ()
1091 (defun allout-do-resumptions () 1170 (defun allout-do-resumptions ()
1092 "Resume all name/value settings registered by `allout-add-resumptions'. 1171 "Resume all name/value settings registered by `allout-add-resumptions'.
1093 1172
1094 This is used when concluding allout-mode, to resume selected variables to 1173 This is used when concluding allout-mode, to resume selected variables to
1119 ;;;_ = allout-exposure-category 1198 ;;;_ = allout-exposure-category
1120 (defvar allout-exposure-category nil 1199 (defvar allout-exposure-category nil
1121 "Symbol for use as allout invisible-text overlay category.") 1200 "Symbol for use as allout invisible-text overlay category.")
1122 ;;;_ x allout-view-change-hook 1201 ;;;_ x allout-view-change-hook
1123 (defvar allout-view-change-hook nil 1202 (defvar allout-view-change-hook nil
1124 "*\(Deprecated\) Hook that's run after allout outline exposure changes. 1203 "*\(Deprecated\) A hook run after allout outline exposure changes.
1125 1204
1126 Switch to using `allout-exposure-change-hook' instead. Both 1205 Switch to using `allout-exposure-change-hook' instead. Both hooks are
1127 variables are currently respected, but this one will be ignored 1206 currently respected, but the other conveys the details of the exposure
1128 in a subsequent allout version.") 1207 change via explicit parameters, and this one will eventually be disabled in
1208 a subsequent allout version.")
1129 ;;;_ = allout-exposure-change-hook 1209 ;;;_ = allout-exposure-change-hook
1130 (defvar allout-exposure-change-hook nil 1210 (defvar allout-exposure-change-hook nil
1131 "*Hook that's run after allout outline exposure changes. 1211 "*Hook that's run after allout outline subtree exposure changes.
1132 1212
1133 This variable will replace `allout-view-change-hook' in a subsequent allout 1213 It is run at the conclusion of `allout-flag-region'.
1134 version, though both are currently respected.") 1214
1135 1215 Functions on the hook must take three arguments:
1216
1217 - from - integer indicating the point at the start of the change.
1218 - to - integer indicating the point of the end of the change.
1219 - flag - change mode: nil for exposure, otherwise concealment.
1220
1221 This hook might be invoked multiple times by a single command.
1222
1223 This hook is replacing `allout-view-change-hook', which is being deprecated
1224 and eventually will not be invoked.")
1225 ;;;_ = allout-structure-added-hook
1226 (defvar allout-structure-added-hook nil
1227 "*Hook that's run after addition of items to the outline.
1228
1229 Functions on the hook should take two arguments:
1230
1231 - new-start - integer indicating the point at the start of the first new item.
1232 - new-end - integer indicating the point of the end of the last new item.
1233
1234 Some edits that introduce new items may missed by this hook -
1235 specifically edits that native allout routines do not control.
1236
1237 This hook might be invoked multiple times by a single command.")
1238 ;;;_ = allout-structure-deleted-hook
1239 (defvar allout-structure-deleted-hook nil
1240 "*Hook that's run after disciplined deletion of subtrees from the outline.
1241
1242 Functions on the hook must take two arguments:
1243
1244 - depth - integer indicating the depth of the subtree that was deleted.
1245 - removed-from - integer indicating the point where the subtree was removed.
1246
1247 Some edits that remove or invalidate items may missed by this hook -
1248 specifically edits that native allout routines do not control.
1249
1250 This hook might be invoked multiple times by a single command.")
1251 ;;;_ = allout-structure-shifted-hook
1252 (defvar allout-structure-shifted-hook nil
1253 "*Hook that's run after shifting of items in the outline.
1254
1255 Functions on the hook should take two arguments:
1256
1257 - depth-change - integer indicating depth increase, negative for decrease
1258 - start - integer indicating the start point of the shifted parent item.
1259
1260 Some edits that shift items can be missed by this hook - specifically edits
1261 that native allout routines do not control.
1262
1263 This hook might be invoked multiple times by a single command.")
1136 ;;;_ = allout-outside-normal-auto-fill-function 1264 ;;;_ = allout-outside-normal-auto-fill-function
1137 (defvar allout-outside-normal-auto-fill-function nil 1265 (defvar allout-outside-normal-auto-fill-function nil
1138 "Value of normal-auto-fill-function outside of allout mode. 1266 "Value of normal-auto-fill-function outside of allout mode.
1139 1267
1140 Used by allout-auto-fill to do the mandated normal-auto-fill-function 1268 Used by allout-auto-fill to do the mandated normal-auto-fill-function
1184 - where to situate the cursor after the decryption is performed 1312 - where to situate the cursor after the decryption is performed
1185 1313
1186 This is used to decrypt the topic that was currently being edited, if it 1314 This is used to decrypt the topic that was currently being edited, if it
1187 was encrypted automatically as part of a file write or autosave.") 1315 was encrypted automatically as part of a file write or autosave.")
1188 (make-variable-buffer-local 'allout-after-save-decrypt) 1316 (make-variable-buffer-local 'allout-after-save-decrypt)
1317 ;;;_ = allout-encryption-plaintext-sanitization-regexps
1318 (defvar allout-encryption-plaintext-sanitization-regexps nil
1319 "List of regexps whose matches are removed from plaintext before encryption.
1320
1321 This is for the sake of removing artifacts, like escapes, that are added on
1322 and not actually part of the original plaintext. The removal is done just
1323 prior to encryption.
1324
1325 Entries must be symbols that are bound to the desired values.
1326
1327 Each value can be a regexp or a list with a regexp followed by a
1328 substitution string. If it's just a regexp, all its matches are removed
1329 before the text is encrypted. If it's a regexp and a substitution, the
1330 substition is used against the regexp matches, a la `replace-match'.")
1331 (make-variable-buffer-local 'allout-encryption-text-removal-regexps)
1332 ;;;_ = allout-encryption-ciphertext-rejection-regexps
1333 (defvar allout-encryption-ciphertext-rejection-regexps nil
1334 "Variable for regexps matching plaintext to remove before encryption.
1335
1336 This is for the sake of redoing encryption in cases where the ciphertext
1337 incidentally contains strings that would disrupt mode operation -
1338 for example, a line that happens to look like an allout-mode topic prefix.
1339
1340 Entries must be symbols that are bound to the desired regexp values.
1341
1342 The encryption will be retried up to
1343 `allout-encryption-ciphertext-rejection-limit' times, after which an error
1344 is raised.")
1345
1346 (make-variable-buffer-local 'allout-encryption-ciphertext-rejection-regexps)
1347 ;;;_ = allout-encryption-ciphertext-rejection-ceiling
1348 (defvar allout-encryption-ciphertext-rejection-ceiling 5
1349 "Limit on number of times encryption ciphertext is rejected.
1350
1351 See `allout-encryption-ciphertext-rejection-regexps' for rejection reasons.")
1352 (make-variable-buffer-local 'allout-encryption-ciphertext-rejection-ceiling)
1189 ;;;_ > allout-mode-p () 1353 ;;;_ > allout-mode-p ()
1190 ;; Must define this macro above any uses, or byte compilation will lack 1354 ;; Must define this macro above any uses, or byte compilation will lack
1191 ;; proper def, if file isn't loaded - eg, during emacs build! 1355 ;; proper def, if file isn't loaded - eg, during emacs build!
1192 (defmacro allout-mode-p () 1356 (defmacro allout-mode-p ()
1193 "Return t if `allout-mode' is active in current buffer." 1357 "Return t if `allout-mode' is active in current buffer."
1635 (remove-hook 'auto-save-hook 'allout-auto-save-hook-handler t) 1799 (remove-hook 'auto-save-hook 'allout-auto-save-hook-handler t)
1636 1800
1637 (remove-overlays (point-min) (point-max) 1801 (remove-overlays (point-min) (point-max)
1638 'category 'allout-exposure-category) 1802 'category 'allout-exposure-category)
1639 1803
1640 (run-hooks 'allout-mode-deactivate-hook) 1804 (setq allout-mode nil)
1641 (setq allout-mode nil)) 1805 (run-hooks 'allout-mode-deactivate-hook))
1642 1806
1643 ;; Activation: 1807 ;; Activation:
1644 ((not active) 1808 ((not active)
1645 (setq allout-explicitly-deactivated nil) 1809 (setq allout-explicitly-deactivated nil)
1646 (if allout-old-style-prefixes 1810 (if allout-old-style-prefixes
1647 ;; Inhibit all the fancy formatting: 1811 ;; Inhibit all the fancy formatting:
1648 (allout-add-resumptions '((allout-primary-bullet "*") 1812 (allout-add-resumptions '(allout-primary-bullet "*")))
1649 (allout-old-style-prefixes ()))))
1650 1813
1651 (allout-overlay-preparations) ; Doesn't hurt to redo this. 1814 (allout-overlay-preparations) ; Doesn't hurt to redo this.
1652 1815
1653 (allout-infer-header-lead) 1816 (allout-infer-header-lead)
1654 (allout-infer-body-reindent) 1817 (allout-infer-body-reindent)
1655 1818
1656 (set-allout-regexp) 1819 (set-allout-regexp)
1820 (allout-add-resumptions
1821 '(allout-encryption-ciphertext-rejection-regexps
1822 allout-line-boundary-regexp
1823 extend)
1824 '(allout-encryption-ciphertext-rejection-regexps
1825 allout-bob-regexp
1826 extend))
1657 1827
1658 ;; Produce map from current version of allout-keybindings-list: 1828 ;; Produce map from current version of allout-keybindings-list:
1659 (setq allout-mode-map 1829 (setq allout-mode-map
1660 (produce-allout-mode-map allout-keybindings-list)) 1830 (produce-allout-mode-map allout-keybindings-list))
1661 (substitute-key-definition 'beginning-of-line 1831 (substitute-key-definition 'beginning-of-line
1662 'move-beginning-of-line 1832 'allout-beginning-of-line
1833 allout-mode-map global-map)
1834 (substitute-key-definition 'move-beginning-of-line
1835 'allout-beginning-of-line
1663 allout-mode-map global-map) 1836 allout-mode-map global-map)
1664 (substitute-key-definition 'end-of-line 1837 (substitute-key-definition 'end-of-line
1665 'move-end-of-line 1838 'allout-end-of-line
1839 allout-mode-map global-map)
1840 (substitute-key-definition 'move-end-of-line
1841 'allout-end-of-line
1666 allout-mode-map global-map) 1842 allout-mode-map global-map)
1667 (produce-allout-mode-menubar-entries) 1843 (produce-allout-mode-menubar-entries)
1668 (fset 'allout-mode-map allout-mode-map) 1844 (fset 'allout-mode-map allout-mode-map)
1669 1845
1670 ;; Include on minor-mode-map-alist, if not already there: 1846 ;; Include on minor-mode-map-alist, if not already there:
1715 (allout-setup-menubar) 1891 (allout-setup-menubar)
1716 1892
1717 (if allout-layout 1893 (if allout-layout
1718 (setq do-layout t)) 1894 (setq do-layout t))
1719 1895
1720 (run-hooks 'allout-mode-hook) 1896 (setq allout-mode t)
1721 (setq allout-mode t)) 1897 (run-hooks 'allout-mode-hook))
1722 1898
1723 ;; Reactivation: 1899 ;; Reactivation:
1724 ((setq do-layout t) 1900 ((setq do-layout t)
1725 (allout-infer-body-reindent)) 1901 (allout-infer-body-reindent))
1726 ) ;; end of activation-mode cases. 1902 ) ;; end of activation-mode cases.
2042 (let ((inhibit-field-text-motion t)) 2218 (let ((inhibit-field-text-motion t))
2043 (end-of-line) 2219 (end-of-line)
2044 (while (allout-hidden-p) 2220 (while (allout-hidden-p)
2045 (end-of-line) 2221 (end-of-line)
2046 (if (allout-hidden-p) (forward-char 1))))) 2222 (if (allout-hidden-p) (forward-char 1)))))
2223 ;;;_ > allout-beginning-of-line ()
2224 (defun allout-beginning-of-line ()
2225 "Beginning-of-line with `allout-beginning-of-line-cycles' behavior, if set."
2226
2227 (interactive)
2228
2229 (if (or (not allout-beginning-of-line-cycles)
2230 (not (equal last-command this-command)))
2231 (move-beginning-of-line 1)
2232 (let ((beginning-of-body (save-excursion
2233 (allout-beginning-of-current-entry)
2234 (point))))
2235 (cond ((= (current-column) 0)
2236 (allout-beginning-of-current-entry))
2237 ((< (point) beginning-of-body)
2238 (allout-beginning-of-current-line))
2239 ((= (point) beginning-of-body)
2240 (goto-char (allout-current-bullet-pos)))
2241 (t (allout-beginning-of-current-line)
2242 (if (< (point) beginning-of-body)
2243 ;; we were on the headline after its start:
2244 (allout-beginning-of-current-entry)))))))
2245 ;;;_ > allout-end-of-line ()
2246 (defun allout-end-of-line ()
2247 "End-of-line with `allout-end-of-line-cycles' behavior, if set."
2248
2249 (interactive)
2250
2251 (if (or (not allout-end-of-line-cycles)
2252 (not (equal last-command this-command)))
2253 (allout-end-of-current-line)
2254 (let ((end-of-entry (save-excursion
2255 (allout-end-of-entry)
2256 (point))))
2257 (cond ((not (eolp))
2258 (allout-end-of-current-line))
2259 ((or (allout-hidden-p) (save-excursion
2260 (forward-char -1)
2261 (allout-hidden-p)))
2262 (allout-back-to-current-heading)
2263 (allout-show-current-entry)
2264 (allout-end-of-entry))
2265 ((>= (point) end-of-entry)
2266 (allout-back-to-current-heading)
2267 (allout-end-of-current-line))
2268 (t (allout-end-of-entry))))))
2047 ;;;_ > allout-next-heading () 2269 ;;;_ > allout-next-heading ()
2048 (defsubst allout-next-heading () 2270 (defsubst allout-next-heading ()
2049 "Move to the heading for the topic \(possibly invisible) after this one. 2271 "Move to the heading for the topic \(possibly invisible) after this one.
2050 2272
2051 Returns the location of the heading, or nil if none found." 2273 Returns the location of the heading, or nil if none found."
2106 ;;; requiring only a single regexp-search based traversal, to scope 2328 ;;; requiring only a single regexp-search based traversal, to scope
2107 ;;; out the subtopic locations. The chart then serves as the basis 2329 ;;; out the subtopic locations. The chart then serves as the basis
2108 ;;; for assessment or adjustment of the subtree, without redundant 2330 ;;; for assessment or adjustment of the subtree, without redundant
2109 ;;; traversal of the structure. 2331 ;;; traversal of the structure.
2110 2332
2111 ;;;_ > allout-chart-subtree (&optional levels orig-depth prev-depth) 2333 ;;;_ > allout-chart-subtree (&optional levels visible orig-depth prev-depth)
2112 (defun allout-chart-subtree (&optional levels orig-depth prev-depth) 2334 (defun allout-chart-subtree (&optional levels visible orig-depth prev-depth)
2113 "Produce a location \"chart\" of subtopics of the containing topic. 2335 "Produce a location \"chart\" of subtopics of the containing topic.
2114 2336
2115 Optional argument LEVELS specifies the depth \(relative to start 2337 Optional argument LEVELS specifies the depth \(relative to start
2116 depth) for the chart. Subsequent optional args are not for public 2338 depth) for the chart.
2117 use. 2339
2340 When optional argument VISIBLE is non-nil, the chart includes
2341 only the visible subelements of the charted subjects.
2342
2343 The remaining optional args are not for internal use by the function.
2118 2344
2119 Point is left at the end of the subtree. 2345 Point is left at the end of the subtree.
2120 2346
2121 Charts are used to capture outline structure, so that outline-altering 2347 Charts are used to capture outline structure, so that outline-altering
2122 routines need assess the structure only once, and then use the chart 2348 routines need assess the structure only once, and then use the chart
2139 (if original ; Just starting? 2365 (if original ; Just starting?
2140 ; Register initial settings and 2366 ; Register initial settings and
2141 ; position to first offspring: 2367 ; position to first offspring:
2142 (progn (setq orig-depth (allout-depth)) 2368 (progn (setq orig-depth (allout-depth))
2143 (or prev-depth (setq prev-depth (1+ orig-depth))) 2369 (or prev-depth (setq prev-depth (1+ orig-depth)))
2144 (allout-next-heading))) 2370 (if visible
2371 (allout-next-visible-heading 1)
2372 (allout-next-heading))))
2145 2373
2146 ;; Loop over the current levels' siblings. Besides being more 2374 ;; Loop over the current levels' siblings. Besides being more
2147 ;; efficient than tail-recursing over a level, it avoids exceeding 2375 ;; efficient than tail-recursing over a level, it avoids exceeding
2148 ;; the typically quite constrained Emacs max-lisp-eval-depth. 2376 ;; the typically quite constrained Emacs max-lisp-eval-depth.
2149 ;; 2377 ;;
2161 (or (allout-next-sibling curr-depth) 2389 (or (allout-next-sibling curr-depth)
2162 ;; or no more siblings - proceed to 2390 ;; or no more siblings - proceed to
2163 ;; next heading at lesser depth: 2391 ;; next heading at lesser depth:
2164 (while (and (<= curr-depth 2392 (while (and (<= curr-depth
2165 (allout-recent-depth)) 2393 (allout-recent-depth))
2166 (allout-next-heading)))) 2394 (if visible
2167 (allout-next-heading))) 2395 (allout-next-visible-heading 1)
2396 (allout-next-heading)))))
2397 (if visible
2398 (allout-next-visible-heading 1)
2399 (allout-next-heading))))
2168 2400
2169 ((and (< prev-depth curr-depth) 2401 ((and (< prev-depth curr-depth)
2170 (or (not levels) 2402 (or (not levels)
2171 (> levels 0))) 2403 (> levels 0)))
2172 ;; Recurse on deeper level of curr topic: 2404 ;; Recurse on deeper level of curr topic:
2173 (setq chart 2405 (setq chart
2174 (cons (allout-chart-subtree (and levels 2406 (cons (allout-chart-subtree (and levels
2175 (1- levels)) 2407 (1- levels))
2176 orig-depth 2408 visible
2177 curr-depth) 2409 orig-depth
2410 curr-depth)
2178 chart)) 2411 chart))
2179 ;; ... then continue with this one. 2412 ;; ... then continue with this one.
2180 ) 2413 )
2181 2414
2182 ;; ... else nil if we've ascended back to prev-depth. 2415 ;; ... else nil if we've ascended back to prev-depth.
2367 (let ((level (allout-recent-depth))) 2600 (let ((level (allout-recent-depth)))
2368 (allout-next-heading) 2601 (allout-next-heading)
2369 (while (and (not (eobp)) 2602 (while (and (not (eobp))
2370 (> (allout-recent-depth) level)) 2603 (> (allout-recent-depth) level))
2371 (allout-next-heading)) 2604 (allout-next-heading))
2372 (and (not (eobp)) (forward-char -1)) 2605 (if (eobp)
2606 (allout-end-of-entry)
2607 (forward-char -1))
2373 (if (and (not include-trailing-blank) (= ?\n (preceding-char))) 2608 (if (and (not include-trailing-blank) (= ?\n (preceding-char)))
2374 (forward-char -1)) 2609 (forward-char -1))
2375 (setq allout-recent-end-of-subtree (point)))) 2610 (setq allout-recent-end-of-subtree (point))))
2376 ;;;_ > allout-end-of-current-subtree (&optional include-trailing-blank) 2611 ;;;_ > allout-end-of-current-subtree (&optional include-trailing-blank)
2377 (defun allout-end-of-current-subtree (&optional include-trailing-blank) 2612 (defun allout-end-of-current-subtree (&optional include-trailing-blank)
2673 then unset it. Set by `allout-pre-command-business' when implementing 2908 then unset it. Set by `allout-pre-command-business' when implementing
2674 hot-spot operation, where literal characters typed over a topic bullet 2909 hot-spot operation, where literal characters typed over a topic bullet
2675 are mapped to the command of the corresponding control-key on the 2910 are mapped to the command of the corresponding control-key on the
2676 `allout-mode-map'.") 2911 `allout-mode-map'.")
2677 (make-variable-buffer-local 'allout-post-goto-bullet) 2912 (make-variable-buffer-local 'allout-post-goto-bullet)
2913 ;;;_ = allout-command-counter
2914 (defvar allout-command-counter 0
2915 "Counter that monotonically increases in allout-mode buffers.
2916
2917 Set by `allout-pre-command-business', to support allout addons in
2918 coordinating with allout activity.")
2919 (make-variable-buffer-local 'allout-command-counter)
2678 ;;;_ > allout-post-command-business () 2920 ;;;_ > allout-post-command-business ()
2679 (defun allout-post-command-business () 2921 (defun allout-post-command-business ()
2680 "Outline `post-command-hook' function. 2922 "Outline `post-command-hook' function.
2681 2923
2682 - Implement (and clear) `allout-post-goto-bullet', for hot-spot 2924 - Implement (and clear) `allout-post-goto-bullet', for hot-spot
2690 2932
2691 (if (and (boundp 'allout-after-save-decrypt) 2933 (if (and (boundp 'allout-after-save-decrypt)
2692 allout-after-save-decrypt) 2934 allout-after-save-decrypt)
2693 (allout-after-saves-handler)) 2935 (allout-after-saves-handler))
2694 2936
2695 ;; Implement -post-goto-bullet, if set: 2937 ;; Implement allout-post-goto-bullet, if set:
2696 (if (and allout-post-goto-bullet 2938 (if (and allout-post-goto-bullet
2697 (allout-current-bullet-pos)) 2939 (allout-current-bullet-pos))
2698 (progn (goto-char (allout-current-bullet-pos)) 2940 (progn (goto-char (allout-current-bullet-pos))
2699 (setq allout-post-goto-bullet nil))) 2941 (setq allout-post-goto-bullet nil)))
2700 )) 2942 ))
2701 ;;;_ > allout-pre-command-business () 2943 ;;;_ > allout-pre-command-business ()
2702 (defun allout-pre-command-business () 2944 (defun allout-pre-command-business ()
2703 "Outline `pre-command-hook' function for outline buffers. 2945 "Outline `pre-command-hook' function for outline buffers.
2704 Implements special behavior when cursor is on bullet character. 2946
2947 Among other things, implements special behavior when the cursor is on the
2948 topic bullet character.
2705 2949
2706 When the cursor is on the bullet character, self-insert characters are 2950 When the cursor is on the bullet character, self-insert characters are
2707 reinterpreted as the corresponding control-character in the 2951 reinterpreted as the corresponding control-character in the
2708 `allout-mode-map'. The `allout-mode' `post-command-hook' insures that 2952 `allout-mode-map'. The `allout-mode' `post-command-hook' insures that
2709 the cursor which has moved as a result of such reinterpretation is 2953 the cursor which has moved as a result of such reinterpretation is
2710 positioned on the bullet character of the destination topic. 2954 positioned on the bullet character of the destination topic.
2711 2955
2712 The upshot is that you can get easy, single (ie, unmodified) key 2956 The upshot is that you can get easy, single \(ie, unmodified\) key
2713 outline maneuvering operations by positioning the cursor on the bullet 2957 outline maneuvering operations by positioning the cursor on the bullet
2714 char. When in this mode you can use regular cursor-positioning 2958 char. When in this mode you can use regular cursor-positioning
2715 command/keystrokes to relocate the cursor off of a bullet character to 2959 command/keystrokes to relocate the cursor off of a bullet character to
2716 return to regular interpretation of self-insert characters." 2960 return to regular interpretation of self-insert characters."
2717 2961
2718 (if (not (allout-mode-p)) 2962 (if (not (allout-mode-p))
2719 nil 2963 nil
2964 ;; Increment allout-command-counter
2965 (setq allout-command-counter (1+ allout-command-counter))
2966 ;; Do hot-spot navigation.
2720 (if (and (eq this-command 'self-insert-command) 2967 (if (and (eq this-command 'self-insert-command)
2721 (eq (point)(allout-current-bullet-pos))) 2968 (eq (point)(allout-current-bullet-pos)))
2722 (allout-hotspot-key-handler)))) 2969 (allout-hotspot-key-handler))))
2723 ;;;_ > allout-hotspot-key-handler () 2970 ;;;_ > allout-hotspot-key-handler ()
2724 (defun allout-hotspot-key-handler () 2971 (defun allout-hotspot-key-handler ()
2988 are hidden. \(The intervening offspring will be exposed in the latter 3235 are hidden. \(The intervening offspring will be exposed in the latter
2989 case.) 3236 case.)
2990 3237
2991 If OFFER-RECENT-BULLET is true, offer to use the bullet of the prior sibling. 3238 If OFFER-RECENT-BULLET is true, offer to use the bullet of the prior sibling.
2992 3239
3240 Runs
3241
2993 Nuances: 3242 Nuances:
2994 3243
2995 - Creation of new topics is with respect to the visible topic 3244 - Creation of new topics is with respect to the visible topic
2996 containing the cursor, regardless of intervening concealed ones. 3245 containing the cursor, regardless of intervening concealed ones.
2997 3246
3038 (allout-descend-to-depth depth)) 3287 (allout-descend-to-depth depth))
3039 (if (allout-numbered-type-prefix) 3288 (if (allout-numbered-type-prefix)
3040 allout-numbered-bullet)))) 3289 allout-numbered-bullet))))
3041 (point))) 3290 (point)))
3042 dbl-space 3291 dbl-space
3043 doing-beginning) 3292 doing-beginning
3293 start end)
3044 3294
3045 (if (not opening-on-blank) 3295 (if (not opening-on-blank)
3046 ; Positioning and vertical 3296 ; Positioning and vertical
3047 ; padding - only if not 3297 ; padding - only if not
3048 ; opening-on-blank: 3298 ; opening-on-blank:
3139 (newline 1)) 3389 (newline 1))
3140 (if (and (not (eobp)) 3390 (if (and (not (eobp))
3141 (not (bolp))) 3391 (not (bolp)))
3142 (forward-char 1)))) 3392 (forward-char 1))))
3143 )) 3393 ))
3394 (setq start (point))
3144 (insert (concat (allout-make-topic-prefix opening-numbered t depth) 3395 (insert (concat (allout-make-topic-prefix opening-numbered t depth)
3145 " ")) 3396 " "))
3397 (setq end (1+ (point)))
3146 3398
3147 (allout-rebullet-heading (and offer-recent-bullet ref-bullet) 3399 (allout-rebullet-heading (and offer-recent-bullet ref-bullet)
3148 depth nil nil t) 3400 depth nil nil t)
3149 (if (> relative-depth 0) 3401 (if (> relative-depth 0)
3150 (save-excursion (goto-char ref-topic) 3402 (save-excursion (goto-char ref-topic)
3151 (allout-show-children))) 3403 (allout-show-children)))
3152 (end-of-line) 3404 (end-of-line)
3405
3406 (run-hook-with-args 'allout-structure-added-hook start end)
3153 ) 3407 )
3154 ) 3408 )
3155 ;;;_ > allout-open-subtopic (arg) 3409 ;;;_ > allout-open-subtopic (arg)
3156 (defun allout-open-subtopic (arg) 3410 (defun allout-open-subtopic (arg)
3157 "Open new topic header at deeper level than the current one. 3411 "Open new topic header at deeper level than the current one.
3546 one level greater than the immediately previous topic, to avoid containment 3800 one level greater than the immediately previous topic, to avoid containment
3547 discontinuity. The first topic in the file can be adjusted to any positive 3801 discontinuity. The first topic in the file can be adjusted to any positive
3548 depth, however." 3802 depth, however."
3549 (interactive "p") 3803 (interactive "p")
3550 (if (> arg 0) 3804 (if (> arg 0)
3805 ;; refuse to create a containment discontinuity:
3551 (save-excursion 3806 (save-excursion
3552 (allout-back-to-current-heading) 3807 (allout-back-to-current-heading)
3553 (if (not (bobp)) 3808 (if (not (bobp))
3554 (let* ((current-depth (allout-recent-depth)) 3809 (let* ((current-depth (allout-recent-depth))
3555 (start-point (point)) 3810 (start-point (point))
3562 (if (and (> predecessor-depth 0) 3817 (if (and (> predecessor-depth 0)
3563 (> (+ current-depth arg) 3818 (> (+ current-depth arg)
3564 (1+ predecessor-depth))) 3819 (1+ predecessor-depth)))
3565 (error (concat "Disallowed shift deeper than" 3820 (error (concat "Disallowed shift deeper than"
3566 " containing topic's children."))))))) 3821 " containing topic's children.")))))))
3567 (allout-rebullet-topic arg)) 3822 (let ((where (point))
3823 has-successor)
3824 (if (and (< arg 0)
3825 (allout-current-topic-collapsed-p)
3826 (save-excursion (allout-next-sibling)))
3827 (setq has-successor t))
3828 (allout-rebullet-topic arg)
3829 (when (< arg 0)
3830 (save-excursion
3831 (if (allout-ascend)
3832 (allout-show-children)))
3833 (if has-successor
3834 (allout-show-children)))
3835 (run-hook-with-args 'allout-structure-shifted-hook arg where)))
3568 ;;;_ > allout-shift-out (arg) 3836 ;;;_ > allout-shift-out (arg)
3569 (defun allout-shift-out (arg) 3837 (defun allout-shift-out (arg)
3570 "Decrease depth of current heading and any topics collapsed within it. 3838 "Decrease depth of current heading and any topics collapsed within it.
3571 3839
3572 We disallow shifts that would result in the topic having a depth more than 3840 We disallow shifts that would result in the topic having a depth more than
3573 one level greater than the immediately previous topic, to avoid containment 3841 one level greater than the immediately previous topic, to avoid containment
3574 discontinuity. The first topic in the file can be adjusted to any positive 3842 discontinuity. The first topic in the file can be adjusted to any positive
3575 depth, however." 3843 depth, however."
3576 (interactive "p") 3844 (interactive "p")
3577 (if (< arg 0) 3845 (allout-shift-in (* arg -1)))
3578 (allout-shift-in (* arg -1)))
3579 (allout-rebullet-topic (* arg -1)))
3580 ;;;_ : Surgery (kill-ring) functions with special provisions for outlines: 3846 ;;;_ : Surgery (kill-ring) functions with special provisions for outlines:
3581 ;;;_ > allout-kill-line (&optional arg) 3847 ;;;_ > allout-kill-line (&optional arg)
3582 (defun allout-kill-line (&optional arg) 3848 (defun allout-kill-line (&optional arg)
3583 "Kill line, adjusting subsequent lines suitably for outline mode." 3849 "Kill line, adjusting subsequent lines suitably for outline mode."
3584 3850
3608 (sit-for 0) 3874 (sit-for 0)
3609 (if allout-numbered-bullet 3875 (if allout-numbered-bullet
3610 (save-excursion ; Renumber subsequent topics if needed: 3876 (save-excursion ; Renumber subsequent topics if needed:
3611 (if (not (looking-at allout-regexp)) 3877 (if (not (looking-at allout-regexp))
3612 (allout-next-heading)) 3878 (allout-next-heading))
3613 (allout-renumber-to-depth depth)))))) 3879 (allout-renumber-to-depth depth)))
3880 (run-hook-with-args 'allout-structure-deleted-hook depth (point)))))
3614 ;;;_ > allout-kill-topic () 3881 ;;;_ > allout-kill-topic ()
3615 (defun allout-kill-topic () 3882 (defun allout-kill-topic ()
3616 "Kill topic together with subtopics. 3883 "Kill topic together with subtopics.
3617 3884
3618 Trailing whitespace is killed with a topic if that whitespace: 3885 Trailing whitespace is killed with a topic if that whitespace:
3654 (allout-unprotected 3921 (allout-unprotected
3655 (remove-text-properties beg (1+ beg) '(allout-was-collapsed t)))) 3922 (remove-text-properties beg (1+ beg) '(allout-was-collapsed t))))
3656 (allout-unprotected (kill-region beg (point))) 3923 (allout-unprotected (kill-region beg (point)))
3657 (sit-for 0) 3924 (sit-for 0)
3658 (save-excursion 3925 (save-excursion
3659 (allout-renumber-to-depth depth)))) 3926 (allout-renumber-to-depth depth))
3927 (run-hook-with-args 'allout-structure-deleted-hook depth (point))))
3660 ;;;_ > allout-yank-processing () 3928 ;;;_ > allout-yank-processing ()
3661 (defun allout-yank-processing (&optional arg) 3929 (defun allout-yank-processing (&optional arg)
3662 3930
3663 "Incidental allout-specific business to be done just after text yanks. 3931 "Incidental allout-specific business to be done just after text yanks.
3664 3932
3681 (interactive "*P") 3949 (interactive "*P")
3682 ; Get to beginning, leaving 3950 ; Get to beginning, leaving
3683 ; region around subject: 3951 ; region around subject:
3684 (if (< (allout-mark-marker t) (point)) 3952 (if (< (allout-mark-marker t) (point))
3685 (exchange-point-and-mark)) 3953 (exchange-point-and-mark))
3686 (let* ((inhibit-field-text-motion t) 3954 (allout-unprotected
3687 (subj-beg (point)) 3955 (let* ((subj-beg (point))
3688 (into-bol (bolp)) 3956 (into-bol (bolp))
3689 (subj-end (allout-mark-marker t)) 3957 (subj-end (allout-mark-marker t))
3690 (was-collapsed (get-text-property subj-beg 'allout-was-collapsed)) 3958 (was-collapsed (get-text-property subj-beg 'allout-was-collapsed))
3691 ;; 'resituate' if yanking an entire topic into topic header: 3959 ;; 'resituate' if yanking an entire topic into topic header:
3692 (resituate (and (allout-e-o-prefix-p) 3960 (resituate (and (allout-e-o-prefix-p)
3693 (looking-at (concat "\\(" allout-regexp "\\)")) 3961 (looking-at (concat "\\(" allout-regexp "\\)"))
3694 (allout-prefix-data (match-beginning 1) 3962 (allout-prefix-data (match-beginning 1)
3695 (match-end 1)))) 3963 (match-end 1))))
3696 ;; `rectify-numbering' if resituating (where several topics may 3964 ;; `rectify-numbering' if resituating (where several topics may
3697 ;; be resituating) or yanking a topic into a topic slot (bol): 3965 ;; be resituating) or yanking a topic into a topic slot (bol):
3698 (rectify-numbering (or resituate 3966 (rectify-numbering (or resituate
3699 (and into-bol (looking-at allout-regexp))))) 3967 (and into-bol (looking-at allout-regexp)))))
3700 (if resituate 3968 (if resituate
3701 ; The yanked stuff is a topic: 3969 ; The yanked stuff is a topic:
3702 (let* ((prefix-len (- (match-end 1) subj-beg)) 3970 (let* ((prefix-len (- (match-end 1) subj-beg))
3703 (subj-depth (allout-recent-depth)) 3971 (subj-depth (allout-recent-depth))
3704 (prefix-bullet (allout-recent-bullet)) 3972 (prefix-bullet (allout-recent-bullet))
3705 (adjust-to-depth 3973 (adjust-to-depth
3706 ;; Nil if adjustment unnecessary, otherwise depth to which 3974 ;; Nil if adjustment unnecessary, otherwise depth to which
3707 ;; adjustment should be made: 3975 ;; adjustment should be made:
3708 (save-excursion 3976 (save-excursion
3709 (and (goto-char subj-end) 3977 (and (goto-char subj-end)
3710 (eolp) 3978 (eolp)
3711 (goto-char subj-beg) 3979 (goto-char subj-beg)
3712 (and (looking-at allout-regexp) 3980 (and (looking-at allout-regexp)
3713 (progn 3981 (progn
3714 (beginning-of-line) 3982 (beginning-of-line)
3715 (not (= (point) subj-beg))) 3983 (not (= (point) subj-beg)))
3716 (looking-at allout-regexp) 3984 (looking-at allout-regexp)
3717 (allout-prefix-data (match-beginning 0) 3985 (allout-prefix-data (match-beginning 0)
3718 (match-end 0))) 3986 (match-end 0)))
3719 (allout-recent-depth)))) 3987 (allout-recent-depth))))
3720 (more t)) 3988 (more t))
3721 (setq rectify-numbering allout-numbered-bullet) 3989 (setq rectify-numbering allout-numbered-bullet)
3722 (if adjust-to-depth 3990 (if adjust-to-depth
3723 ; Do the adjustment: 3991 ; Do the adjustment:
3724 (progn 3992 (progn
3725 (message "... yanking") (sit-for 0) 3993 (message "... yanking") (sit-for 0)
3726 (save-restriction 3994 (save-restriction
3727 (narrow-to-region subj-beg subj-end) 3995 (narrow-to-region subj-beg subj-end)
3728 ; Trim off excessive blank 3996 ; Trim off excessive blank
3729 ; line at end, if any: 3997 ; line at end, if any:
3730 (goto-char (point-max)) 3998 (goto-char (point-max))
3731 (if (looking-at "^$") 3999 (if (looking-at "^$")
3732 (allout-unprotected (delete-char -1))) 4000 (allout-unprotected (delete-char -1)))
3733 ; Work backwards, with each 4001 ; Work backwards, with each
3734 ; shallowest level, 4002 ; shallowest level,
3735 ; successively excluding the 4003 ; successively excluding the
3736 ; last processed topic from 4004 ; last processed topic from
3737 ; the narrow region: 4005 ; the narrow region:
3738 (while more 4006 (while more
3739 (allout-back-to-current-heading) 4007 (allout-back-to-current-heading)
3740 ; go as high as we can in each bunch: 4008 ; go as high as we can in each bunch:
3741 (while (allout-ascend-to-depth (1- (allout-depth)))) 4009 (while (allout-ascend-to-depth (1- (allout-depth))))
3742 (save-excursion 4010 (save-excursion
3743 (allout-rebullet-topic-grunt (- adjust-to-depth 4011 (allout-rebullet-topic-grunt (- adjust-to-depth
3744 subj-depth)) 4012 subj-depth))
3745 (allout-depth)) 4013 (allout-depth))
3746 (if (setq more (not (bobp))) 4014 (if (setq more (not (bobp)))
3747 (progn (widen) 4015 (progn (widen)
3748 (forward-char -1) 4016 (forward-char -1)
3749 (narrow-to-region subj-beg (point)))))) 4017 (narrow-to-region subj-beg (point))))))
3750 (message "") 4018 (message "")
3751 ;; Preserve new bullet if it's a distinctive one, otherwise 4019 ;; Preserve new bullet if it's a distinctive one, otherwise
3752 ;; use old one: 4020 ;; use old one:
3753 (if (string-match (regexp-quote prefix-bullet) 4021 (if (string-match (regexp-quote prefix-bullet)
3754 allout-distinctive-bullets-string) 4022 allout-distinctive-bullets-string)
3755 ; Delete from bullet of old to 4023 ; Delete from bullet of old to
3756 ; before bullet of new: 4024 ; before bullet of new:
3757 (progn 4025 (progn
3758 (beginning-of-line) 4026 (beginning-of-line)
3759 (delete-region (point) subj-beg) 4027 (delete-region (point) subj-beg)
3760 (set-marker (allout-mark-marker t) subj-end) 4028 (set-marker (allout-mark-marker t) subj-end)
3761 (goto-char subj-beg) 4029 (goto-char subj-beg)
3762 (allout-end-of-prefix)) 4030 (allout-end-of-prefix))
3763 ; Delete base subj prefix, 4031 ; Delete base subj prefix,
3764 ; leaving old one: 4032 ; leaving old one:
3765 (delete-region (point) (+ (point) 4033 (delete-region (point) (+ (point)
3766 prefix-len 4034 prefix-len
3767 (- adjust-to-depth subj-depth))) 4035 (- adjust-to-depth subj-depth)))
3768 ; and delete residual subj 4036 ; and delete residual subj
3769 ; prefix digits and space: 4037 ; prefix digits and space:
3770 (while (looking-at "[0-9]") (delete-char 1)) 4038 (while (looking-at "[0-9]") (delete-char 1))
3771 (if (looking-at " ") (delete-char 1)))) 4039 (if (looking-at " ") (delete-char 1))))
3772 (exchange-point-and-mark)))) 4040 (exchange-point-and-mark))))
3773 (if rectify-numbering 4041 (if rectify-numbering
3774 (progn 4042 (progn
3775 (save-excursion 4043 (save-excursion
3776 ; Give some preliminary feedback: 4044 ; Give some preliminary feedback:
3777 (message "... reconciling numbers") (sit-for 0) 4045 (message "... reconciling numbers") (sit-for 0)
3778 ; ... and renumber, in case necessary: 4046 ; ... and renumber, in case necessary:
3779 (goto-char subj-beg) 4047 (goto-char subj-beg)
3780 (if (allout-goto-prefix) 4048 (if (allout-goto-prefix)
3781 (allout-rebullet-heading nil ;;; solicit 4049 (allout-rebullet-heading nil ;;; solicit
3782 (allout-depth) ;;; depth 4050 (allout-depth) ;;; depth
3783 nil ;;; number-control 4051 nil ;;; number-control
3784 nil ;;; index 4052 nil ;;; index
3785 t)) 4053 t))
3786 (message "")))) 4054 (message ""))))
3787 (when (and (or into-bol resituate) was-collapsed) 4055 (when (and (or into-bol resituate) was-collapsed)
3788 (remove-text-properties subj-beg (1+ subj-beg) '(allout-was-collapsed)) 4056 (remove-text-properties subj-beg (1+ subj-beg) '(allout-was-collapsed))
3789 (allout-hide-current-subtree)) 4057 (allout-hide-current-subtree))
3790 (if (not resituate) 4058 (if (not resituate)
3791 (exchange-point-and-mark)))) 4059 (exchange-point-and-mark))
4060 (run-hook-with-args 'allout-structure-added-hook subj-beg subj-end))))
3792 ;;;_ > allout-yank (&optional arg) 4061 ;;;_ > allout-yank (&optional arg)
3793 (defun allout-yank (&optional arg) 4062 (defun allout-yank (&optional arg)
3794 "`allout-mode' yank, with depth and numbering adjustment of yanked topics. 4063 "`allout-mode' yank, with depth and numbering adjustment of yanked topics.
3795 4064
3796 Non-topic yanks work no differently than normal yanks. 4065 Non-topic yanks work no differently than normal yanks.
3818 `allout-yank-pop' works with `allout-yank' just like normal `yank-pop' 4087 `allout-yank-pop' works with `allout-yank' just like normal `yank-pop'
3819 works with normal `yank' in non-outline buffers." 4088 works with normal `yank' in non-outline buffers."
3820 4089
3821 (interactive "*P") 4090 (interactive "*P")
3822 (setq this-command 'yank) 4091 (setq this-command 'yank)
3823 (yank arg) 4092 (allout-unprotected
4093 (yank arg))
3824 (if (allout-mode-p) 4094 (if (allout-mode-p)
3825 (allout-yank-processing)) 4095 (allout-yank-processing)))
3826 )
3827 ;;;_ > allout-yank-pop (&optional arg) 4096 ;;;_ > allout-yank-pop (&optional arg)
3828 (defun allout-yank-pop (&optional arg) 4097 (defun allout-yank-pop (&optional arg)
3829 "Yank-pop like `allout-yank' when popping to bare outline prefixes. 4098 "Yank-pop like `allout-yank' when popping to bare outline prefixes.
3830 4099
3831 Adapts level of popped topics to level of fresh prefix. 4100 Adapts level of popped topics to level of fresh prefix.
3880 ;;;_ #6 Exposure Control 4149 ;;;_ #6 Exposure Control
3881 4150
3882 ;;;_ - Fundamental 4151 ;;;_ - Fundamental
3883 ;;;_ > allout-flag-region (from to flag) 4152 ;;;_ > allout-flag-region (from to flag)
3884 (defun allout-flag-region (from to flag) 4153 (defun allout-flag-region (from to flag)
3885 "Conceal text from FROM to TO if FLAG is non-nil, else reveal it. 4154 "Conceal text between FROM and TO if FLAG is non-nil, else reveal it.
3886 4155
3887 Text is shown if flag is nil and hidden otherwise." 4156 Exposure-change hook `allout-exposure-change-hook' is run with the same
4157 arguments as this function, after the exposure changes are made. \(The old
4158 `allout-view-change-hook' is being deprecated, and eventually will not be
4159 invoked.\)"
4160
3888 ;; We use outline invisibility spec. 4161 ;; We use outline invisibility spec.
3889 (remove-overlays from to 'category 'allout-exposure-category) 4162 (remove-overlays from to 'category 'allout-exposure-category)
3890 (when flag 4163 (when flag
3891 (let ((o (make-overlay from to))) 4164 (let ((o (make-overlay from to)))
3892 (overlay-put o 'category 'allout-exposure-category) 4165 (overlay-put o 'category 'allout-exposure-category)
3893 (when (featurep 'xemacs) 4166 (when (featurep 'xemacs)
3894 (let ((props (symbol-plist 'allout-exposure-category))) 4167 (let ((props (symbol-plist 'allout-exposure-category)))
3895 (while props 4168 (while props
3896 (overlay-put o (pop props) (pop props))))))) 4169 (overlay-put o (pop props) (pop props)))))))
3897 (run-hooks 'allout-view-change-hook) 4170 (run-hooks 'allout-view-change-hook)
3898 (run-hooks 'allout-exposure-change-hook)) 4171 (run-hook-with-args 'allout-exposure-change-hook from to flag))
3899 ;;;_ > allout-flag-current-subtree (flag) 4172 ;;;_ > allout-flag-current-subtree (flag)
3900 (defun allout-flag-current-subtree (flag) 4173 (defun allout-flag-current-subtree (flag)
3901 "Conceal currently-visible topic's subtree if FLAG non-nil, else reveal it." 4174 "Conceal currently-visible topic's subtree if FLAG non-nil, else reveal it."
3902 4175
3903 (save-excursion 4176 (save-excursion
4069 collapsed and uncollapsed. If optional INCLUDE-SINGLE-LINERS is 4342 collapsed and uncollapsed. If optional INCLUDE-SINGLE-LINERS is
4070 true, then single-line topics are considered to be collapsed. By 4343 true, then single-line topics are considered to be collapsed. By
4071 default, they are treated as being uncollapsed." 4344 default, they are treated as being uncollapsed."
4072 (save-excursion 4345 (save-excursion
4073 (and 4346 (and
4074 (= (progn (allout-back-to-current-heading) 4347 ;; Is the topic all on one line (allowing for trailing blank line)?
4075 (move-end-of-line 1) 4348 (>= (progn (allout-back-to-current-heading)
4076 (point)) 4349 (move-end-of-line 1)
4077 (allout-end-of-current-subtree (not (looking-at "\n\n")))) 4350 (point))
4351 (allout-end-of-current-subtree (not (looking-at "\n\n"))))
4352
4078 (or include-single-liners 4353 (or include-single-liners
4079 (progn (backward-char 1) (allout-hidden-p)))))) 4354 (progn (backward-char 1) (allout-hidden-p))))))
4080 ;;;_ > allout-hide-current-subtree (&optional just-close) 4355 ;;;_ > allout-hide-current-subtree (&optional just-close)
4081 (defun allout-hide-current-subtree (&optional just-close) 4356 (defun allout-hide-current-subtree (&optional just-close)
4082 "Close the current topic, or containing topic if this one is already closed. 4357 "Close the current topic, or containing topic if this one is already closed.
5095 ) 5370 )
5096 ;;;_ > allout-encrypt-string (text decrypt allout-buffer key-type for-key 5371 ;;;_ > allout-encrypt-string (text decrypt allout-buffer key-type for-key
5097 ;;; fetch-pass &optional retried verifying 5372 ;;; fetch-pass &optional retried verifying
5098 ;;; passphrase) 5373 ;;; passphrase)
5099 (defun allout-encrypt-string (text decrypt allout-buffer key-type for-key 5374 (defun allout-encrypt-string (text decrypt allout-buffer key-type for-key
5100 fetch-pass &optional retried verifying 5375 fetch-pass &optional retried rejected
5101 passphrase) 5376 verifying passphrase)
5102 "Encrypt or decrypt message TEXT. 5377 "Encrypt or decrypt message TEXT.
5103 5378
5104 If DECRYPT is true (default false), then decrypt instead of encrypt. 5379 If DECRYPT is true (default false), then decrypt instead of encrypt.
5105 5380
5106 FETCH-PASS (default false) forces fresh prompting for the passphrase. 5381 FETCH-PASS (default false) forces fresh prompting for the passphrase.
5113 Optional RETRIED is for internal use - conveys the number of failed keys 5388 Optional RETRIED is for internal use - conveys the number of failed keys
5114 that have been solicited in sequence leading to this current call. 5389 that have been solicited in sequence leading to this current call.
5115 5390
5116 Optional PASSPHRASE enables explicit delivery of the decryption passphrase, 5391 Optional PASSPHRASE enables explicit delivery of the decryption passphrase,
5117 for verification purposes. 5392 for verification purposes.
5393
5394 Optional REJECTED is for internal use - conveys the number of
5395 rejections due to matches against
5396 `allout-encryption-ciphertext-rejection-regexps', as limited by
5397 `allout-encryption-ciphertext-rejection-ceiling'.
5118 5398
5119 Returns the resulting string, or nil if the transformation fails." 5399 Returns the resulting string, or nil if the transformation fails."
5120 5400
5121 (require 'pgg) 5401 (require 'pgg)
5122 5402
5139 key-type 5419 key-type
5140 (if (equal key-type 'keypair) 5420 (if (equal key-type 'keypair)
5141 target-prompt-id 5421 target-prompt-id
5142 (or (buffer-file-name allout-buffer) 5422 (or (buffer-file-name allout-buffer)
5143 target-prompt-id)))) 5423 target-prompt-id))))
5424 (strip-plaintext-regexps
5425 (if (not decrypt)
5426 (allout-get-configvar-values
5427 'allout-encryption-plaintext-sanitization-regexps)))
5428 (reject-ciphertext-regexps
5429 (if (not decrypt)
5430 (allout-get-configvar-values
5431 'allout-encryption-ciphertext-rejection-regexps)))
5432 (rejected (or rejected 0))
5433 (rejections-left (- allout-encryption-ciphertext-rejection-ceiling
5434 rejected))
5144 result-text status) 5435 result-text status)
5145 5436
5146 (if (and fetch-pass (not passphrase)) 5437 (if (and fetch-pass (not passphrase))
5147 ;; Force later fetch by evicting passphrase from the cache. 5438 ;; Force later fetch by evicting passphrase from the cache.
5148 (pgg-remove-passphrase-from-cache target-cache-id t)) 5439 (pgg-remove-passphrase-from-cache target-cache-id t))
5159 target-cache-id 5450 target-cache-id
5160 target-prompt-id 5451 target-prompt-id
5161 key-type 5452 key-type
5162 allout-buffer 5453 allout-buffer
5163 retried fetch-pass))) 5454 retried fetch-pass)))
5455
5164 (with-temp-buffer 5456 (with-temp-buffer
5165 5457
5166 (insert text) 5458 (insert text)
5459
5460 (when (and strip-plaintext-regexps (not decrypt))
5461 (dolist (re strip-plaintext-regexps)
5462 (let ((re (if (listp re) (car re) re))
5463 (replacement (if (listp re) (cadr re) "")))
5464 (goto-char (point-min))
5465 (while (re-search-forward re nil t)
5466 (replace-match replacement nil nil)))))
5167 5467
5168 (cond 5468 (cond
5169 5469
5170 ;; symmetric: 5470 ;; symmetric:
5171 ((equal key-type 'symmetric) 5471 ((equal key-type 'symmetric)
5181 (pgg-situate-output (point-min) (point-max)) 5481 (pgg-situate-output (point-min) (point-max))
5182 ;; failed - handle passphrase caching 5482 ;; failed - handle passphrase caching
5183 (if verifying 5483 (if verifying
5184 (throw 'encryption-failed nil) 5484 (throw 'encryption-failed nil)
5185 (pgg-remove-passphrase-from-cache target-cache-id t) 5485 (pgg-remove-passphrase-from-cache target-cache-id t)
5186 (error "Symmetric-cipher encryption failed - %s" 5486 (error "Symmetric-cipher %scryption failed - %s"
5487 (if decrypt "de" "en")
5187 "try again with different passphrase.")))) 5488 "try again with different passphrase."))))
5188 5489
5189 ;; encrypt 'keypair: 5490 ;; encrypt 'keypair:
5190 ((not decrypt) 5491 ((not decrypt)
5191 5492
5206 (pgg-decrypt (point-min) (point-max) passphrase)) 5507 (pgg-decrypt (point-min) (point-max) passphrase))
5207 5508
5208 (if status 5509 (if status
5209 (pgg-situate-output (point-min) (point-max)) 5510 (pgg-situate-output (point-min) (point-max))
5210 (error (pgg-remove-passphrase-from-cache target-cache-id t) 5511 (error (pgg-remove-passphrase-from-cache target-cache-id t)
5211 (error "decryption failed")))) 5512 (error "decryption failed")))))
5212 )
5213 5513
5214 (setq result-text 5514 (setq result-text
5215 (buffer-substring 1 (- (point-max) (if decrypt 0 1)))) 5515 (buffer-substring 1 (- (point-max) (if decrypt 0 1))))
5216
5217 ;; validate result - non-empty
5218 (cond ((not result-text)
5219 (if verifying
5220 nil
5221 ;; transform was fruitless, retry w/new passphrase.
5222 (pgg-remove-passphrase-from-cache target-cache-id t)
5223 (allout-encrypt-string text allout-buffer decrypt nil
5224 (if retried (1+ retried) 1)
5225 passphrase)))
5226
5227 ;; Barf if encryption yields extraordinary control chars:
5228 ((and (not decrypt)
5229 (string-match "[\C-a\C-k\C-o-\C-z\C-@]"
5230 result-text))
5231 (error (concat "encryption produced unusable"
5232 " non-armored text - reconfigure!")))
5233
5234 ;; valid result and just verifying or non-symmetric:
5235 ((or verifying (not (equal key-type 'symmetric)))
5236 (if (or verifying decrypt)
5237 (pgg-add-passphrase-to-cache target-cache-id
5238 passphrase t))
5239 result-text)
5240
5241 ;; valid result and regular symmetric - "register"
5242 ;; passphrase with mnemonic aids/cache.
5243 (t
5244 (set-buffer allout-buffer)
5245 (if passphrase
5246 (pgg-add-passphrase-to-cache target-cache-id
5247 passphrase t))
5248 (allout-update-passphrase-mnemonic-aids for-key passphrase
5249 allout-buffer)
5250 result-text)
5251 )
5252 ) 5516 )
5517
5518 ;; validate result - non-empty
5519 (cond ((not result-text)
5520 (if verifying
5521 nil
5522 ;; transform was fruitless, retry w/new passphrase.
5523 (pgg-remove-passphrase-from-cache target-cache-id t)
5524 (allout-encrypt-string text decrypt allout-buffer
5525 key-type for-key nil
5526 (if retried (1+ retried) 1)
5527 rejected verifying nil)))
5528
5529 ;; Retry (within limit) if ciphertext contains rejections:
5530 ((and (not decrypt)
5531 ;; Check for disqualification of this ciphertext:
5532 (let ((regexps reject-ciphertext-regexps)
5533 reject-it)
5534 (while (and regexps (not reject-it))
5535 (setq reject-it (string-match (car regexps)
5536 result-text))
5537 (pop regexps))
5538 reject-it))
5539 (setq rejections-left (1- rejections-left))
5540 (if (<= rejections-left 0)
5541 (error (concat "Ciphertext rejected too many times"
5542 " (%s), per `%s'")
5543 allout-encryption-ciphertext-rejection-ceiling
5544 'allout-encryption-ciphertext-rejection-regexps)
5545 (allout-encrypt-string text decrypt allout-buffer
5546 key-type for-key nil
5547 retried (1+ rejected)
5548 verifying passphrase)))
5549 ;; Barf if encryption yields extraordinary control chars:
5550 ((and (not decrypt)
5551 (string-match "[\C-a\C-k\C-o-\C-z\C-@]"
5552 result-text))
5553 (error (concat "Encryption produced non-armored text, which"
5554 "conflicts with allout mode - reconfigure!")))
5555
5556 ;; valid result and just verifying or non-symmetric:
5557 ((or verifying (not (equal key-type 'symmetric)))
5558 (if (or verifying decrypt)
5559 (pgg-add-passphrase-to-cache target-cache-id
5560 passphrase t))
5561 result-text)
5562
5563 ;; valid result and regular symmetric - "register"
5564 ;; passphrase with mnemonic aids/cache.
5565 (t
5566 (set-buffer allout-buffer)
5567 (if passphrase
5568 (pgg-add-passphrase-to-cache target-cache-id
5569 passphrase t))
5570 (allout-update-passphrase-mnemonic-aids for-key passphrase
5571 allout-buffer)
5572 result-text)
5573 )
5253 ) 5574 )
5254 ) 5575 )
5255 ) 5576 )
5256 ;;;_ > allout-obtain-passphrase (for-key cache-id prompt-id key-type 5577 ;;;_ > allout-obtain-passphrase (for-key cache-id prompt-id key-type
5257 ;;; allout-buffer retried fetch-pass) 5578 ;;; allout-buffer retried fetch-pass)
5311 5632
5312 (cached (and (not fetch-pass) 5633 (cached (and (not fetch-pass)
5313 (pgg-read-passphrase-from-cache cache-id t))) 5634 (pgg-read-passphrase-from-cache cache-id t)))
5314 (got-pass (or cached 5635 (got-pass (or cached
5315 (pgg-read-passphrase full-prompt cache-id t))) 5636 (pgg-read-passphrase full-prompt cache-id t)))
5316
5317 confirmation) 5637 confirmation)
5318 5638
5319 (if (not got-pass) 5639 (if (not got-pass)
5320 nil 5640 nil
5321 5641
5322 ;; Duplicate our handle on the passphrase so it's not clobbered by 5642 ;; Duplicate our handle on the passphrase so it's not clobbered by
5323 ;; deactivate-passwd memory clearing: 5643 ;; deactivate-passwd memory clearing:
5324 (setq got-pass (format "%s" got-pass)) 5644 (setq got-pass (copy-sequence got-pass))
5325 5645
5326 (cond (verifier-string 5646 (cond (verifier-string
5327 (save-window-excursion 5647 (save-window-excursion
5328 (if (allout-encrypt-string verifier-string 'decrypt 5648 (if (allout-encrypt-string verifier-string 'decrypt
5329 allout-buffer 'symmetric 5649 allout-buffer 'symmetric
5330 for-key nil 0 'verifying 5650 for-key nil 0 0 'verifying
5331 got-pass) 5651 (copy-sequence got-pass))
5332 (setq confirmation (format "%s" got-pass)))) 5652 (setq confirmation (format "%s" got-pass))))
5333 5653
5334 (if (and (not confirmation) 5654 (if (and (not confirmation)
5335 (if (yes-or-no-p 5655 (if (yes-or-no-p
5336 (concat "Passphrase differs from established" 5656 (concat "Passphrase differs from established"
5363 (progn (setq retried (if retried (1+ retried) 1)) 5683 (progn (setq retried (if retried (1+ retried) 1))
5364 (pgg-remove-passphrase-from-cache cache-id t) 5684 (pgg-remove-passphrase-from-cache cache-id t)
5365 ;; recurse to this routine: 5685 ;; recurse to this routine:
5366 (pgg-read-passphrase prompt-sans-hint cache-id t)) 5686 (pgg-read-passphrase prompt-sans-hint cache-id t))
5367 (pgg-remove-passphrase-from-cache cache-id t) 5687 (pgg-remove-passphrase-from-cache cache-id t)
5368 (error "Confirmation failed."))) 5688 (error "Confirmation failed."))))))))
5369 ;; reduce opportunity for memory cherry-picking by zeroing duplicate:
5370 (dotimes (i (length got-pass))
5371 (aset got-pass i 0))
5372 )
5373 )
5374 )
5375 )
5376 )
5377 ;;;_ > allout-encrypted-topic-p () 5689 ;;;_ > allout-encrypted-topic-p ()
5378 (defun allout-encrypted-topic-p () 5690 (defun allout-encrypted-topic-p ()
5379 "True if the current topic is encryptable and encrypted." 5691 "True if the current topic is encryptable and encrypted."
5380 (save-excursion 5692 (save-excursion
5381 (allout-end-of-prefix t) 5693 (allout-end-of-prefix t)
5424 (random t) 5736 (random t)
5425 (let ((spew (make-string 20 ?\0))) 5737 (let ((spew (make-string 20 ?\0)))
5426 (dotimes (i (length spew)) 5738 (dotimes (i (length spew))
5427 (aset spew i (1+ (random 254)))) 5739 (aset spew i (1+ (random 254))))
5428 (allout-encrypt-string spew nil (current-buffer) 'symmetric 5740 (allout-encrypt-string spew nil (current-buffer) 'symmetric
5429 nil nil 0 passphrase)) 5741 nil nil 0 0 passphrase))
5430 ) 5742 )
5431 ;;;_ > allout-update-passphrase-mnemonic-aids (for-key passphrase 5743 ;;;_ > allout-update-passphrase-mnemonic-aids (for-key passphrase
5432 ;;; outline-buffer) 5744 ;;; outline-buffer)
5433 (defun allout-update-passphrase-mnemonic-aids (for-key passphrase 5745 (defun allout-update-passphrase-mnemonic-aids (for-key passphrase
5434 outline-buffer) 5746 outline-buffer)
5503 (set-buffer allout-buffer) 5815 (set-buffer allout-buffer)
5504 (and (boundp 'allout-passphrase-verifier-string) 5816 (and (boundp 'allout-passphrase-verifier-string)
5505 allout-passphrase-verifier-string 5817 allout-passphrase-verifier-string
5506 (allout-encrypt-string (allout-get-encryption-passphrase-verifier) 5818 (allout-encrypt-string (allout-get-encryption-passphrase-verifier)
5507 'decrypt allout-buffer 'symmetric 5819 'decrypt allout-buffer 'symmetric
5508 key nil 0 'verifying passphrase) 5820 key nil 0 0 'verifying passphrase)
5509 t))) 5821 t)))
5510 ;;;_ > allout-next-topic-pending-encryption (&optional except-mark) 5822 ;;;_ > allout-next-topic-pending-encryption (&optional except-mark)
5511 (defun allout-next-topic-pending-encryption (&optional except-mark) 5823 (defun allout-next-topic-pending-encryption (&optional except-mark)
5512 "Return the point of the next topic pending encryption, or nil if none. 5824 "Return the point of the next topic pending encryption, or nil if none.
5513 5825
5806 (let ((count 0)) 6118 (let ((count 0))
5807 (while (re-search-forward "[ ][ ]*$" end t) 6119 (while (re-search-forward "[ ][ ]*$" end t)
5808 (goto-char (1+ (match-beginning 0))) 6120 (goto-char (1+ (match-beginning 0)))
5809 (setq count (1+ count))) 6121 (setq count (1+ count)))
5810 count)))) 6122 count))))
6123 ;;;_ > allout-get-configvar-values (varname)
6124 (defun allout-get-configvar-values (configvar-name)
6125 "Return a list of values of the symbols in list bound to CONFIGVAR-NAME.
6126
6127 The user is prompted for removal of symbols that are unbound, and they
6128 otherwise are ignored.
6129
6130 CONFIGVAR-NAME should be the name of the configuration variable,
6131 not its value."
6132
6133 (let ((configvar-value (symbol-value configvar-name))
6134 got)
6135 (dolist (sym configvar-value)
6136 (if (not (boundp sym))
6137 (if (yes-or-no-p (format "%s entry `%s' is unbound - remove it? "
6138 configvar-name sym))
6139 (delq sym (symbol-value configvar-name)))
6140 (push (symbol-value sym) got)))
6141 (reverse got)))
5811 ;;;_ > allout-mark-marker to accommodate divergent emacsen: 6142 ;;;_ > allout-mark-marker to accommodate divergent emacsen:
5812 (defun allout-mark-marker (&optional force buffer) 6143 (defun allout-mark-marker (&optional force buffer)
5813 "Accommodate the different signature for `mark-marker' across Emacsen. 6144 "Accommodate the different signature for `mark-marker' across Emacsen.
5814 6145
5815 XEmacs takes two optional args, while mainline GNU Emacs does not, 6146 XEmacs takes two optional args, while mainline GNU Emacs does not,