1;;; allout.el --- extensive outline mode for use alone and with other modes 2 3;; Copyright (C) 1992, 1993, 1994, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Ken Manheimer <ken dot manheimer at gmail dot com> 7;; Maintainer: Ken Manheimer <ken dot manheimer at gmail dot com> 8;; Created: Dec 1991 - first release to usenet 9;; Version: 2.2.1 10;; Keywords: outlines wp languages 11;; Website: http://myriadicity.net/Sundry/EmacsAllout 12 13;; This file is part of GNU Emacs. 14 15;; GNU Emacs is free software; you can redistribute it and/or modify 16;; it under the terms of the GNU General Public License as published by 17;; the Free Software Foundation; either version 2, or (at your option) 18;; any later version. 19 20;; GNU Emacs is distributed in the hope that it will be useful, 21;; but WITHOUT ANY WARRANTY; without even the implied warranty of 22;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 23;; GNU General Public License for more details. 24 25;; You should have received a copy of the GNU General Public License 26;; along with GNU Emacs; see the file COPYING. If not, write to the 27;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 28;; Boston, MA 02110-1301, USA. 29 30;;; Commentary: 31 32;; Allout outline minor mode provides extensive outline formatting and 33;; and manipulation beyond standard emacs outline mode. Some features: 34;; 35;; - Classic outline-mode topic-oriented navigation and exposure adjustment 36;; - Topic-oriented editing including coherent topic and subtopic 37;; creation, promotion, demotion, cut/paste across depths, etc. 38;; - Incremental search with dynamic exposure and reconcealment of text 39;; - Customizable bullet format - enables programming-language specific 40;; outlining, for code-folding editing. (Allout code itself is to try it; 41;; formatted as an outline - do ESC-x eval-buffer in allout.el; but 42;; emacs local file variables need to be enabled when the 43;; file was visited - see `enable-local-variables'.) 44;; - Configurable per-file initial exposure settings 45;; - Symmetric-key and key-pair topic encryption, plus symmetric passphrase 46;; mnemonic support, with verification against an established passphrase 47;; (using a stashed encrypted dummy string) and user-supplied hint 48;; maintenance. (See allout-toggle-current-subtree-encryption docstring. 49;; Currently only GnuPG encryption is supported, and integration 50;; with gpg-agent is not yet implemented.) 51;; - Automatic topic-number maintenance 52;; - "Hot-spot" operation, for single-keystroke maneuvering and 53;; exposure control (see the allout-mode docstring) 54;; - Easy rendering of exposed portions into numbered, latex, indented, etc 55;; outline styles 56;; - Careful attention to whitespace - enabling blank lines between items 57;; and maintenance of hanging indentation (in paragraph auto-fill and 58;; across topic promotion and demotion) of topic bodies consistent with 59;; indentation of their topic header. 60;; 61;; and more. 62;; 63;; See the `allout-mode' function's docstring for an introduction to the 64;; mode. 65;; 66;; The latest development version and helpful notes are available at 67;; http://myriadicity.net/Sundry/EmacsAllout . 68;; 69;; The outline menubar additions provide quick reference to many of 70;; the features, and see the docstring of the variable `allout-init' 71;; for instructions on priming your Emacs session for automatic 72;; activation of allout-mode. 73;; 74;; See the docstring of the variables `allout-layout' and 75;; `allout-auto-activation' for details on automatic activation of 76;; `allout-mode' as a minor mode. (It has changed since allout 77;; 3.x, for those of you that depend on the old method.) 78;; 79;; Note - the lines beginning with `;;;_' are outline topic headers. 80;; Just `ESC-x eval-buffer' to give it a whirl. 81 82;; ken manheimer (ken dot manheimer at gmail dot com) 83 84;;; Code: 85 86;;;_* Dependency autoloads 87(require 'overlay) 88(eval-when-compile 89 ;; Most of the requires here are for stuff covered by autoloads. 90 ;; Since just byte-compiling doesn't trigger autoloads, so that 91 ;; "function not found" warnings would occur without these requires. 92 (progn 93 (require 'pgg) 94 (require 'pgg-gpg) 95 (require 'overlay) 96 ;; `cl' is required for `assert'. `assert' is not covered by a standard 97 ;; autoload, but it is a macro, so that eval-when-compile is sufficient 98 ;; to byte-compile it in, or to do the require when the buffer evalled. 99 (require 'cl) 100 )) 101 102;;;_* USER CUSTOMIZATION VARIABLES: 103 104;;;_ > defgroup allout 105(defgroup allout nil 106 "Extensive outline mode for use alone and with other modes." 107 :prefix "allout-" 108 :group 'outlines) 109 110;;;_ + Layout, Mode, and Topic Header Configuration 111 112;;;_ = allout-auto-activation 113(defcustom allout-auto-activation nil 114 "*Regulates auto-activation modality of allout outlines - see `allout-init'. 115 116Setq-default by `allout-init' to regulate whether or not allout 117outline mode is automatically activated when the buffer-specific 118variable `allout-layout' is non-nil, and whether or not the layout 119dictated by `allout-layout' should be imposed on mode activation. 120 121With value t, auto-mode-activation and auto-layout are enabled. 122\(This also depends on `allout-find-file-hook' being installed in 123`find-file-hook', which is also done by `allout-init'.) 124 125With value `ask', auto-mode-activation is enabled, and endorsement for 126performing auto-layout is asked of the user each time. 127 128With value `activate', only auto-mode-activation is enabled, 129auto-layout is not. 130 131With value nil, neither auto-mode-activation nor auto-layout are 132enabled. 133 134See the docstring for `allout-init' for the proper interface to 135this variable." 136 :type '(choice (const :tag "On" t) 137 (const :tag "Ask about layout" "ask") 138 (const :tag "Mode only" "activate") 139 (const :tag "Off" nil)) 140 :group 'allout) 141;;;_ = allout-default-layout 142(defcustom allout-default-layout '(-2 : 0) 143 "*Default allout outline layout specification. 144 145This setting specifies the outline exposure to use when 146`allout-layout' has the local value `t'. This docstring describes the 147layout specifications. 148 149A list value specifies a default layout for the current buffer, 150to be applied upon activation of `allout-mode'. Any non-nil 151value will automatically trigger `allout-mode', provided 152`allout-init' has been called to enable this behavior. 153 154The types of elements in the layout specification are: 155 156 integer - dictate the relative depth to open the corresponding topic(s), 157 where: 158 - negative numbers force the topic to be closed before opening 159 to the absolute value of the number, so all siblings are open 160 only to that level. 161 - positive numbers open to the relative depth indicated by the 162 number, but do not force already opened subtopics to be closed. 163 - 0 means to close topic - hide all subitems. 164 : - repeat spec - apply the preceeding element to all siblings at 165 current level, *up to* those siblings that would be covered by specs 166 following the `:' on the list. Ie, apply to all topics at level but 167 trailing ones accounted for by trailing specs. (Only the first of 168 multiple colons at the same level is honored - later ones are ignored.) 169 * - completely exposes the topic, including bodies 170 + - exposes all subtopics, but not the bodies 171 - - exposes the body of the corresponding topic, but not subtopics 172 list - a nested layout spec, to be applied intricately to its 173 corresponding item(s) 174 175Examples: 176 '(-2 : 0) 177 Collapse the top-level topics to show their children and 178 grandchildren, but completely collapse the final top-level topic. 179 '(-1 () : 1 0) 180 Close the first topic so only the immediate subtopics are shown, 181 leave the subsequent topics exposed as they are until the second 182 second to last topic, which is exposed at least one level, and 183 completely close the last topic. 184 '(-2 : -1 *) 185 Expose children and grandchildren of all topics at current 186 level except the last two; expose children of the second to 187 last and completely expose the last one, including its subtopics. 188 189See `allout-expose-topic' for more about the exposure process. 190 191Also, allout's mode-specific provisions will make topic prefixes default 192to the comment-start string, if any, of the language of the file. This 193is modulo the setting of `allout-use-mode-specific-leader', which see." 194 :type 'allout-layout-type 195 :group 'allout) 196;;;_ : allout-layout-type 197(define-widget 'allout-layout-type 'lazy 198 "Allout layout format customization basic building blocks." 199 :type '(repeat 200 (choice (integer :tag "integer (<= zero is strict)") 201 (const :tag ": (repeat prior)" :) 202 (const :tag "* (completely expose)" *) 203 (const :tag "+ (expose all offspring, headlines only)" +) 204 (const :tag "- (expose topic body but not offspring)" -) 205 (allout-layout-type :tag "<Nested layout>")))) 206 207;;;_ = allout-show-bodies 208(defcustom allout-show-bodies nil 209 "*If non-nil, show entire body when exposing a topic, rather than 210just the header." 211 :type 'boolean 212 :group 'allout) 213(make-variable-buffer-local 'allout-show-bodies) 214;;;###autoload 215(put 'allout-show-bodies 'safe-local-variable 216 (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil))))) 217 218;;;_ = allout-beginning-of-line-cycles 219(defcustom allout-beginning-of-line-cycles t 220 "*If non-nil, \\[allout-beginning-of-line] will cycle through smart-placement options. 221 222Cycling only happens on when the command is repeated, not when it 223follows a different command. 224 225Smart-placement means that repeated calls to this function will 226advance as follows: 227 228 - if the cursor is on a non-headline body line and not on the first column: 229 then it goes to the first column 230 - if the cursor is on the first column of a non-headline body line: 231 then it goes to the start of the headline within the item body 232 - if the cursor is on the headline and not the start of the headline: 233 then it goes to the start of the headline 234 - if the cursor is on the start of the headline: 235 then it goes to the bullet character (for hotspot navigation) 236 - if the cursor is on the bullet character: 237 then it goes to the first column of that line (the headline) 238 - if the cursor is on the first column of the headline: 239 then it goes to the start of the headline within the item body. 240 241In this fashion, you can use the beginning-of-line command to do 242its normal job and then, when repeated, advance through the 243entry, cycling back to start. 244 245If this configuration variable is nil, then the cursor is just 246advanced to the beginning of the line and remains there on 247repeated calls." 248 :type 'boolean :group 'allout) 249;;;_ = allout-end-of-line-cycles 250(defcustom allout-end-of-line-cycles t 251 "*If non-nil, \\[allout-end-of-line] will cycle through smart-placement options. 252 253Cycling only happens on when the command is repeated, not when it 254follows a different command. 255 256Smart-placement means that repeated calls to this function will 257advance as follows: 258 259 - if the cursor is not on the end-of-line, 260 then it goes to the end-of-line 261 - if the cursor is on the end-of-line but not the end-of-entry, 262 then it goes to the end-of-entry, exposing it if necessary 263 - if the cursor is on the end-of-entry, 264 then it goes to the end of the head line 265 266In this fashion, you can use the end-of-line command to do its 267normal job and then, when repeated, advance through the entry, 268cycling back to start. 269 270If this configuration variable is nil, then the cursor is just 271advanced to the end of the line and remains there on repeated 272calls." 273 :type 'boolean :group 'allout) 274 275;;;_ = allout-header-prefix 276(defcustom allout-header-prefix "." 277;; this string is treated as literal match. it will be `regexp-quote'd, so 278;; one cannot use regular expressions to match varying header prefixes. 279 "*Leading string which helps distinguish topic headers. 280 281Outline topic header lines are identified by a leading topic 282header prefix, which mostly have the value of this var at their front. 283Level 1 topics are exceptions. They consist of only a single 284character, which is typically set to the `allout-primary-bullet'." 285 :type 'string 286 :group 'allout) 287(make-variable-buffer-local 'allout-header-prefix) 288;;;###autoload 289(put 'allout-header-prefix 'safe-local-variable 'stringp) 290;;;_ = allout-primary-bullet 291(defcustom allout-primary-bullet "*" 292 "Bullet used for top-level outline topics. 293 294Outline topic header lines are identified by a leading topic header 295prefix, which is concluded by bullets that includes the value of this 296var and the respective allout-*-bullets-string vars. 297 298The value of an asterisk (`*') provides for backwards compatibility 299with the original Emacs outline mode. See `allout-plain-bullets-string' 300and `allout-distinctive-bullets-string' for the range of available 301bullets." 302 :type 'string 303 :group 'allout) 304(make-variable-buffer-local 'allout-primary-bullet) 305;;;###autoload 306(put 'allout-primary-bullet 'safe-local-variable 'stringp) 307;;;_ = allout-plain-bullets-string 308(defcustom allout-plain-bullets-string ".," 309 "*The bullets normally used in outline topic prefixes. 310 311See `allout-distinctive-bullets-string' for the other kind of 312bullets. 313 314DO NOT include the close-square-bracket, `]', as a bullet. 315 316Outline mode has to be reactivated in order for changes to the value 317of this var to take effect." 318 :type 'string 319 :group 'allout) 320(make-variable-buffer-local 'allout-plain-bullets-string) 321;;;###autoload 322(put 'allout-plain-bullets-string 'safe-local-variable 'stringp) 323;;;_ = allout-distinctive-bullets-string 324(defcustom allout-distinctive-bullets-string "*+-=>()[{}&!?#%\"X@$~_\\:;^" 325 "*Persistent outline header bullets used to distinguish special topics. 326 327These bullets are distinguish topics with particular character. 328They are not used by default in the topic creation routines, but 329are offered as options when you modify topic creation with a 330universal argument \(\\[universal-argument]), or during rebulleting \(\\[allout-rebullet-current-heading]). 331 332Distinctive bullets are not cycled when topics are shifted or 333otherwise automatically rebulleted, so their marking is 334persistent until deliberately changed. Their significance is 335purely by convention, however. Some conventions suggest 336themselves: 337 338 `(' - open paren - an aside or incidental point 339 `?' - question mark - uncertain or outright question 340 `!' - exclamation point/bang - emphatic 341 `[' - open square bracket - meta-note, about item instead of item's subject 342 `\"' - double quote - a quotation or other citation 343 `=' - equal sign - an assignement, equating a name with some connotation 344 `^' - carat - relates to something above 345 346Some are more elusive, but their rationale may be recognizable: 347 348 `+' - plus - pending consideration, completion 349 `_' - underscore - done, completed 350 `&' - ampersand - addendum, furthermore 351 352\(Some other non-plain bullets have special meaning to the 353software. By default: 354 355 `~' marks encryptable topics - see `allout-topic-encryption-bullet' 356 `#' marks auto-numbered bullets - see `allout-numbered-bullet'.) 357 358See `allout-plain-bullets-string' for the standard, alternating 359bullets. 360 361You must run `set-allout-regexp' in order for outline mode to 362adopt changes of this value. 363 364DO NOT include the close-square-bracket, `]', on either of the bullet 365strings." 366 :type 'string 367 :group 'allout) 368(make-variable-buffer-local 'allout-distinctive-bullets-string) 369;;;###autoload 370(put 'allout-distinctive-bullets-string 'safe-local-variable 'stringp) 371 372;;;_ = allout-use-mode-specific-leader 373(defcustom allout-use-mode-specific-leader t 374 "*When non-nil, use mode-specific topic-header prefixes. 375 376Allout outline mode will use the mode-specific `allout-mode-leaders' or 377comment-start string, if any, to lead the topic prefix string, so topic 378headers look like comments in the programming language. It will also use 379the comment-start string, with an '_' appended, for `allout-primary-bullet'. 380 381String values are used as literals, not regular expressions, so 382do not escape any regulare-expression characters. 383 384Value t means to first check for assoc value in `allout-mode-leaders' 385alist, then use comment-start string, if any, then use default (`.'). 386\(See note about use of comment-start strings, below.) 387 388Set to the symbol for either of `allout-mode-leaders' or 389`comment-start' to use only one of them, respectively. 390 391Value nil means to always use the default (`.') and leave 392`allout-primary-bullet' unaltered. 393 394comment-start strings that do not end in spaces are tripled in 395the header-prefix, and an `_' underscore is tacked on the end, to 396distinguish them from regular comment strings. comment-start 397strings that do end in spaces are not tripled, but an underscore 398is substituted for the space. [This presumes that the space is 399for appearance, not comment syntax. You can use 400`allout-mode-leaders' to override this behavior, when 401undesired.]" 402 :type '(choice (const t) (const nil) string 403 (const allout-mode-leaders) 404 (const comment-start)) 405 :group 'allout) 406;;;###autoload 407(put 'allout-use-mode-specific-leader 'safe-local-variable 408 '(lambda (x) (or (memq x '(t nil allout-mode-leaders comment-start)) 409 (stringp x)))) 410;;;_ = allout-mode-leaders 411(defvar allout-mode-leaders '() 412 "Specific allout-prefix leading strings per major modes. 413 414Use this if the mode's comment-start string isn't what you 415prefer, or if the mode lacks a comment-start string. See 416`allout-use-mode-specific-leader' for more details. 417 418If you're constructing a string that will comment-out outline 419structuring so it can be included in program code, append an extra 420character, like an \"_\" underscore, to distinguish the lead string 421from regular comments that start at the beginning-of-line.") 422 423;;;_ = allout-old-style-prefixes 424(defcustom allout-old-style-prefixes nil 425 "*When non-nil, use only old-and-crusty `outline-mode' `*' topic prefixes. 426 427Non-nil restricts the topic creation and modification 428functions to asterix-padded prefixes, so they look exactly 429like the original Emacs-outline style prefixes. 430 431Whatever the setting of this variable, both old and new style prefixes 432are always respected by the topic maneuvering functions." 433 :type 'boolean 434 :group 'allout) 435(make-variable-buffer-local 'allout-old-style-prefixes) 436;;;###autoload 437(put 'allout-old-style-prefixes 'safe-local-variable 438 (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil))))) 439;;;_ = allout-stylish-prefixes - alternating bullets 440(defcustom allout-stylish-prefixes t 441 "*Do fancy stuff with topic prefix bullets according to level, etc. 442 443Non-nil enables topic creation, modification, and repositioning 444functions to vary the topic bullet char (the char that marks the topic 445depth) just preceding the start of the topic text) according to level. 446Otherwise, only asterisks (`*') and distinctive bullets are used. 447 448This is how an outline can look (but sans indentation) with stylish 449prefixes: 450 451 * Top level 452 .* A topic 453 . + One level 3 subtopic 454 . . One level 4 subtopic 455 . . A second 4 subtopic 456 . + Another level 3 subtopic 457 . #1 A numbered level 4 subtopic 458 . #2 Another 459 . ! Another level 4 subtopic with a different distinctive bullet 460 . #4 And another numbered level 4 subtopic 461 462This would be an outline with stylish prefixes inhibited (but the 463numbered and other distinctive bullets retained): 464 465 * Top level 466 .* A topic 467 . * One level 3 subtopic 468 . * One level 4 subtopic 469 . * A second 4 subtopic 470 . * Another level 3 subtopic 471 . #1 A numbered level 4 subtopic 472 . #2 Another 473 . ! Another level 4 subtopic with a different distinctive bullet 474 . #4 And another numbered level 4 subtopic 475 476Stylish and constant prefixes (as well as old-style prefixes) are 477always respected by the topic maneuvering functions, regardless of 478this variable setting. 479 480The setting of this var is not relevant when `allout-old-style-prefixes' 481is non-nil." 482 :type 'boolean 483 :group 'allout) 484(make-variable-buffer-local 'allout-stylish-prefixes) 485;;;###autoload 486(put 'allout-stylish-prefixes 'safe-local-variable 487 (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil))))) 488 489;;;_ = allout-numbered-bullet 490(defcustom allout-numbered-bullet "#" 491 "*String designating bullet of topics that have auto-numbering; nil for none. 492 493Topics having this bullet have automatic maintenance of a sibling 494sequence-number tacked on, just after the bullet. Conventionally set 495to \"#\", you can set it to a bullet of your choice. A nil value 496disables numbering maintenance." 497 :type '(choice (const nil) string) 498 :group 'allout) 499(make-variable-buffer-local 'allout-numbered-bullet) 500;;;###autoload 501(put 'allout-numbered-bullet 'safe-local-variable 502 (if (fboundp 'string-or-null-p) 503 'string-or-null-p 504 '(lambda (x) (or (stringp x) (null x))))) 505;;;_ = allout-file-xref-bullet 506(defcustom allout-file-xref-bullet "@" 507 "*Bullet signifying file cross-references, for `allout-resolve-xref'. 508 509Set this var to the bullet you want to use for file cross-references." 510 :type '(choice (const nil) string) 511 :group 'allout) 512;;;###autoload 513(put 'allout-file-xref-bullet 'safe-local-variable 514 (if (fboundp 'string-or-null-p) 515 'string-or-null-p 516 '(lambda (x) (or (stringp x) (null x))))) 517;;;_ = allout-presentation-padding 518(defcustom allout-presentation-padding 2 519 "*Presentation-format white-space padding factor, for greater indent." 520 :type 'integer 521 :group 'allout) 522 523(make-variable-buffer-local 'allout-presentation-padding) 524;;;###autoload 525(put 'allout-presentation-padding 'safe-local-variable 'integerp) 526 527;;;_ = allout-abbreviate-flattened-numbering 528(defcustom allout-abbreviate-flattened-numbering nil 529 "*If non-nil, `allout-flatten-exposed-to-buffer' abbreviates topic 530numbers to minimal amount with some context. Otherwise, entire 531numbers are always used." 532 :type 'boolean 533 :group 'allout) 534 535;;;_ + LaTeX formatting 536;;;_ - allout-number-pages 537(defcustom allout-number-pages nil 538 "*Non-nil turns on page numbering for LaTeX formatting of an outline." 539 :type 'boolean 540 :group 'allout) 541;;;_ - allout-label-style 542(defcustom allout-label-style "\\large\\bf" 543 "*Font and size of labels for LaTeX formatting of an outline." 544 :type 'string 545 :group 'allout) 546;;;_ - allout-head-line-style 547(defcustom allout-head-line-style "\\large\\sl " 548 "*Font and size of entries for LaTeX formatting of an outline." 549 :type 'string 550 :group 'allout) 551;;;_ - allout-body-line-style 552(defcustom allout-body-line-style " " 553 "*Font and size of entries for LaTeX formatting of an outline." 554 :type 'string 555 :group 'allout) 556;;;_ - allout-title-style 557(defcustom allout-title-style "\\Large\\bf" 558 "*Font and size of titles for LaTeX formatting of an outline." 559 :type 'string 560 :group 'allout) 561;;;_ - allout-title 562(defcustom allout-title '(or buffer-file-name (buffer-name)) 563 "*Expression to be evaluated to determine the title for LaTeX 564formatted copy." 565 :type 'sexp 566 :group 'allout) 567;;;_ - allout-line-skip 568(defcustom allout-line-skip ".05cm" 569 "*Space between lines for LaTeX formatting of an outline." 570 :type 'string 571 :group 'allout) 572;;;_ - allout-indent 573(defcustom allout-indent ".3cm" 574 "*LaTeX formatted depth-indent spacing." 575 :type 'string 576 :group 'allout) 577 578;;;_ + Topic encryption 579;;;_ = allout-encryption group 580(defgroup allout-encryption nil 581 "Settings for topic encryption features of allout outliner." 582 :group 'allout) 583;;;_ = allout-topic-encryption-bullet 584(defcustom allout-topic-encryption-bullet "~" 585 "*Bullet signifying encryption of the entry's body." 586 :type '(choice (const nil) string) 587 :version "22.0" 588 :group 'allout-encryption) 589;;;_ = allout-passphrase-verifier-handling 590(defcustom allout-passphrase-verifier-handling t 591 "*Enable use of symmetric encryption passphrase verifier if non-nil. 592 593See the docstring for the `allout-enable-file-variable-adjustment' 594variable for details about allout ajustment of file variables." 595 :type 'boolean 596 :version "22.0" 597 :group 'allout-encryption) 598(make-variable-buffer-local 'allout-passphrase-verifier-handling) 599;;;_ = allout-passphrase-hint-handling 600(defcustom allout-passphrase-hint-handling 'always 601 "*Dictate outline encryption passphrase reminder handling: 602 603 always - always show reminder when prompting 604 needed - show reminder on passphrase entry failure 605 disabled - never present or adjust reminder 606 607See the docstring for the `allout-enable-file-variable-adjustment' 608variable for details about allout ajustment of file variables." 609 :type '(choice (const always) 610 (const needed) 611 (const disabled)) 612 :version "22.0" 613 :group 'allout-encryption) 614(make-variable-buffer-local 'allout-passphrase-hint-handling) 615;;;_ = allout-encrypt-unencrypted-on-saves 616(defcustom allout-encrypt-unencrypted-on-saves t 617 "*When saving, should topics pending encryption be encrypted? 618 619The idea is to prevent file-system exposure of any un-encrypted stuff, and 620mostly covers both deliberate file writes and auto-saves. 621 622 - Yes: encrypt all topics pending encryption, even if it's the one 623 currently being edited. (In that case, the currently edited topic 624 will be automatically decrypted before any user interaction, so they 625 can continue editing but the copy on the file system will be 626 encrypted.) 627 Auto-saves will use the \"All except current topic\" mode if this 628 one is selected, to avoid practical difficulties - see below. 629 - All except current topic: skip the topic currently being edited, even if 630 it's pending encryption. This may expose the current topic on the 631 file sytem, but avoids the nuisance of prompts for the encryption 632 passphrase in the middle of editing for, eg, autosaves. 633 This mode is used for auto-saves for both this option and \"Yes\". 634 - No: leave it to the user to encrypt any unencrypted topics. 635 636For practical reasons, auto-saves always use the 'except-current policy 637when auto-encryption is enabled. (Otherwise, spurious passphrase prompts 638and unavoidable timing collisions are too disruptive.) If security for a 639file requires that even the current topic is never auto-saved in the clear, 640disable auto-saves for that file." 641 642 :type '(choice (const :tag "Yes" t) 643 (const :tag "All except current topic" except-current) 644 (const :tag "No" nil)) 645 :version "22.0" 646 :group 'allout-encryption) 647(make-variable-buffer-local 'allout-encrypt-unencrypted-on-saves) 648 649;;;_ + Developer 650;;;_ = allout-developer group 651(defgroup allout-developer nil 652 "Settings for topic encryption features of allout outliner." 653 :group 'allout) 654;;;_ = allout-run-unit-tests-on-load 655(defcustom allout-run-unit-tests-on-load nil 656 "*When non-nil, unit tests will be run at end of loading the allout module. 657 658Generally, allout code developers are the only ones who'll want to set this. 659 660\(If set, this makes it an even better practice to exercise changes by 661doing byte-compilation with a repeat count, so the file is loaded after 662compilation.) 663 664See `allout-run-unit-tests' to see what's run." 665 :type 'boolean 666 :group 'allout-developer) 667 668;;;_ + Miscellaneous customization 669 670;;;_ = allout-command-prefix 671(defcustom allout-command-prefix "\C-c " 672 "*Key sequence to be used as prefix for outline mode command key bindings. 673 674Default is '\C-c<space>'; just '\C-c' is more short-and-sweet, if you're 675willing to let allout use a bunch of \C-c keybindings." 676 :type 'string 677 :group 'allout) 678 679;;;_ = allout-keybindings-list 680;;; You have to reactivate allout-mode - `(allout-mode t)' - to 681;;; institute changes to this var. 682(defvar allout-keybindings-list () 683 "*List of `allout-mode' key / function bindings, for `allout-mode-map'. 684 685String or vector key will be prefaced with `allout-command-prefix', 686unless optional third, non-nil element is present.") 687(setq allout-keybindings-list 688 '( 689 ; Motion commands: 690 ("\C-n" allout-next-visible-heading) 691 ("\C-p" allout-previous-visible-heading) 692 ("\C-u" allout-up-current-level) 693 ("\C-f" allout-forward-current-level) 694 ("\C-b" allout-backward-current-level) 695 ("\C-a" allout-beginning-of-current-entry) 696 ("\C-e" allout-end-of-entry) 697 ; Exposure commands: 698 ("\C-i" allout-show-children) 699 ("\C-s" allout-show-current-subtree) 700 ("\C-h" allout-hide-current-subtree) 701 ("h" allout-hide-current-subtree) 702 ("\C-o" allout-show-current-entry) 703 ("!" allout-show-all) 704 ("x" allout-toggle-current-subtree-encryption) 705 ; Alteration commands: 706 (" " allout-open-sibtopic) 707 ("." allout-open-subtopic) 708 ("," allout-open-supertopic) 709 ("'" allout-shift-in) 710 (">" allout-shift-in) 711 ("<" allout-shift-out) 712 ("\C-m" allout-rebullet-topic) 713 ("*" allout-rebullet-current-heading) 714 ("#" allout-number-siblings) 715 ("\C-k" allout-kill-line t) 716 ("\M-k" allout-copy-line-as-kill t) 717 ("\C-y" allout-yank t) 718 ("\M-y" allout-yank-pop t) 719 ("\C-k" allout-kill-topic) 720 ("\M-k" allout-copy-topic-as-kill) 721 ; Miscellaneous commands: 722 ;([?\C-\ ] allout-mark-topic) 723 ("@" allout-resolve-xref) 724 ("=c" allout-copy-exposed-to-buffer) 725 ("=i" allout-indented-exposed-to-buffer) 726 ("=t" allout-latexify-exposed) 727 ("=p" allout-flatten-exposed-to-buffer))) 728 729;;;_ = allout-inhibit-auto-fill 730(defcustom allout-inhibit-auto-fill nil 731 "*If non-nil, auto-fill will be inhibited in the allout buffers. 732 733You can customize this setting to set it for all allout buffers, or set it 734in individual buffers if you want to inhibit auto-fill only in particular 735buffers. (You could use a function on `allout-mode-hook' to inhibit 736auto-fill according, eg, to the major mode.) 737 738If you don't set this and auto-fill-mode is enabled, allout will use the 739value that `normal-auto-fill-function', if any, when allout mode starts, or 740else allout's special hanging-indent maintaining auto-fill function, 741`allout-auto-fill'." 742 :type 'boolean 743 :group 'allout) 744(make-variable-buffer-local 'allout-inhibit-auto-fill) 745 746;;;_ = allout-use-hanging-indents 747(defcustom allout-use-hanging-indents t 748 "*If non-nil, topic body text auto-indent defaults to indent of the header. 749Ie, it is indented to be just past the header prefix. This is 750relevant mostly for use with indented-text-mode, or other situations 751where auto-fill occurs." 752 :type 'boolean 753 :group 'allout) 754(make-variable-buffer-local 'allout-use-hanging-indents) 755;;;###autoload 756(put 'allout-use-hanging-indents 'safe-local-variable 757 (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil))))) 758 759;;;_ = allout-reindent-bodies 760(defcustom allout-reindent-bodies (if allout-use-hanging-indents 761 'text) 762 "*Non-nil enables auto-adjust of topic body hanging indent with depth shifts. 763 764When active, topic body lines that are indented even with or beyond 765their topic header are reindented to correspond with depth shifts of 766the header. 767 768A value of t enables reindent in non-programming-code buffers, ie 769those that do not have the variable `comment-start' set. A value of 770`force' enables reindent whether or not `comment-start' is set." 771 :type '(choice (const nil) (const t) (const text) (const force)) 772 :group 'allout) 773 774(make-variable-buffer-local 'allout-reindent-bodies) 775;;;###autoload 776(put 'allout-reindent-bodies 'safe-local-variable 777 '(lambda (x) (memq x '(nil t text force)))) 778 779;;;_ = allout-enable-file-variable-adjustment 780(defcustom allout-enable-file-variable-adjustment t 781 "*If non-nil, some allout outline actions edit Emacs local file var text. 782 783This can range from changes to existing entries, addition of new ones, 784and creation of a new local variables section when necessary. 785 786Emacs file variables adjustments are also inhibited if `enable-local-variables' 787is nil. 788 789Operations potentially causing edits include allout encryption routines. 790For details, see `allout-toggle-current-subtree-encryption's docstring." 791 :type 'boolean 792 :group 'allout) 793(make-variable-buffer-local 'allout-enable-file-variable-adjustment) 794 795;;;_* CODE - no user customizations below. 796 797;;;_ #1 Internal Outline Formatting and Configuration 798;;;_ : Version 799;;;_ = allout-version 800(defvar allout-version "2.2.1" 801 "Version of currently loaded outline package. (allout.el)") 802;;;_ > allout-version 803(defun allout-version (&optional here) 804 "Return string describing the loaded outline version." 805 (interactive "P") 806 (let ((msg (concat "Allout Outline Mode v " allout-version))) 807 (if here (insert msg)) 808 (message "%s" msg) 809 msg)) 810;;;_ : Mode activation (defined here because it's referenced early) 811;;;_ = allout-mode 812(defvar allout-mode nil "Allout outline mode minor-mode flag.") 813(make-variable-buffer-local 'allout-mode) 814;;;_ = allout-layout nil 815(defvar allout-layout nil ; LEAVE GLOBAL VALUE NIL - see docstring. 816 "Buffer-specific setting for allout layout. 817 818In buffers where this is non-nil (and if `allout-init' has been run, to 819enable this behavior), `allout-mode' will be automatically activated. The 820layout dictated by the value will be used to set the initial exposure when 821`allout-mode' is activated. 822 823\*You should not setq-default this variable non-nil unless you want every 824visited file to be treated as an allout file.* 825 826The value would typically be set by a file local variable. For 827example, the following lines at the bottom of an Emacs Lisp file: 828 829;;;Local variables: 830;;;allout-layout: (0 : -1 -1 0) 831;;;End: 832 833dictate activation of `allout-mode' mode when the file is visited 834\(presuming allout-init was already run), followed by the 835equivalent of `(allout-expose-topic 0 : -1 -1 0)'. (This is 836the layout used for the allout.el source file.) 837 838`allout-default-layout' describes the specification format. 839`allout-layout' can additionally have the value `t', in which 840case the value of `allout-default-layout' is used.") 841(make-variable-buffer-local 'allout-layout) 842;;;###autoload 843(put 'allout-layout 'safe-local-variable 844 '(lambda (x) (or (numberp x) (listp x) (memq x '(: * + -))))) 845 846;;;_ : Topic header format 847;;;_ = allout-regexp 848(defvar allout-regexp "" 849 "*Regular expression to match the beginning of a heading line. 850 851Any line whose beginning matches this regexp is considered a 852heading. This var is set according to the user configuration vars 853by `set-allout-regexp'.") 854(make-variable-buffer-local 'allout-regexp) 855;;;_ = allout-bullets-string 856(defvar allout-bullets-string "" 857 "A string dictating the valid set of outline topic bullets. 858 859This var should *not* be set by the user - it is set by `set-allout-regexp', 860and is produced from the elements of `allout-plain-bullets-string' 861and `allout-distinctive-bullets-string'.") 862(make-variable-buffer-local 'allout-bullets-string) 863;;;_ = allout-bullets-string-len 864(defvar allout-bullets-string-len 0 865 "Length of current buffers' `allout-plain-bullets-string'.") 866(make-variable-buffer-local 'allout-bullets-string-len) 867;;;_ = allout-depth-specific-regexp 868(defvar allout-depth-specific-regexp "" 869 "*Regular expression to match a heading line prefix for a particular depth. 870 871This expression is used to search for depth-specific topic 872headers at depth 2 and greater. Use `allout-depth-one-regexp' 873for to seek topics at depth one. 874 875This var is set according to the user configuration vars by 876`set-allout-regexp'. It is prepared with format strings for two 877decimal numbers, which should each be one less than the depth of the 878topic prefix to be matched.") 879(make-variable-buffer-local 'allout-depth-specific-regexp) 880;;;_ = allout-depth-one-regexp 881(defvar allout-depth-one-regexp "" 882 "*Regular expression to match a heading line prefix for depth one. 883 884This var is set according to the user configuration vars by 885`set-allout-regexp'. It is prepared with format strings for two 886decimal numbers, which should each be one less than the depth of the 887topic prefix to be matched.") 888(make-variable-buffer-local 'allout-depth-one-regexp) 889;;;_ = allout-line-boundary-regexp 890(defvar allout-line-boundary-regexp () 891 "`allout-regexp' with outline style beginning-of-line anchor. 892 893This is properly set by `set-allout-regexp'.") 894(make-variable-buffer-local 'allout-line-boundary-regexp) 895;;;_ = allout-bob-regexp 896(defvar allout-bob-regexp () 897 "Like `allout-line-boundary-regexp', for headers at beginning of buffer.") 898(make-variable-buffer-local 'allout-bob-regexp) 899;;;_ = allout-header-subtraction 900(defvar allout-header-subtraction (1- (length allout-header-prefix)) 901 "Allout-header prefix length to subtract when computing topic depth.") 902(make-variable-buffer-local 'allout-header-subtraction) 903;;;_ = allout-plain-bullets-string-len 904(defvar allout-plain-bullets-string-len (length allout-plain-bullets-string) 905 "Length of `allout-plain-bullets-string', updated by `set-allout-regexp'.") 906(make-variable-buffer-local 'allout-plain-bullets-string-len) 907 908;;;_ = allout-doublecheck-at-and-shallower 909(defconst allout-doublecheck-at-and-shallower 2 910 "Validate apparent topics of this depth and shallower as being non-aberrant. 911 912Verified with `allout-aberrant-container-p'. This check's usefulness is 913limited to shallow depths, because the determination of aberrance 914is according to the mistaken item being followed by a legitimate item of 915excessively greater depth.") 916;;;_ X allout-reset-header-lead (header-lead) 917(defun allout-reset-header-lead (header-lead) 918 "*Reset the leading string used to identify topic headers." 919 (interactive "sNew lead string: ") 920 (setq allout-header-prefix header-lead) 921 (setq allout-header-subtraction (1- (length allout-header-prefix))) 922 (set-allout-regexp)) 923;;;_ X allout-lead-with-comment-string (header-lead) 924(defun allout-lead-with-comment-string (&optional header-lead) 925 "*Set the topic-header leading string to specified string. 926 927Useful when for encapsulating outline structure in programming 928language comments. Returns the leading string." 929 930 (interactive "P") 931 (if (not (stringp header-lead)) 932 (setq header-lead (read-string 933 "String prefix for topic headers: "))) 934 (setq allout-reindent-bodies nil) 935 (allout-reset-header-lead header-lead) 936 header-lead) 937;;;_ > allout-infer-header-lead-and-primary-bullet () 938(defun allout-infer-header-lead-and-primary-bullet () 939 "Determine appropriate `allout-header-prefix' and `allout-primary-bullet'. 940 941Works according to settings of: 942 943 `comment-start' 944 `allout-header-prefix' (default) 945 `allout-use-mode-specific-leader' 946and `allout-mode-leaders'. 947 948Apply this via (re)activation of `allout-mode', rather than 949invoking it directly." 950 (let* ((use-leader (and (boundp 'allout-use-mode-specific-leader) 951 (if (or (stringp allout-use-mode-specific-leader) 952 (memq allout-use-mode-specific-leader 953 '(allout-mode-leaders 954 comment-start 955 t))) 956 allout-use-mode-specific-leader 957 ;; Oops - garbled value, equate with effect of 't: 958 t))) 959 (leader 960 (cond 961 ((not use-leader) nil) 962 ;; Use the explicitly designated leader: 963 ((stringp use-leader) use-leader) 964 (t (or (and (memq use-leader '(t allout-mode-leaders)) 965 ;; Get it from outline mode leaders? 966 (cdr (assq major-mode allout-mode-leaders))) 967 ;; ... didn't get from allout-mode-leaders... 968 (and (memq use-leader '(t comment-start)) 969 comment-start 970 ;; Use comment-start, maybe tripled, and with 971 ;; underscore: 972 (concat 973 (if (string= " " 974 (substring comment-start 975 (1- (length comment-start)))) 976 ;; Use comment-start, sans trailing space: 977 (substring comment-start 0 -1) 978 (concat comment-start comment-start comment-start)) 979 ;; ... and append underscore, whichever: 980 "_"))))))) 981 (if (not leader) 982 nil 983 (setq allout-header-prefix leader) 984 (if (not allout-old-style-prefixes) 985 ;; setting allout-primary-bullet makes the top level topics use - 986 ;; actually, be - the special prefix: 987 (setq allout-primary-bullet leader)) 988 allout-header-prefix))) 989(defalias 'allout-infer-header-lead 990 'allout-infer-header-lead-and-primary-bullet) 991;;;_ > allout-infer-body-reindent () 992(defun allout-infer-body-reindent () 993 "Determine proper setting for `allout-reindent-bodies'. 994 995Depends on default setting of `allout-reindent-bodies' (which see) 996and presence of setting for `comment-start', to tell whether the 997file is programming code." 998 (if (and allout-reindent-bodies 999 comment-start 1000 (not (eq 'force allout-reindent-bodies))) 1001 (setq allout-reindent-bodies nil))) 1002;;;_ > set-allout-regexp () 1003(defun set-allout-regexp () 1004 "Generate proper topic-header regexp form for outline functions. 1005 1006Works with respect to `allout-plain-bullets-string' and 1007`allout-distinctive-bullets-string'. 1008 1009Also refresh various data structures that hinge on the regexp." 1010 1011 (interactive) 1012 ;; Derive allout-bullets-string from user configured components: 1013 (setq allout-bullets-string "") 1014 (let ((strings (list 'allout-plain-bullets-string 1015 'allout-distinctive-bullets-string 1016 'allout-primary-bullet)) 1017 cur-string 1018 cur-len 1019 cur-char 1020 index) 1021 (while strings 1022 (setq index 0) 1023 (setq cur-len (length (setq cur-string (symbol-value (car strings))))) 1024 (while (< index cur-len) 1025 (setq cur-char (aref cur-string index)) 1026 (setq allout-bullets-string 1027 (concat allout-bullets-string 1028 (cond 1029 ; Single dash would denote a 1030 ; sequence, repeated denotes 1031 ; a dash: 1032 ((eq cur-char ?-) "--") 1033 ; literal close-square-bracket 1034 ; doesn't work right in the 1035 ; expr, exclude it: 1036 ((eq cur-char ?\]) "") 1037 (t (regexp-quote (char-to-string cur-char)))))) 1038 (setq index (1+ index))) 1039 (setq strings (cdr strings))) 1040 ) 1041 ;; Derive next for repeated use in allout-pending-bullet: 1042 (setq allout-plain-bullets-string-len (length allout-plain-bullets-string)) 1043 (setq allout-header-subtraction (1- (length allout-header-prefix))) 1044 1045 (let (new-part old-part) 1046 (setq new-part (concat "\\(" 1047 (regexp-quote allout-header-prefix) 1048 "[ \t]*" 1049 ;; already regexp-quoted in a custom way: 1050 "[" allout-bullets-string "]" 1051 "\\)") 1052 old-part (concat "\\(" 1053 (regexp-quote allout-primary-bullet) 1054 "\\|" 1055 (regexp-quote allout-header-prefix) 1056 "\\)" 1057 "+" 1058 " ?[^" allout-primary-bullet "]") 1059 allout-regexp (concat new-part 1060 "\\|" 1061 old-part 1062 "\\|\^l") 1063 1064 allout-line-boundary-regexp (concat "\n" new-part 1065 "\\|" 1066 "\n" old-part) 1067 1068 allout-bob-regexp (concat "\\`" new-part 1069 "\\|" 1070 "\\`" old-part)) 1071 1072 (setq allout-depth-specific-regexp 1073 (concat "\\(^\\|\\`\\)" 1074 "\\(" 1075 1076 ;; new-style spacers-then-bullet string: 1077 "\\(" 1078 (allout-format-quote (regexp-quote allout-header-prefix)) 1079 " \\{%s\\}" 1080 "[" (allout-format-quote allout-bullets-string) "]" 1081 "\\)" 1082 1083 ;; old-style all-bullets string, if primary not multi-char: 1084 (if (< 0 allout-header-subtraction) 1085 "" 1086 (concat "\\|\\(" 1087 (allout-format-quote 1088 (regexp-quote allout-primary-bullet)) 1089 (allout-format-quote 1090 (regexp-quote allout-primary-bullet)) 1091 (allout-format-quote 1092 (regexp-quote allout-primary-bullet)) 1093 "\\{%s\\}" 1094 ;; disqualify greater depths: 1095 "[^" 1096 (allout-format-quote allout-primary-bullet) 1097 "]\\)" 1098 )) 1099 "\\)" 1100 )) 1101 (setq allout-depth-one-regexp 1102 (concat "\\(^\\|\\`\\)" 1103 "\\(" 1104 1105 "\\(" 1106 (regexp-quote allout-header-prefix) 1107 ;; disqualify any bullet char following any amount of 1108 ;; intervening whitespace: 1109 " *" 1110 (concat "[^ " allout-bullets-string "]") 1111 "\\)" 1112 (if (< 0 allout-header-subtraction) 1113 ;; Need not support anything like the old 1114 ;; bullet style if the prefix is multi-char. 1115 "" 1116 (concat "\\|" 1117 (regexp-quote allout-primary-bullet) 1118 ;; disqualify deeper primary-bullet sequences: 1119 "[^" allout-primary-bullet "]")) 1120 "\\)" 1121 )))) 1122;;;_ : Key bindings 1123;;;_ = allout-mode-map 1124(defvar allout-mode-map nil "Keybindings for (allout) outline minor mode.") 1125;;;_ > produce-allout-mode-map (keymap-alist &optional base-map) 1126(defun produce-allout-mode-map (keymap-list &optional base-map) 1127 "Produce keymap for use as allout-mode-map, from KEYMAP-LIST. 1128 1129Built on top of optional BASE-MAP, or empty sparse map if none specified. 1130See doc string for allout-keybindings-list for format of binding list." 1131 (let ((map (or base-map (make-sparse-keymap))) 1132 (pref (list allout-command-prefix))) 1133 (mapcar (function 1134 (lambda (cell) 1135 (let ((add-pref (null (cdr (cdr cell)))) 1136 (key-suff (list (car cell)))) 1137 (apply 'define-key 1138 (list map 1139 (apply 'concat (if add-pref 1140 (append pref key-suff) 1141 key-suff)) 1142 (car (cdr cell))))))) 1143 keymap-list) 1144 map)) 1145;;;_ : Menu bar 1146(defvar allout-mode-exposure-menu) 1147(defvar allout-mode-editing-menu) 1148(defvar allout-mode-navigation-menu) 1149(defvar allout-mode-misc-menu) 1150(defun produce-allout-mode-menubar-entries () 1151 (require 'easymenu) 1152 (easy-menu-define allout-mode-exposure-menu 1153 allout-mode-map 1154 "Allout outline exposure menu." 1155 '("Exposure" 1156 ["Show Entry" allout-show-current-entry t] 1157 ["Show Children" allout-show-children t] 1158 ["Show Subtree" allout-show-current-subtree t] 1159 ["Hide Subtree" allout-hide-current-subtree t] 1160 ["Hide Leaves" allout-hide-current-leaves t] 1161 "----" 1162 ["Show All" allout-show-all t])) 1163 (easy-menu-define allout-mode-editing-menu 1164 allout-mode-map 1165 "Allout outline editing menu." 1166 '("Headings" 1167 ["Open Sibling" allout-open-sibtopic t] 1168 ["Open Subtopic" allout-open-subtopic t] 1169 ["Open Supertopic" allout-open-supertopic t] 1170 "----" 1171 ["Shift Topic In" allout-shift-in t] 1172 ["Shift Topic Out" allout-shift-out t] 1173 ["Rebullet Topic" allout-rebullet-topic t] 1174 ["Rebullet Heading" allout-rebullet-current-heading t] 1175 ["Number Siblings" allout-number-siblings t] 1176 "----" 1177 ["Toggle Topic Encryption" 1178 allout-toggle-current-subtree-encryption 1179 (> (allout-current-depth) 1)])) 1180 (easy-menu-define allout-mode-navigation-menu 1181 allout-mode-map 1182 "Allout outline navigation menu." 1183 '("Navigation" 1184 ["Next Visible Heading" allout-next-visible-heading t] 1185 ["Previous Visible Heading" 1186 allout-previous-visible-heading t] 1187 "----" 1188 ["Up Level" allout-up-current-level t] 1189 ["Forward Current Level" allout-forward-current-level t] 1190 ["Backward Current Level" 1191 allout-backward-current-level t] 1192 "----" 1193 ["Beginning of Entry" 1194 allout-beginning-of-current-entry t] 1195 ["End of Entry" allout-end-of-entry t] 1196 ["End of Subtree" allout-end-of-current-subtree t])) 1197 (easy-menu-define allout-mode-misc-menu 1198 allout-mode-map 1199 "Allout outlines miscellaneous bindings." 1200 '("Misc" 1201 ["Version" allout-version t] 1202 "----" 1203 ["Duplicate Exposed" allout-copy-exposed-to-buffer t] 1204 ["Duplicate Exposed, numbered" 1205 allout-flatten-exposed-to-buffer t] 1206 ["Duplicate Exposed, indented" 1207 allout-indented-exposed-to-buffer t] 1208 "----" 1209 ["Set Header Lead" allout-reset-header-lead t] 1210 ["Set New Exposure" allout-expose-topic t]))) 1211;;;_ : Allout Modal-Variables Utilities 1212;;;_ = allout-mode-prior-settings 1213(defvar allout-mode-prior-settings nil 1214 "Internal `allout-mode' use; settings to be resumed on mode deactivation. 1215 1216See `allout-add-resumptions' and `allout-do-resumptions'.") 1217(make-variable-buffer-local 'allout-mode-prior-settings) 1218;;;_ > allout-add-resumptions (&rest pairs) 1219(defun allout-add-resumptions (&rest pairs) 1220 "Set name/value PAIRS. 1221 1222Old settings are preserved for later resumption using `allout-do-resumptions'. 1223 1224The new values are set as a buffer local. On resumption, the prior buffer 1225scope of the variable is restored along with its value. If it was a void 1226buffer-local value, then it is left as nil on resumption. 1227 1228The pairs are lists whose car is the name of the variable and car of the 1229cdr is the new value: '(some-var some-value)'. The pairs can actually be 1230triples, where the third element qualifies the disposition of the setting, 1231as described further below. 1232 1233If the optional third element is the symbol 'extend, then the new value 1234created by `cons'ing the second element of the pair onto the front of the 1235existing value. 1236 1237If the optional third element is the symbol 'append, then the new value is 1238extended from the existing one by `append'ing a list containing the second 1239element of the pair onto the end of the existing value. 1240 1241Extension, and resumptions in general, should not be used for hook 1242functions - use the 'local mode of `add-hook' for that, instead. 1243 1244The settings are stored on `allout-mode-prior-settings'." 1245 (while pairs 1246 (let* ((pair (pop pairs)) 1247 (name (car pair)) 1248 (value (cadr pair)) 1249 (qualifier (if (> (length pair) 2) 1250 (caddr pair))) 1251 prior-value) 1252 (if (not (symbolp name)) 1253 (error "Pair's name, %S, must be a symbol, not %s" 1254 name (type-of name))) 1255 (setq prior-value (condition-case nil 1256 (symbol-value name) 1257 (void-variable nil))) 1258 (when (not (assoc name allout-mode-prior-settings)) 1259 ;; Not already added as a resumption, create the prior setting entry. 1260 (if (local-variable-p name) 1261 ;; is already local variable - preserve the prior value: 1262 (push (list name prior-value) allout-mode-prior-settings) 1263 ;; wasn't local variable, indicate so for resumption by killing 1264 ;; local value, and make it local: 1265 (push (list name) allout-mode-prior-settings) 1266 (make-local-variable name))) 1267 (if qualifier 1268 (cond ((eq qualifier 'extend) 1269 (if (not (listp prior-value)) 1270 (error "extension of non-list prior value attempted") 1271 (set name (cons value prior-value)))) 1272 ((eq qualifier 'append) 1273 (if (not (listp prior-value)) 1274 (error "appending of non-list prior value attempted") 1275 (set name (append prior-value (list value))))) 1276 (t (error "unrecognized setting qualifier `%s' encountered" 1277 qualifier))) 1278 (set name value))))) 1279;;;_ > allout-do-resumptions () 1280(defun allout-do-resumptions () 1281 "Resume all name/value settings registered by `allout-add-resumptions'. 1282 1283This is used when concluding allout-mode, to resume selected variables to 1284their settings before allout-mode was started." 1285 1286 (while allout-mode-prior-settings 1287 (let* ((pair (pop allout-mode-prior-settings)) 1288 (name (car pair)) 1289 (value-cell (cdr pair))) 1290 (if (not value-cell) 1291 ;; Prior value was global: 1292 (kill-local-variable name) 1293 ;; Prior value was explicit: 1294 (set name (car value-cell)))))) 1295;;;_ : Mode-specific incidentals 1296;;;_ > allout-unprotected (expr) 1297(defmacro allout-unprotected (expr) 1298 "Enable internal outline operations to alter invisible text." 1299 `(let ((inhibit-read-only (if (not buffer-read-only) t)) 1300 (inhibit-field-text-motion t)) 1301 ,expr)) 1302;;;_ = allout-mode-hook 1303(defvar allout-mode-hook nil 1304 "*Hook that's run when allout mode starts.") 1305;;;_ = allout-mode-deactivate-hook 1306(defvar allout-mode-deactivate-hook nil 1307 "*Hook that's run when allout mode ends.") 1308;;;_ = allout-exposure-category 1309(defvar allout-exposure-category nil 1310 "Symbol for use as allout invisible-text overlay category.") 1311;;;_ x allout-view-change-hook 1312(defvar allout-view-change-hook nil 1313 "*(Deprecated) A hook run after allout outline exposure changes. 1314 1315Switch to using `allout-exposure-change-hook' instead. Both hooks are 1316currently respected, but the other conveys the details of the exposure 1317change via explicit parameters, and this one will eventually be disabled in 1318a subsequent allout version.") 1319;;;_ = allout-exposure-change-hook 1320(defvar allout-exposure-change-hook nil 1321 "*Hook that's run after allout outline subtree exposure changes. 1322 1323It is run at the conclusion of `allout-flag-region'. 1324 1325Functions on the hook must take three arguments: 1326 1327 - from - integer indicating the point at the start of the change. 1328 - to - integer indicating the point of the end of the change. 1329 - flag - change mode: nil for exposure, otherwise concealment. 1330 1331This hook might be invoked multiple times by a single command. 1332 1333This hook is replacing `allout-view-change-hook', which is being deprecated 1334and eventually will not be invoked.") 1335;;;_ = allout-structure-added-hook 1336(defvar allout-structure-added-hook nil 1337 "*Hook that's run after addition of items to the outline. 1338 1339Functions on the hook should take two arguments: 1340 1341 - new-start - integer indicating the point at the start of the first new item. 1342 - new-end - integer indicating the point of the end of the last new item. 1343 1344Some edits that introduce new items may missed by this hook - 1345specifically edits that native allout routines do not control. 1346 1347This hook might be invoked multiple times by a single command.") 1348;;;_ = allout-structure-deleted-hook 1349(defvar allout-structure-deleted-hook nil 1350 "*Hook that's run after disciplined deletion of subtrees from the outline. 1351 1352Functions on the hook must take two arguments: 1353 1354 - depth - integer indicating the depth of the subtree that was deleted. 1355 - removed-from - integer indicating the point where the subtree was removed. 1356 1357Some edits that remove or invalidate items may missed by this hook - 1358specifically edits that native allout routines do not control. 1359 1360This hook might be invoked multiple times by a single command.") 1361;;;_ = allout-structure-shifted-hook 1362(defvar allout-structure-shifted-hook nil 1363 "*Hook that's run after shifting of items in the outline. 1364 1365Functions on the hook should take two arguments: 1366 1367 - depth-change - integer indicating depth increase, negative for decrease 1368 - start - integer indicating the start point of the shifted parent item. 1369 1370Some edits that shift items can be missed by this hook - specifically edits 1371that native allout routines do not control. 1372 1373This hook might be invoked multiple times by a single command.") 1374;;;_ = allout-outside-normal-auto-fill-function 1375(defvar allout-outside-normal-auto-fill-function nil 1376 "Value of normal-auto-fill-function outside of allout mode. 1377 1378Used by allout-auto-fill to do the mandated normal-auto-fill-function 1379wrapped within allout's automatic fill-prefix setting.") 1380(make-variable-buffer-local 'allout-outside-normal-auto-fill-function) 1381;;;_ = file-var-bug hack 1382(defvar allout-v18/19-file-var-hack nil 1383 "Horrible hack used to prevent invalid multiple triggering of outline 1384mode from prop-line file-var activation. Used by `allout-mode' function 1385to track repeats.") 1386;;;_ = allout-passphrase-verifier-string 1387(defvar allout-passphrase-verifier-string nil 1388 "Setting used to test solicited encryption passphrases against the one 1389already associated with a file. 1390 1391It consists of an encrypted random string useful only to verify that a 1392passphrase entered by the user is effective for decryption. The passphrase 1393itself is \*not* recorded in the file anywhere, and the encrypted contents 1394are random binary characters to avoid exposing greater susceptibility to 1395search attacks. 1396 1397The verifier string is retained as an Emacs file variable, as well as in 1398the Emacs buffer state, if file variable adjustments are enabled. See 1399`allout-enable-file-variable-adjustment' for details about that.") 1400(make-variable-buffer-local 'allout-passphrase-verifier-string) 1401;;;###autoload 1402(put 'allout-passphrase-verifier-string 'safe-local-variable 'stringp) 1403;;;_ = allout-passphrase-hint-string 1404(defvar allout-passphrase-hint-string "" 1405 "Variable used to retain reminder string for file's encryption passphrase. 1406 1407See the description of `allout-passphrase-hint-handling' for details about how 1408the reminder is deployed. 1409 1410The hint is retained as an Emacs file variable, as well as in the Emacs buffer 1411state, if file variable adjustments are enabled. See 1412`allout-enable-file-variable-adjustment' for details about that.") 1413(make-variable-buffer-local 'allout-passphrase-hint-string) 1414(setq-default allout-passphrase-hint-string "") 1415;;;###autoload 1416(put 'allout-passphrase-hint-string 'safe-local-variable 'stringp) 1417;;;_ = allout-after-save-decrypt 1418(defvar allout-after-save-decrypt nil 1419 "Internal variable, is nil or has the value of two points: 1420 1421 - the location of a topic to be decrypted after saving is done 1422 - where to situate the cursor after the decryption is performed 1423 1424This is used to decrypt the topic that was currently being edited, if it 1425was encrypted automatically as part of a file write or autosave.") 1426(make-variable-buffer-local 'allout-after-save-decrypt) 1427;;;_ = allout-encryption-plaintext-sanitization-regexps 1428(defvar allout-encryption-plaintext-sanitization-regexps nil 1429 "List of regexps whose matches are removed from plaintext before encryption. 1430 1431This is for the sake of removing artifacts, like escapes, that are added on 1432and not actually part of the original plaintext. The removal is done just 1433prior to encryption. 1434 1435Entries must be symbols that are bound to the desired values. 1436 1437Each value can be a regexp or a list with a regexp followed by a 1438substitution string. If it's just a regexp, all its matches are removed 1439before the text is encrypted. If it's a regexp and a substitution, the 1440substition is used against the regexp matches, a la `replace-match'.") 1441(make-variable-buffer-local 'allout-encryption-text-removal-regexps) 1442;;;_ = allout-encryption-ciphertext-rejection-regexps 1443(defvar allout-encryption-ciphertext-rejection-regexps nil 1444 "Variable for regexps matching plaintext to remove before encryption. 1445 1446This is for the sake of redoing encryption in cases where the ciphertext 1447incidentally contains strings that would disrupt mode operation - 1448for example, a line that happens to look like an allout-mode topic prefix. 1449 1450Entries must be symbols that are bound to the desired regexp values. 1451 1452The encryption will be retried up to 1453`allout-encryption-ciphertext-rejection-limit' times, after which an error 1454is raised.") 1455 1456(make-variable-buffer-local 'allout-encryption-ciphertext-rejection-regexps) 1457;;;_ = allout-encryption-ciphertext-rejection-ceiling 1458(defvar allout-encryption-ciphertext-rejection-ceiling 5 1459 "Limit on number of times encryption ciphertext is rejected. 1460 1461See `allout-encryption-ciphertext-rejection-regexps' for rejection reasons.") 1462(make-variable-buffer-local 'allout-encryption-ciphertext-rejection-ceiling) 1463;;;_ > allout-mode-p () 1464;; Must define this macro above any uses, or byte compilation will lack 1465;; proper def, if file isn't loaded - eg, during emacs build! 1466(defmacro allout-mode-p () 1467 "Return t if `allout-mode' is active in current buffer." 1468 'allout-mode) 1469;;;_ > allout-write-file-hook-handler () 1470(defun allout-write-file-hook-handler () 1471 "Implement `allout-encrypt-unencrypted-on-saves' policy for file writes." 1472 1473 (if (or (not (allout-mode-p)) 1474 (not (boundp 'allout-encrypt-unencrypted-on-saves)) 1475 (not allout-encrypt-unencrypted-on-saves)) 1476 nil 1477 (let ((except-mark (and (equal allout-encrypt-unencrypted-on-saves 1478 'except-current) 1479 (point-marker)))) 1480 (if (save-excursion (goto-char (point-min)) 1481 (allout-next-topic-pending-encryption except-mark)) 1482 (progn 1483 (message "auto-encrypting pending topics") 1484 (sit-for 0) 1485 (condition-case failure 1486 (setq allout-after-save-decrypt 1487 (allout-encrypt-decrypted except-mark)) 1488 (error (progn 1489 (message 1490 "allout-write-file-hook-handler suppressing error %s" 1491 failure) 1492 (sit-for 2)))))) 1493 )) 1494 nil) 1495;;;_ > allout-auto-save-hook-handler () 1496(defun allout-auto-save-hook-handler () 1497 "Implement `allout-encrypt-unencrypted-on-saves' policy for auto save." 1498 1499 (if (and (allout-mode-p) allout-encrypt-unencrypted-on-saves) 1500 ;; Always implement 'except-current policy when enabled. 1501 (let ((allout-encrypt-unencrypted-on-saves 'except-current)) 1502 (allout-write-file-hook-handler)))) 1503;;;_ > allout-after-saves-handler () 1504(defun allout-after-saves-handler () 1505 "Decrypt topic encrypted for save, if it's currently being edited. 1506 1507Ie, if it was pending encryption and contained the point in its body before 1508the save. 1509 1510We use values stored in `allout-after-save-decrypt' to locate the topic 1511and the place for the cursor after the decryption is done." 1512 (if (not (and (allout-mode-p) 1513 (boundp 'allout-after-save-decrypt) 1514 allout-after-save-decrypt)) 1515 t 1516 (goto-char (car allout-after-save-decrypt)) 1517 (let ((was-modified (buffer-modified-p))) 1518 (allout-toggle-subtree-encryption) 1519 (if (not was-modified) 1520 (set-buffer-modified-p nil))) 1521 (goto-char (cadr allout-after-save-decrypt)) 1522 (setq allout-after-save-decrypt nil)) 1523 ) 1524;;;_ = allout-inhibit-aberrance-doublecheck nil 1525;; In some exceptional moments, disparate topic depths need to be allowed 1526;; momentarily, eg when one topic is being yanked into another and they're 1527;; about to be reconciled. let-binding allout-inhibit-aberrance-doublecheck 1528;; prevents the aberrance doublecheck to allow, eg, the reconciliation 1529;; processing to happen in the presence of such discrepancies. It should 1530;; almost never be needed, however. 1531(defvar allout-inhibit-aberrance-doublecheck nil 1532 "Internal state, for momentarily inhibits aberrance doublecheck. 1533 1534This should only be momentarily let-bound non-nil, not set 1535non-nil in a lasting way.") 1536 1537;;;_ #2 Mode activation 1538;;;_ = allout-explicitly-deactivated 1539(defvar allout-explicitly-deactivated nil 1540 "If t, `allout-mode's last deactivation was deliberate. 1541So `allout-post-command-business' should not reactivate it...") 1542(make-variable-buffer-local 'allout-explicitly-deactivated) 1543;;;_ > allout-init (&optional mode) 1544(defun allout-init (&optional mode) 1545 "Prime `allout-mode' to enable/disable auto-activation, wrt `allout-layout'. 1546 1547MODE is one of the following symbols: 1548 1549 - nil (or no argument) deactivate auto-activation/layout; 1550 - `activate', enable auto-activation only; 1551 - `ask', enable auto-activation, and enable auto-layout but with 1552 confirmation for layout operation solicited from user each time; 1553 - `report', just report and return the current auto-activation state; 1554 - anything else (eg, t) for auto-activation and auto-layout, without 1555 any confirmation check. 1556 1557Use this function to setup your Emacs session for automatic activation 1558of allout outline mode, contingent to the buffer-specific setting of 1559the `allout-layout' variable. (See `allout-layout' and 1560`allout-expose-topic' docstrings for more details on auto layout). 1561 1562`allout-init' works by setting up (or removing) the `allout-mode' 1563find-file-hook, and giving `allout-auto-activation' a suitable 1564setting. 1565 1566To prime your Emacs session for full auto-outline operation, include 1567the following two lines in your Emacs init file: 1568 1569\(require 'allout) 1570\(allout-init t)" 1571 1572 (interactive) 1573 (if (interactive-p) 1574 (progn 1575 (setq mode 1576 (completing-read 1577 (concat "Select outline auto setup mode " 1578 "(empty for report, ? for options) ") 1579 '(("nil")("full")("activate")("deactivate") 1580 ("ask") ("report") ("")) 1581 nil 1582 t)) 1583 (if (string= mode "") 1584 (setq mode 'report) 1585 (setq mode (intern-soft mode))))) 1586 (let 1587 ;; convenience aliases, for consistent ref to respective vars: 1588 ((hook 'allout-find-file-hook) 1589 (find-file-hook-var-name (if (boundp 'find-file-hook) 1590 'find-file-hook 1591 'find-file-hooks)) 1592 (curr-mode 'allout-auto-activation)) 1593 1594 (cond ((not mode) 1595 (set find-file-hook-var-name 1596 (delq hook (symbol-value find-file-hook-var-name))) 1597 (if (interactive-p) 1598 (message "Allout outline mode auto-activation inhibited."))) 1599 ((eq mode 'report) 1600 (if (not (memq hook (symbol-value find-file-hook-var-name))) 1601 (allout-init nil) 1602 ;; Just punt and use the reports from each of the modes: 1603 (allout-init (symbol-value curr-mode)))) 1604 (t (add-hook find-file-hook-var-name hook) 1605 (set curr-mode ; `set', not `setq'! 1606 (cond ((eq mode 'activate) 1607 (message 1608 "Outline mode auto-activation enabled.") 1609 'activate) 1610 ((eq mode 'report) 1611 ;; Return the current mode setting: 1612 (allout-init mode)) 1613 ((eq mode 'ask) 1614 (message 1615 (concat "Outline mode auto-activation and " 1616 "-layout (upon confirmation) enabled.")) 1617 'ask) 1618 ((message 1619 "Outline mode auto-activation and -layout enabled.") 1620 'full))))))) 1621;;;_ > allout-setup-menubar () 1622(defun allout-setup-menubar () 1623 "Populate the current buffer's menubar with `allout-mode' stuff." 1624 (let ((menus (list allout-mode-exposure-menu 1625 allout-mode-editing-menu 1626 allout-mode-navigation-menu 1627 allout-mode-misc-menu)) 1628 cur) 1629 (while menus 1630 (setq cur (car menus) 1631 menus (cdr menus)) 1632 (easy-menu-add cur)))) 1633;;;_ > allout-overlay-preparations 1634(defun allout-overlay-preparations () 1635 "Set the properties of the allout invisible-text overlay and others." 1636 (setplist 'allout-exposure-category nil) 1637 (put 'allout-exposure-category 'invisible 'allout) 1638 (put 'allout-exposure-category 'evaporate t) 1639 ;; XXX We use isearch-open-invisible *and* isearch-mode-end-hook. The 1640 ;; latter would be sufficient, but it seems that a separate behavior - 1641 ;; the _transient_ opening of invisible text during isearch - is keyed to 1642 ;; presence of the isearch-open-invisible property - even though this 1643 ;; property controls the isearch _arrival_ behavior. This is the case at 1644 ;; least in emacs 21, 22.0, and xemacs 21.4. 1645 (put 'allout-exposure-category 'isearch-open-invisible 1646 'allout-isearch-end-handler) 1647 (if (featurep 'xemacs) 1648 (put 'allout-exposure-category 'start-open t) 1649 (put 'allout-exposure-category 'insert-in-front-hooks 1650 '(allout-overlay-insert-in-front-handler))) 1651 (put 'allout-exposure-category 'modification-hooks 1652 '(allout-overlay-interior-modification-handler))) 1653;;;_ > allout-mode (&optional toggle) 1654;;;_ : Defun: 1655;;;###autoload 1656(defun allout-mode (&optional toggle) 1657;;;_ . Doc string: 1658 "Toggle minor mode for controlling exposure and editing of text outlines. 1659\\<allout-mode-map> 1660 1661Optional arg forces mode to re-initialize iff arg is positive num or 1662symbol. Allout outline mode always runs as a minor mode. 1663 1664Allout outline mode provides extensive outline oriented formatting and 1665manipulation. It enables structural editing of outlines, as well as 1666navigation and exposure. It also is specifically aimed at 1667accommodating syntax-sensitive text like programming languages. (For 1668an example, see the allout code itself, which is organized as an allout 1669outline.) 1670 1671In addition to typical outline navigation and exposure, allout includes: 1672 1673 - topic-oriented authoring, including keystroke-based topic creation, 1674 repositioning, promotion/demotion, cut, and paste 1675 - incremental search with dynamic exposure and reconcealment of hidden text 1676 - adjustable format, so programming code can be developed in outline-structure 1677 - easy topic encryption and decryption 1678 - \"Hot-spot\" operation, for single-keystroke maneuvering and exposure control 1679 - integral outline layout, for automatic initial exposure when visiting a file 1680 - independent extensibility, using comprehensive exposure and authoring hooks 1681 1682and many other features. 1683 1684Below is a description of the key bindings, and then explanation of 1685special `allout-mode' features and terminology. See also the outline 1686menubar additions for quick reference to many of the features, and see 1687the docstring of the function `allout-init' for instructions on 1688priming your emacs session for automatic activation of `allout-mode'. 1689 1690The bindings are dictated by the customizable `allout-keybindings-list' 1691variable. We recommend customizing `allout-command-prefix' to use just 1692`\\C-c' as the command prefix, if the allout bindings don't conflict with 1693any personal bindings you have on \\C-c. In any case, outline structure 1694navigation and authoring is simplified by positioning the cursor on an 1695item's bullet character, the \"hot-spot\" - then you can invoke allout 1696commands with just the un-prefixed, un-control-shifted command letters. 1697This is described further in the HOT-SPOT Operation section. 1698 1699 Exposure Control: 1700 ---------------- 1701\\[allout-hide-current-subtree] `allout-hide-current-subtree' 1702\\[allout-show-children] `allout-show-children' 1703\\[allout-show-current-subtree] `allout-show-current-subtree' 1704\\[allout-show-current-entry] `allout-show-current-entry' 1705\\[allout-show-all] `allout-show-all' 1706 1707 Navigation: 1708 ---------- 1709\\[allout-next-visible-heading] `allout-next-visible-heading' 1710\\[allout-previous-visible-heading] `allout-previous-visible-heading' 1711\\[allout-up-current-level] `allout-up-current-level' 1712\\[allout-forward-current-level] `allout-forward-current-level' 1713\\[allout-backward-current-level] `allout-backward-current-level' 1714\\[allout-end-of-entry] `allout-end-of-entry' 1715\\[allout-beginning-of-current-entry] `allout-beginning-of-current-entry' (alternately, goes to hot-spot) 1716\\[allout-beginning-of-line] `allout-beginning-of-line' - like regular beginning-of-line, but 1717 if immediately repeated cycles to the beginning of the current item 1718 and then to the hot-spot (if `allout-beginning-of-line-cycles' is set). 1719 1720 1721 Topic Header Production: 1722 ----------------------- 1723\\[allout-open-sibtopic] `allout-open-sibtopic' Create a new sibling after current topic. 1724\\[allout-open-subtopic] `allout-open-subtopic' ... an offspring of current topic. 1725\\[allout-open-supertopic] `allout-open-supertopic' ... a sibling of the current topic's parent. 1726 1727 Topic Level and Prefix Adjustment: 1728 --------------------------------- 1729\\[allout-shift-in] `allout-shift-in' Shift current topic and all offspring deeper 1730\\[allout-shift-out] `allout-shift-out' ... less deep 1731\\[allout-rebullet-current-heading] `allout-rebullet-current-heading' Prompt for alternate bullet for 1732 current topic 1733\\[allout-rebullet-topic] `allout-rebullet-topic' Reconcile bullets of topic and 1734 its' offspring - distinctive bullets are not changed, others 1735 are alternated according to nesting depth. 1736\\[allout-number-siblings] `allout-number-siblings' Number bullets of topic and siblings - 1737 the offspring are not affected. 1738 With repeat count, revoke numbering. 1739 1740 Topic-oriented Killing and Yanking: 1741 ---------------------------------- 1742\\[allout-kill-topic] `allout-kill-topic' Kill current topic, including offspring. 1743\\[allout-copy-topic-as-kill] `allout-copy-topic-as-kill' Copy current topic, including offspring. 1744\\[allout-kill-line] `allout-kill-line' kill-line, attending to outline structure. 1745\\[allout-copy-line-as-kill] `allout-copy-line-as-kill' Copy line but don't delete it. 1746\\[allout-yank] `allout-yank' Yank, adjusting depth of yanked topic to 1747 depth of heading if yanking into bare topic 1748 heading (ie, prefix sans text). 1749\\[allout-yank-pop] `allout-yank-pop' Is to allout-yank as yank-pop is to yank 1750 1751 Topic-oriented Encryption: 1752 ------------------------- 1753\\[allout-toggle-current-subtree-encryption] `allout-toggle-current-subtree-encryption' 1754 Encrypt/Decrypt topic content 1755 1756 Misc commands: 1757 ------------- 1758M-x outlineify-sticky Activate outline mode for current buffer, 1759 and establish a default file-var setting 1760 for `allout-layout'. 1761\\[allout-mark-topic] `allout-mark-topic' 1762\\[allout-copy-exposed-to-buffer] `allout-copy-exposed-to-buffer' 1763 Duplicate outline, sans concealed text, to 1764 buffer with name derived from derived from that 1765 of current buffer - \"*BUFFERNAME exposed*\". 1766\\[allout-flatten-exposed-to-buffer] `allout-flatten-exposed-to-buffer' 1767 Like above 'copy-exposed', but convert topic 1768 prefixes to section.subsection... numeric 1769 format. 1770\\[eval-expression] (allout-init t) Setup Emacs session for outline mode 1771 auto-activation. 1772 1773 Topic Encryption 1774 1775Outline mode supports gpg encryption of topics, with support for 1776symmetric and key-pair modes, passphrase timeout, passphrase 1777consistency checking, user-provided hinting for symmetric key 1778mode, and auto-encryption of topics pending encryption on save. 1779 1780Topics pending encryption are, by default, automatically 1781encrypted during file saves. If the contents of the topic 1782containing the cursor was encrypted for a save, it is 1783automatically decrypted for continued editing. 1784 1785The aim of these measures is reliable topic privacy while 1786preventing accidents like neglected encryption before saves, 1787forgetting which passphrase was used, and other practical 1788pitfalls. 1789 1790See `allout-toggle-current-subtree-encryption' function docstring 1791and `allout-encrypt-unencrypted-on-saves' customization variable 1792for details. 1793 1794 HOT-SPOT Operation 1795 1796Hot-spot operation provides a means for easy, single-keystroke outline 1797navigation and exposure control. 1798 1799When the text cursor is positioned directly on the bullet character of 1800a topic, regular characters (a to z) invoke the commands of the 1801corresponding allout-mode keymap control chars. For example, \"f\" 1802would invoke the command typically bound to \"C-c<space>C-f\" 1803\(\\[allout-forward-current-level] `allout-forward-current-level'). 1804 1805Thus, by positioning the cursor on a topic bullet, you can 1806execute the outline navigation and manipulation commands with a 1807single keystroke. Regular navigation keys (eg, \\[forward-char], \\[next-line]) don't get 1808this special translation, so you can use them to get out of the 1809hot-spot and back to normal editing operation. 1810 1811In allout-mode, the normal beginning-of-line command (\\[allout-beginning-of-line]]) is 1812replaced with one that makes it easy to get to the hot-spot. If you 1813repeat it immediately it cycles (if `allout-beginning-of-line-cycles' 1814is set) to the beginning of the item and then, if you hit it again 1815immediately, to the hot-spot. Similarly, `allout-beginning-of-current-entry' 1816\(\\[allout-beginning-of-current-entry]) moves to the hot-spot when the cursor is already located 1817at the beginning of the current entry. 1818 1819 Extending Allout 1820 1821Allout exposure and authoring activites all have associated 1822hooks, by which independent code can cooperate with allout 1823without changes to the allout core. Here are key ones: 1824 1825`allout-mode-hook' 1826`allout-mode-deactivate-hook' 1827`allout-exposure-change-hook' 1828`allout-structure-added-hook' 1829`allout-structure-deleted-hook' 1830`allout-structure-shifted-hook' 1831 1832 Terminology 1833 1834Topic hierarchy constituents - TOPICS and SUBTOPICS: 1835 1836ITEM: A unitary outline element, including the HEADER and ENTRY text. 1837TOPIC: An ITEM and any ITEMs contained within it, ie having greater DEPTH 1838 and with no intervening items of lower DEPTH than the container. 1839CURRENT ITEM: 1840 The visible ITEM most immediately containing the cursor. 1841DEPTH: The degree of nesting of an ITEM; it increases with containment. 1842 The DEPTH is determined by the HEADER PREFIX. The DEPTH is also 1843 called the: 1844LEVEL: The same as DEPTH. 1845 1846ANCESTORS: 1847 Those ITEMs whose TOPICs contain an ITEM. 1848PARENT: An ITEM's immediate ANCESTOR. It has a DEPTH one less than that 1849 of the ITEM. 1850OFFSPRING: 1851 The ITEMs contained within an ITEM's TOPIC. 1852SUBTOPIC: 1853 An OFFSPRING of its ANCESTOR TOPICs. 1854CHILD: 1855 An immediate SUBTOPIC of its PARENT. 1856SIBLINGS: 1857 TOPICs having the same PARENT and DEPTH. 1858 1859Topic text constituents: 1860 1861HEADER: The first line of an ITEM, include the ITEM PREFIX and HEADER 1862 text. 1863ENTRY: The text content of an ITEM, before any OFFSPRING, but including 1864 the HEADER text and distinct from the ITEM PREFIX. 1865BODY: Same as ENTRY. 1866PREFIX: The leading text of an ITEM which distinguishes it from normal 1867 ENTRY text. Allout recognizes the outline structure according 1868 to the strict PREFIX format. It consists of a PREFIX-LEAD string, 1869 PREFIX-PADDING, and a BULLET. The BULLET might be followed by a 1870 number, indicating the ordinal number of the topic among its 1871 siblings, or an asterisk indicating encryption, plus an optional 1872 space. After that is the ITEM HEADER text, which is not part of 1873 the PREFIX. 1874 1875 The relative length of the PREFIX determines the nesting DEPTH 1876 of the ITEM. 1877PREFIX-LEAD: 1878 The string at the beginning of a HEADER PREFIX, by default a `.'. 1879 It can be customized by changing the setting of 1880 `allout-header-prefix' and then reinitializing `allout-mode'. 1881 1882 When the PREFIX-LEAD is set to the comment-string of a 1883 programming language, outline structuring can be embedded in 1884 program code without interfering with processing of the text 1885 (by emacs or the language processor) as program code. This 1886 setting happens automatically when allout mode is used in 1887 programming-mode buffers. See `allout-use-mode-specific-leader' 1888 docstring for more detail. 1889PREFIX-PADDING: 1890 Spaces or asterisks which separate the PREFIX-LEAD and the 1891 bullet, determining the ITEM's DEPTH. 1892BULLET: A character at the end of the ITEM PREFIX, it must be one of 1893 the characters listed on `allout-plain-bullets-string' or 1894 `allout-distinctive-bullets-string'. When creating a TOPIC, 1895 plain BULLETs are by default used, according to the DEPTH of the 1896 TOPIC. Choice among the distinctive BULLETs is offered when you 1897 provide a universal argugment \(\\[universal-argument]) to the 1898 TOPIC creation command, or when explictly rebulleting a TOPIC. The 1899 significance of the various distinctive bullets is purely by 1900 convention. See the documentation for the above bullet strings for 1901 more details. 1902EXPOSURE: 1903 The state of a TOPIC which determines the on-screen visibility 1904 of its OFFSPRING and contained ENTRY text. 1905CONCEALED: 1906 TOPICs and ENTRY text whose EXPOSURE is inhibited. Concealed 1907 text is represented by \"...\" ellipses. 1908 1909 CONCEALED TOPICs are effectively collapsed within an ANCESTOR. 1910CLOSED: A TOPIC whose immediate OFFSPRING and body-text is CONCEALED. 1911OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be." 1912;;;_ . Code 1913 (interactive "P") 1914 1915 (let* ((active (and (not (equal major-mode 'outline)) 1916 (allout-mode-p))) 1917 ; Massage universal-arg `toggle' val: 1918 (toggle (and toggle 1919 (or (and (listp toggle)(car toggle)) 1920 toggle))) 1921 ; Activation specifically demanded? 1922 (explicit-activation (and toggle 1923 (or (symbolp toggle) 1924 (and (wholenump toggle) 1925 (not (zerop toggle)))))) 1926 ;; allout-mode already called once during this complex command? 1927 (same-complex-command (eq allout-v18/19-file-var-hack 1928 (car command-history))) 1929 (write-file-hook-var-name (cond ((boundp 'write-file-functions) 1930 'write-file-functions) 1931 ((boundp 'write-file-hooks) 1932 'write-file-hooks) 1933 (t 'local-write-file-hooks))) 1934 do-layout 1935 ) 1936 1937 ; See comments below re v19.18,.19 bug. 1938 (setq allout-v18/19-file-var-hack (car command-history)) 1939 1940 (cond 1941 1942 ;; Provision for v19.18, 19.19 bug - 1943 ;; Emacs v 19.18, 19.19 file-var code invokes prop-line-designated 1944 ;; modes twice when file is visited. We have to avoid toggling mode 1945 ;; off on second invocation, so we detect it as best we can, and 1946 ;; skip everything. 1947 ((and same-complex-command ; Still in same complex command 1948 ; as last time `allout-mode' invoked. 1949 active ; Already activated. 1950 (not explicit-activation) ; Prop-line file-vars don't have args. 1951 (string-match "^19.1[89]" ; Bug only known to be in v19.18 and 1952 emacs-version)); 19.19. 1953 t) 1954 1955 ;; Deactivation: 1956 ((and (not explicit-activation) 1957 (or active toggle)) 1958 ; Activation not explicitly 1959 ; requested, and either in 1960 ; active state or *de*activation 1961 ; specifically requested: 1962 (setq allout-explicitly-deactivated t) 1963 1964 (allout-do-resumptions) 1965 1966 (remove-from-invisibility-spec '(allout . t)) 1967 (remove-hook 'pre-command-hook 'allout-pre-command-business t) 1968 (remove-hook 'post-command-hook 'allout-post-command-business t) 1969 (remove-hook 'before-change-functions 'allout-before-change-handler t) 1970 (remove-hook 'isearch-mode-end-hook 'allout-isearch-end-handler t) 1971 (remove-hook write-file-hook-var-name 'allout-write-file-hook-handler t) 1972 (remove-hook 'auto-save-hook 'allout-auto-save-hook-handler t) 1973 1974 (remove-overlays (point-min) (point-max) 1975 'category 'allout-exposure-category) 1976 1977 (setq allout-mode nil) 1978 (run-hooks 'allout-mode-deactivate-hook)) 1979 1980 ;; Activation: 1981 ((not active) 1982 (setq allout-explicitly-deactivated nil) 1983 (if allout-old-style-prefixes 1984 ;; Inhibit all the fancy formatting: 1985 (allout-add-resumptions '(allout-primary-bullet "*"))) 1986 1987 (allout-overlay-preparations) ; Doesn't hurt to redo this. 1988 1989 (allout-infer-header-lead-and-primary-bullet) 1990 (allout-infer-body-reindent) 1991 1992 (set-allout-regexp) 1993 (allout-add-resumptions 1994 '(allout-encryption-ciphertext-rejection-regexps 1995 allout-line-boundary-regexp 1996 extend) 1997 '(allout-encryption-ciphertext-rejection-regexps 1998 allout-bob-regexp 1999 extend)) 2000 2001 ;; Produce map from current version of allout-keybindings-list: 2002 (allout-setup-mode-map) 2003 (produce-allout-mode-menubar-entries) 2004 2005 ;; Include on minor-mode-map-alist, if not already there: 2006 (if (not (member '(allout-mode . allout-mode-map) 2007 minor-mode-map-alist)) 2008 (setq minor-mode-map-alist 2009 (cons '(allout-mode . allout-mode-map) 2010 minor-mode-map-alist))) 2011 2012 (add-to-invisibility-spec '(allout . t)) 2013 2014 (allout-add-resumptions '(line-move-ignore-invisible t)) 2015 (add-hook 'pre-command-hook 'allout-pre-command-business nil t) 2016 (add-hook 'post-command-hook 'allout-post-command-business nil t) 2017 (add-hook 'before-change-functions 'allout-before-change-handler 2018 nil t) 2019 (add-hook 'isearch-mode-end-hook 'allout-isearch-end-handler nil t) 2020 (add-hook write-file-hook-var-name 'allout-write-file-hook-handler 2021 nil t) 2022 (add-hook 'auto-save-hook 'allout-auto-save-hook-handler 2023 nil t) 2024 2025 ;; Stash auto-fill settings and adjust so custom allout auto-fill 2026 ;; func will be used if auto-fill is active or activated. (The 2027 ;; custom func respects topic headline, maintains hanging-indents, 2028 ;; etc.) 2029 (if (and auto-fill-function (not allout-inhibit-auto-fill)) 2030 ;; allout-auto-fill will use the stashed values and so forth. 2031 (allout-add-resumptions '(auto-fill-function allout-auto-fill))) 2032 (allout-add-resumptions (list 'allout-former-auto-filler 2033 auto-fill-function) 2034 ;; Register allout-auto-fill to be used if 2035 ;; filling is active: 2036 (list 'allout-outside-normal-auto-fill-function 2037 normal-auto-fill-function) 2038 '(normal-auto-fill-function allout-auto-fill) 2039 ;; Paragraphs are broken by topic headlines. 2040 (list 'paragraph-start 2041 (concat paragraph-start "\\|^\\(" 2042 allout-regexp "\\)")) 2043 (list 'paragraph-separate 2044 (concat paragraph-separate "\\|^\\(" 2045 allout-regexp "\\)"))) 2046 (or (assq 'allout-mode minor-mode-alist) 2047 (setq minor-mode-alist 2048 (cons '(allout-mode " Allout") minor-mode-alist))) 2049 2050 (allout-setup-menubar) 2051 2052 (if allout-layout 2053 (setq do-layout t)) 2054 2055 (setq allout-mode t) 2056 (run-hooks 'allout-mode-hook)) 2057 2058 ;; Reactivation: 2059 ((setq do-layout t) 2060 (allout-infer-body-reindent)) 2061 ) ;; end of activation-mode cases. 2062 2063 ;; Do auto layout if warranted: 2064 (let ((use-layout (if (listp allout-layout) 2065 allout-layout 2066 allout-default-layout))) 2067 (if (and do-layout 2068 allout-auto-activation 2069 use-layout 2070 (and (not (eq allout-auto-activation 'activate)) 2071 (if (eq allout-auto-activation 'ask) 2072 (if (y-or-n-p (format "Expose %s with layout '%s'? " 2073 (buffer-name) 2074 use-layout)) 2075 t 2076 (message "Skipped %s layout." (buffer-name)) 2077 nil) 2078 t))) 2079 (save-excursion 2080 (message "Adjusting '%s' exposure..." (buffer-name)) 2081 (goto-char 0) 2082 (allout-this-or-next-heading) 2083 (condition-case err 2084 (progn 2085 (apply 'allout-expose-topic (list use-layout)) 2086 (message "Adjusting '%s' exposure... done." (buffer-name))) 2087 ;; Problem applying exposure - notify user, but don't 2088 ;; interrupt, eg, file visit: 2089 (error (message "%s" (car (cdr err))) 2090 (sit-for 1)))))) 2091 allout-mode 2092 ) ; let* 2093 ) ; defun 2094 2095(defun allout-setup-mode-map () 2096 "Establish allout-mode bindings." 2097 (setq-default allout-mode-map 2098 (produce-allout-mode-map allout-keybindings-list)) 2099 (setq allout-mode-map 2100 (produce-allout-mode-map allout-keybindings-list)) 2101 (substitute-key-definition 'beginning-of-line 2102 'allout-beginning-of-line 2103 allout-mode-map global-map) 2104 (substitute-key-definition 'move-beginning-of-line 2105 'allout-beginning-of-line 2106 allout-mode-map global-map) 2107 (substitute-key-definition 'end-of-line 2108 'allout-end-of-line 2109 allout-mode-map global-map) 2110 (substitute-key-definition 'move-end-of-line 2111 'allout-end-of-line 2112 allout-mode-map global-map) 2113 (fset 'allout-mode-map allout-mode-map)) 2114 2115;; ensure that allout-mode-map has some setting even if allout-mode hasn't 2116;; been invoked: 2117(allout-setup-mode-map) 2118 2119;;;_ > allout-minor-mode 2120(defalias 'allout-minor-mode 'allout-mode) 2121 2122;;;_ - Position Assessment 2123;;;_ > allout-hidden-p (&optional pos) 2124(defsubst allout-hidden-p (&optional pos) 2125 "Non-nil if the character after point is invisible." 2126 (eq (get-char-property (or pos (point)) 'invisible) 'allout)) 2127 2128;;;_ > allout-overlay-insert-in-front-handler (ol after beg end 2129;;; &optional prelen) 2130(defun allout-overlay-insert-in-front-handler (ol after beg end 2131 &optional prelen) 2132 "Shift the overlay so stuff inserted in front of it are excluded." 2133 (if after 2134 (move-overlay ol (1+ beg) (overlay-end ol)))) 2135;;;_ > allout-overlay-interior-modification-handler (ol after beg end 2136;;; &optional prelen) 2137(defun allout-overlay-interior-modification-handler (ol after beg end 2138 &optional prelen) 2139 "Get confirmation before making arbitrary changes to invisible text. 2140 2141We expose the invisible text and ask for confirmation. Refusal or 2142keyboard-quit abandons the changes, with keyboard-quit additionally 2143reclosing the opened text. 2144 2145No confirmation is necessary when inhibit-read-only is set - eg, allout 2146internal functions use this feature cohesively bunch changes." 2147 2148 (when (and (not inhibit-read-only) (not after)) 2149 (let ((start (point)) 2150 (ol-start (overlay-start ol)) 2151 (ol-end (overlay-end ol)) 2152 first) 2153 (goto-char beg) 2154 (while (< (point) end) 2155 (when (allout-hidden-p) 2156 (allout-show-to-offshoot) 2157 (if (allout-hidden-p) 2158 (save-excursion (forward-char 1) 2159 (allout-show-to-offshoot))) 2160 (when (not first) 2161 (setq first (point)))) 2162 (goto-char (if (featurep 'xemacs) 2163 (next-property-change (1+ (point)) nil end) 2164 (next-char-property-change (1+ (point)) end)))) 2165 (when first 2166 (goto-char first) 2167 (condition-case nil 2168 (if (not 2169 (yes-or-no-p 2170 (substitute-command-keys 2171 (concat "Modify concealed text? (\"no\" just aborts," 2172 " \\[keyboard-quit] also reconceals) ")))) 2173 (progn (goto-char start) 2174 (error "Concealed-text change refused."))) 2175 (quit (allout-flag-region ol-start ol-end nil) 2176 (allout-flag-region ol-start ol-end t) 2177 (error "Concealed-text change abandoned, text reconcealed.")))) 2178 (goto-char start)))) 2179;;;_ > allout-before-change-handler (beg end) 2180(defun allout-before-change-handler (beg end) 2181 "Protect against changes to invisible text. 2182 2183See allout-overlay-interior-modification-handler for details." 2184 2185 (if (and (allout-mode-p) undo-in-progress (allout-hidden-p)) 2186 (allout-show-to-offshoot)) 2187 2188 ;; allout-overlay-interior-modification-handler on an overlay handles 2189 ;; this in other emacs, via `allout-exposure-category's 'modification-hooks. 2190 (when (and (featurep 'xemacs) (allout-mode-p)) 2191 ;; process all of the pending overlays: 2192 (save-excursion 2193 (got-char beg) 2194 (let ((overlay (allout-get-invisibility-overlay))) 2195 (allout-overlay-interior-modification-handler 2196 overlay nil beg end nil))))) 2197;;;_ > allout-isearch-end-handler (&optional overlay) 2198(defun allout-isearch-end-handler (&optional overlay) 2199 "Reconcile allout outline exposure on arriving in hidden text after isearch. 2200 2201Optional OVERLAY parameter is for when this function is used by 2202`isearch-open-invisible' overlay property. It is otherwise unused, so this 2203function can also be used as an `isearch-mode-end-hook'." 2204 2205 (if (and (allout-mode-p) (allout-hidden-p)) 2206 (allout-show-to-offshoot))) 2207 2208;;;_ #3 Internal Position State-Tracking - "allout-recent-*" funcs 2209;;; All the basic outline functions that directly do string matches to 2210;;; evaluate heading prefix location set the variables 2211;;; `allout-recent-prefix-beginning' and `allout-recent-prefix-end' 2212;;; when successful. Functions starting with `allout-recent-' all 2213;;; use this state, providing the means to avoid redundant searches 2214;;; for just-established data. This optimization can provide 2215;;; significant speed improvement, but it must be employed carefully. 2216;;;_ = allout-recent-prefix-beginning 2217(defvar allout-recent-prefix-beginning 0 2218 "Buffer point of the start of the last topic prefix encountered.") 2219(make-variable-buffer-local 'allout-recent-prefix-beginning) 2220;;;_ = allout-recent-prefix-end 2221(defvar allout-recent-prefix-end 0 2222 "Buffer point of the end of the last topic prefix encountered.") 2223(make-variable-buffer-local 'allout-recent-prefix-end) 2224;;;_ = allout-recent-depth 2225(defvar allout-recent-depth 0 2226 "Depth of the last topic prefix encountered.") 2227(make-variable-buffer-local 'allout-recent-depth) 2228;;;_ = allout-recent-end-of-subtree 2229(defvar allout-recent-end-of-subtree 0 2230 "Buffer point last returned by `allout-end-of-current-subtree'.") 2231(make-variable-buffer-local 'allout-recent-end-of-subtree) 2232;;;_ > allout-prefix-data () 2233(defsubst allout-prefix-data () 2234 "Register allout-prefix state data. 2235 2236For reference by `allout-recent' funcs. Returns BEGINNING." 2237 (setq allout-recent-prefix-end (or (match-end 1) (match-end 2)) 2238 allout-recent-prefix-beginning (or (match-beginning 1) 2239 (match-beginning 2)) 2240 allout-recent-depth (max 1 (- allout-recent-prefix-end 2241 allout-recent-prefix-beginning 2242 allout-header-subtraction))) 2243 allout-recent-prefix-beginning) 2244;;;_ > nullify-allout-prefix-data () 2245(defsubst nullify-allout-prefix-data () 2246 "Mark allout prefix data as being uninformative." 2247 (setq allout-recent-prefix-end (point) 2248 allout-recent-prefix-beginning (point) 2249 allout-recent-depth 0) 2250 allout-recent-prefix-beginning) 2251;;;_ > allout-recent-depth () 2252(defsubst allout-recent-depth () 2253 "Return depth of last heading encountered by an outline maneuvering function. 2254 2255All outline functions which directly do string matches to assess 2256headings set the variables `allout-recent-prefix-beginning' and 2257`allout-recent-prefix-end' if successful. This function uses those settings 2258to return the current depth." 2259 2260 allout-recent-depth) 2261;;;_ > allout-recent-prefix () 2262(defsubst allout-recent-prefix () 2263 "Like `allout-recent-depth', but returns text of last encountered prefix. 2264 2265All outline functions which directly do string matches to assess 2266headings set the variables `allout-recent-prefix-beginning' and 2267`allout-recent-prefix-end' if successful. This function uses those settings 2268to return the current prefix." 2269 (buffer-substring-no-properties allout-recent-prefix-beginning 2270 allout-recent-prefix-end)) 2271;;;_ > allout-recent-bullet () 2272(defmacro allout-recent-bullet () 2273 "Like allout-recent-prefix, but returns bullet of last encountered prefix. 2274 2275All outline functions which directly do string matches to assess 2276headings set the variables `allout-recent-prefix-beginning' and 2277`allout-recent-prefix-end' if successful. This function uses those settings 2278to return the current depth of the most recently matched topic." 2279 '(buffer-substring-no-properties (1- allout-recent-prefix-end) 2280 allout-recent-prefix-end)) 2281 2282;;;_ #4 Navigation 2283 2284;;;_ - Position Assessment 2285;;;_ : Location Predicates 2286;;;_ > allout-do-doublecheck () 2287(defsubst allout-do-doublecheck () 2288 "True if current item conditions qualify for checking on topic aberrance." 2289 (and 2290 ;; presume integrity of outline and yanked content during yank - necessary, 2291 ;; to allow for level disparity of yank location and yanked text: 2292 (not allout-inhibit-aberrance-doublecheck) 2293 ;; allout-doublecheck-at-and-shallower is ceiling for doublecheck: 2294 (<= allout-recent-depth allout-doublecheck-at-and-shallower))) 2295;;;_ > allout-aberrant-container-p () 2296(defun allout-aberrant-container-p () 2297 "True if topic, or next sibling with children, contains them discontinuously. 2298 2299Discontinuous means an immediate offspring that is nested more 2300than one level deeper than the topic. 2301 2302If topic has no offspring, then the next sibling with offspring will 2303determine whether or not this one is determined to be aberrant. 2304 2305If true, then the allout-recent-* settings are calibrated on the 2306offspring that qaulifies it as aberrant, ie with depth that 2307exceeds the topic by more than one." 2308 2309 ;; This is most clearly understood when considering standard-prefix-leader 2310 ;; low-level topics, which can all too easily match text not intended as 2311 ;; headers. For example, any line with a leading '.' or '*' and lacking a 2312 ;; following bullet qualifies without this protection. (A sequence of 2313 ;; them can occur naturally, eg a typical textual bullet list.) We 2314 ;; disqualify such low-level sequences when they are followed by a 2315 ;; discontinuously contained child, inferring that the sequences are not 2316 ;; actually connected with their prospective context. 2317 2318 (let ((depth (allout-depth)) 2319 (start-point (point)) 2320 done aberrant) 2321 (save-excursion 2322 (while (and (not done) 2323 (re-search-forward allout-line-boundary-regexp nil 0)) 2324 (allout-prefix-data) 2325 (goto-char allout-recent-prefix-beginning) 2326 (cond 2327 ;; sibling - continue: 2328 ((eq allout-recent-depth depth)) 2329 ;; first offspring is excessive - aberrant: 2330 ((> allout-recent-depth (1+ depth)) 2331 (setq done t aberrant t)) 2332 ;; next non-sibling is lower-depth - not aberrant: 2333 (t (setq done t))))) 2334 (if aberrant 2335 aberrant 2336 (goto-char start-point) 2337 ;; recalibrate allout-recent-* 2338 (allout-depth) 2339 nil))) 2340;;;_ > allout-on-current-heading-p () 2341(defun allout-on-current-heading-p () 2342 "Return non-nil if point is on current visible topics' header line. 2343 2344Actually, returns prefix beginning point." 2345 (save-excursion 2346 (allout-beginning-of-current-line) 2347 (and (looking-at allout-regexp) 2348 (allout-prefix-data) 2349 (or (not (allout-do-doublecheck)) 2350 (not (allout-aberrant-container-p)))))) 2351;;;_ > allout-on-heading-p () 2352(defalias 'allout-on-heading-p 'allout-on-current-heading-p) 2353;;;_ > allout-e-o-prefix-p () 2354(defun allout-e-o-prefix-p () 2355 "True if point is located where current topic prefix ends, heading begins." 2356 (and (save-excursion (let ((inhibit-field-text-motion t)) 2357 (beginning-of-line)) 2358 (looking-at allout-regexp)) 2359 (= (point)(save-excursion (allout-end-of-prefix)(point))))) 2360;;;_ : Location attributes 2361;;;_ > allout-depth () 2362(defun allout-depth () 2363 "Return depth of topic most immediately containing point. 2364 2365Return zero if point is not within any topic. 2366 2367Like `allout-current-depth', but respects hidden as well as visible topics." 2368 (save-excursion 2369 (let ((start-point (point))) 2370 (if (and (allout-goto-prefix) 2371 (not (< start-point (point)))) 2372 allout-recent-depth 2373 (progn 2374 ;; Oops, no prefix, nullify it: 2375 (nullify-allout-prefix-data) 2376 ;; ... and return 0: 2377 0))))) 2378;;;_ > allout-current-depth () 2379(defun allout-current-depth () 2380 "Return depth of visible topic most immediately containing point. 2381 2382Return zero if point is not within any topic." 2383 (save-excursion 2384 (if (allout-back-to-current-heading) 2385 (max 1 2386 (- allout-recent-prefix-end 2387 allout-recent-prefix-beginning 2388 allout-header-subtraction)) 2389 0))) 2390;;;_ > allout-get-current-prefix () 2391(defun allout-get-current-prefix () 2392 "Topic prefix of the current topic." 2393 (save-excursion 2394 (if (allout-goto-prefix) 2395 (allout-recent-prefix)))) 2396;;;_ > allout-get-bullet () 2397(defun allout-get-bullet () 2398 "Return bullet of containing topic (visible or not)." 2399 (save-excursion 2400 (and (allout-goto-prefix) 2401 (allout-recent-bullet)))) 2402;;;_ > allout-current-bullet () 2403(defun allout-current-bullet () 2404 "Return bullet of current (visible) topic heading, or none if none found." 2405 (condition-case nil 2406 (save-excursion 2407 (allout-back-to-current-heading) 2408 (buffer-substring-no-properties (- allout-recent-prefix-end 1) 2409 allout-recent-prefix-end)) 2410 ;; Quick and dirty provision, ostensibly for missing bullet: 2411 (args-out-of-range nil)) 2412 ) 2413;;;_ > allout-get-prefix-bullet (prefix) 2414(defun allout-get-prefix-bullet (prefix) 2415 "Return the bullet of the header prefix string PREFIX." 2416 ;; Doesn't make sense if we're old-style prefixes, but this just 2417 ;; oughtn't be called then, so forget about it... 2418 (if (string-match allout-regexp prefix) 2419 (substring prefix (1- (match-end 2)) (match-end 2)))) 2420;;;_ > allout-sibling-index (&optional depth) 2421(defun allout-sibling-index (&optional depth) 2422 "Item number of this prospective topic among its siblings. 2423 2424If optional arg DEPTH is greater than current depth, then we're 2425opening a new level, and return 0. 2426 2427If less than this depth, ascend to that depth and count..." 2428 2429 (save-excursion 2430 (cond ((and depth (<= depth 0) 0)) 2431 ((or (null depth) (= depth (allout-depth))) 2432 (let ((index 1)) 2433 (while (allout-previous-sibling allout-recent-depth nil) 2434 (setq index (1+ index))) 2435 index)) 2436 ((< depth allout-recent-depth) 2437 (allout-ascend-to-depth depth) 2438 (allout-sibling-index)) 2439 (0)))) 2440;;;_ > allout-topic-flat-index () 2441(defun allout-topic-flat-index () 2442 "Return a list indicating point's numeric section.subsect.subsubsect... 2443Outermost is first." 2444 (let* ((depth (allout-depth)) 2445 (next-index (allout-sibling-index depth)) 2446 (rev-sibls nil)) 2447 (while (> next-index 0) 2448 (setq rev-sibls (cons next-index rev-sibls)) 2449 (setq depth (1- depth)) 2450 (setq next-index (allout-sibling-index depth))) 2451 rev-sibls) 2452 ) 2453 2454;;;_ - Navigation routines 2455;;;_ > allout-beginning-of-current-line () 2456(defun allout-beginning-of-current-line () 2457 "Like beginning of line, but to visible text." 2458 2459 ;; This combination of move-beginning-of-line and beginning-of-line is 2460 ;; deliberate, but the (beginning-of-line) may now be superfluous. 2461 (let ((inhibit-field-text-motion t)) 2462 (move-beginning-of-line 1) 2463 (beginning-of-line) 2464 (while (and (not (bobp)) (or (not (bolp)) (allout-hidden-p))) 2465 (beginning-of-line) 2466 (if (or (allout-hidden-p) (not (bolp))) 2467 (forward-char -1))))) 2468;;;_ > allout-end-of-current-line () 2469(defun allout-end-of-current-line () 2470 "Move to the end of line, past concealed text if any." 2471 ;; XXX This is for symmetry with `allout-beginning-of-current-line' - 2472 ;; `move-end-of-line' doesn't suffer the same problem as 2473 ;; `move-beginning-of-line'. 2474 (let ((inhibit-field-text-motion t)) 2475 (end-of-line) 2476 (while (allout-hidden-p) 2477 (end-of-line) 2478 (if (allout-hidden-p) (forward-char 1))))) 2479;;;_ > allout-beginning-of-line () 2480(defun allout-beginning-of-line () 2481 "Beginning-of-line with `allout-beginning-of-line-cycles' behavior, if set." 2482 2483 (interactive) 2484 2485 (if (or (not allout-beginning-of-line-cycles) 2486 (not (equal last-command this-command))) 2487 (move-beginning-of-line 1) 2488 (allout-depth) 2489 (let ((beginning-of-body 2490 (save-excursion 2491 (while (and (allout-do-doublecheck) 2492 (allout-aberrant-container-p) 2493 (allout-previous-visible-heading 1))) 2494 (allout-beginning-of-current-entry) 2495 (point)))) 2496 (cond ((= (current-column) 0) 2497 (goto-char beginning-of-body)) 2498 ((< (point) beginning-of-body) 2499 (allout-beginning-of-current-line)) 2500 ((= (point) beginning-of-body) 2501 (goto-char (allout-current-bullet-pos))) 2502 (t (allout-beginning-of-current-line) 2503 (if (< (point) beginning-of-body) 2504 ;; we were on the headline after its start: 2505 (goto-char beginning-of-body))))))) 2506;;;_ > allout-end-of-line () 2507(defun allout-end-of-line () 2508 "End-of-line with `allout-end-of-line-cycles' behavior, if set." 2509 2510 (interactive) 2511 2512 (if (or (not allout-end-of-line-cycles) 2513 (not (equal last-command this-command))) 2514 (allout-end-of-current-line) 2515 (let ((end-of-entry (save-excursion 2516 (allout-end-of-entry) 2517 (point)))) 2518 (cond ((not (eolp)) 2519 (allout-end-of-current-line)) 2520 ((or (allout-hidden-p) (save-excursion 2521 (forward-char -1) 2522 (allout-hidden-p))) 2523 (allout-back-to-current-heading) 2524 (allout-show-current-entry) 2525 (allout-show-children) 2526 (allout-end-of-entry)) 2527 ((>= (point) end-of-entry) 2528 (allout-back-to-current-heading) 2529 (allout-end-of-current-line)) 2530 (t (allout-end-of-entry)))))) 2531;;;_ > allout-next-heading () 2532(defsubst allout-next-heading () 2533 "Move to the heading for the topic (possibly invisible) after this one. 2534 2535Returns the location of the heading, or nil if none found. 2536 2537We skip anomolous low-level topics, a la `allout-aberrant-container-p'." 2538 (if (looking-at allout-regexp) 2539 (forward-char 1)) 2540 2541 (when (re-search-forward allout-line-boundary-regexp nil 0) 2542 (allout-prefix-data) 2543 (and (allout-do-doublecheck) 2544 ;; this will set allout-recent-* on the first non-aberrant topic, 2545 ;; whether it's the current one or one that disqualifies it: 2546 (allout-aberrant-container-p)) 2547 (goto-char allout-recent-prefix-beginning))) 2548;;;_ > allout-this-or-next-heading 2549(defun allout-this-or-next-heading () 2550 "Position cursor on current or next heading." 2551 ;; A throwaway non-macro that is defined after allout-next-heading 2552 ;; and usable by allout-mode. 2553 (if (not (allout-goto-prefix-doublechecked)) (allout-next-heading))) 2554;;;_ > allout-previous-heading () 2555(defun allout-previous-heading () 2556 "Move to the prior (possibly invisible) heading line. 2557 2558Return the location of the beginning of the heading, or nil if not found. 2559 2560We skip anomolous low-level topics, a la `allout-aberrant-container-p'." 2561 2562 (if (bobp) 2563 nil 2564 (let ((start-point (point))) 2565 ;; allout-goto-prefix-doublechecked calls us, so we can't use it here. 2566 (allout-goto-prefix) 2567 (when (or (re-search-backward allout-line-boundary-regexp nil 0) 2568 (looking-at allout-bob-regexp)) 2569 (goto-char (allout-prefix-data)) 2570 (if (and (allout-do-doublecheck) 2571 (allout-aberrant-container-p)) 2572 (or (allout-previous-heading) 2573 (and (goto-char start-point) 2574 ;; recalibrate allout-recent-*: 2575 (allout-depth) 2576 nil)) 2577 (point)))))) 2578;;;_ > allout-get-invisibility-overlay () 2579(defun allout-get-invisibility-overlay () 2580 "Return the overlay at point that dictates allout invisibility." 2581 (let ((overlays (overlays-at (point))) 2582 got) 2583 (while (and overlays (not got)) 2584 (if (equal (overlay-get (car overlays) 'invisible) 'allout) 2585 (setq got (car overlays)) 2586 (pop overlays))) 2587 got)) 2588;;;_ > allout-back-to-visible-text () 2589(defun allout-back-to-visible-text () 2590 "Move to most recent prior character that is visible, and return point." 2591 (if (allout-hidden-p) 2592 (goto-char (overlay-start (allout-get-invisibility-overlay)))) 2593 (point)) 2594 2595;;;_ - Subtree Charting 2596;;;_ " These routines either produce or assess charts, which are 2597;;; nested lists of the locations of topics within a subtree. 2598;;; 2599;;; Charts enable efficient subtree navigation by providing a reusable basis 2600;;; for elaborate, compound assessment and adjustment of a subtree. 2601 2602;;;_ > allout-chart-subtree (&optional levels visible orig-depth prev-depth) 2603(defun allout-chart-subtree (&optional levels visible orig-depth prev-depth) 2604 "Produce a location \"chart\" of subtopics of the containing topic. 2605 2606Optional argument LEVELS specifies a depth limit (relative to start 2607depth) for the chart. Null LEVELS means no limit. 2608 2609When optional argument VISIBLE is non-nil, the chart includes 2610only the visible subelements of the charted subjects. 2611 2612The remaining optional args are for internal use by the function. 2613 2614Point is left at the end of the subtree. 2615 2616Charts are used to capture outline structure, so that outline-altering 2617routines need assess the structure only once, and then use the chart 2618for their elaborate manipulations. 2619 2620The chart entries for the topics are in reverse order, so the 2621last topic is listed first. The entry for each topic consists of 2622an integer indicating the point at the beginning of the topic 2623prefix. Charts for offspring consists of a list containing, 2624recursively, the charts for the respective subtopics. The chart 2625for a topics' offspring precedes the entry for the topic itself. 2626 2627The other function parameters are for internal recursion, and should 2628not be specified by external callers. ORIG-DEPTH is depth of topic at 2629starting point, and PREV-DEPTH is depth of prior topic." 2630 2631 (let ((original (not orig-depth)) ; `orig-depth' set only in recursion. 2632 chart curr-depth) 2633 2634 (if original ; Just starting? 2635 ; Register initial settings and 2636 ; position to first offspring: 2637 (progn (setq orig-depth (allout-depth)) 2638 (or prev-depth (setq prev-depth (1+ orig-depth))) 2639 (if visible 2640 (allout-next-visible-heading 1) 2641 (allout-next-heading)))) 2642 2643 ;; Loop over the current levels' siblings. Besides being more 2644 ;; efficient than tail-recursing over a level, it avoids exceeding 2645 ;; the typically quite constrained Emacs max-lisp-eval-depth. 2646 ;; 2647 ;; Probably would speed things up to implement loop-based stack 2648 ;; operation rather than recursing for lower levels. Bah. 2649 2650 (while (and (not (eobp)) 2651 ; Still within original topic? 2652 (< orig-depth (setq curr-depth allout-recent-depth)) 2653 (cond ((= prev-depth curr-depth) 2654 ;; Register this one and move on: 2655 (setq chart (cons allout-recent-prefix-beginning chart)) 2656 (if (and levels (<= levels 1)) 2657 ;; At depth limit - skip sublevels: 2658 (or (allout-next-sibling curr-depth) 2659 ;; or no more siblings - proceed to 2660 ;; next heading at lesser depth: 2661 (while (and (<= curr-depth 2662 allout-recent-depth) 2663 (if visible 2664 (allout-next-visible-heading 1) 2665 (allout-next-heading))))) 2666 (if visible 2667 (allout-next-visible-heading 1) 2668 (allout-next-heading)))) 2669 2670 ((and (< prev-depth curr-depth) 2671 (or (not levels) 2672 (> levels 0))) 2673 ;; Recurse on deeper level of curr topic: 2674 (setq chart 2675 (cons (allout-chart-subtree (and levels 2676 (1- levels)) 2677 visible 2678 orig-depth 2679 curr-depth) 2680 chart)) 2681 ;; ... then continue with this one. 2682 ) 2683 2684 ;; ... else nil if we've ascended back to prev-depth. 2685 2686 ))) 2687 2688 (if original ; We're at the last sibling on 2689 ; the original level. Position 2690 ; to the end of it: 2691 (progn (and (not (eobp)) (forward-char -1)) 2692 (and (= (preceding-char) ?\n) 2693 (= (aref (buffer-substring (max 1 (- (point) 3)) 2694 (point)) 2695 1) 2696 ?\n) 2697 (forward-char -1)) 2698 (setq allout-recent-end-of-subtree (point)))) 2699 2700 chart ; (nreverse chart) not necessary, 2701 ; and maybe not preferable. 2702 )) 2703;;;_ > allout-chart-siblings (&optional start end) 2704(defun allout-chart-siblings (&optional start end) 2705 "Produce a list of locations of this and succeeding sibling topics. 2706Effectively a top-level chart of siblings. See `allout-chart-subtree' 2707for an explanation of charts." 2708 (save-excursion 2709 (when (allout-goto-prefix-doublechecked) 2710 (let ((chart (list (point)))) 2711 (while (allout-next-sibling) 2712 (setq chart (cons (point) chart))) 2713 (if chart (setq chart (nreverse chart))))))) 2714;;;_ > allout-chart-to-reveal (chart depth) 2715(defun allout-chart-to-reveal (chart depth) 2716 2717 "Return a flat list of hidden points in subtree CHART, up to DEPTH. 2718 2719If DEPTH is nil, include hidden points at any depth. 2720 2721Note that point can be left at any of the points on chart, or at the 2722start point." 2723 2724 (let (result here) 2725 (while (and (or (null depth) (> depth 0)) 2726 chart) 2727 (setq here (car chart)) 2728 (if (listp here) 2729 (let ((further (allout-chart-to-reveal here (if (null depth) 2730 depth 2731 (1- depth))))) 2732 ;; We're on the start of a subtree - recurse with it, if there's 2733 ;; more depth to go: 2734 (if further (setq result (append further result))) 2735 (setq chart (cdr chart))) 2736 (goto-char here) 2737 (if (allout-hidden-p) 2738 (setq result (cons here result))) 2739 (setq chart (cdr chart)))) 2740 result)) 2741;;;_ X allout-chart-spec (chart spec &optional exposing) 2742;; (defun allout-chart-spec (chart spec &optional exposing) 2743;; "Not yet (if ever) implemented. 2744 2745;; Produce exposure directives given topic/subtree CHART and an exposure SPEC. 2746 2747;; Exposure spec indicates the locations to be exposed and the prescribed 2748;; exposure status. Optional arg EXPOSING is an integer, with 0 2749;; indicating pending concealment, anything higher indicating depth to 2750;; which subtopic headers should be exposed, and negative numbers 2751;; indicating (negative of) the depth to which subtopic headers and 2752;; bodies should be exposed. 2753 2754;; The produced list can have two types of entries. Bare numbers 2755;; indicate points in the buffer where topic headers that should be 2756;; exposed reside. 2757 2758;; - bare negative numbers indicates that the topic starting at the 2759;; point which is the negative of the number should be opened, 2760;; including their entries. 2761;; - bare positive values indicate that this topic header should be 2762;; opened. 2763;; - Lists signify the beginning and end points of regions that should 2764;; be flagged, and the flag to employ. (For concealment: `(\?r)', and 2765;; exposure:" 2766;; (while spec 2767;; (cond ((listp spec) 2768;; ) 2769;; ) 2770;; (setq spec (cdr spec))) 2771;; ) 2772 2773;;;_ - Within Topic 2774;;;_ > allout-goto-prefix () 2775(defun allout-goto-prefix () 2776 "Put point at beginning of immediately containing outline topic. 2777 2778Goes to most immediate subsequent topic if none immediately containing. 2779 2780Not sensitive to topic visibility. 2781 2782Returns the point at the beginning of the prefix, or nil if none." 2783 2784 (let (done) 2785 (while (and (not done) 2786 (search-backward "\n" nil 1)) 2787 (forward-char 1) 2788 (if (looking-at allout-regexp) 2789 (setq done (allout-prefix-data)) 2790 (forward-char -1))) 2791 (if (bobp) 2792 (cond ((looking-at allout-regexp) 2793 (allout-prefix-data)) 2794 ((allout-next-heading)) 2795 (done)) 2796 done))) 2797;;;_ > allout-goto-prefix-doublechecked () 2798(defun allout-goto-prefix-doublechecked () 2799 "Put point at beginning of immediately containing outline topic. 2800 2801Like `allout-goto-prefix', but shallow topics (according to 2802`allout-doublecheck-at-and-shallower') are checked and 2803disqualified for child containment discontinuity, according to 2804`allout-aberrant-container-p'." 2805 (if (allout-goto-prefix) 2806 (if (and (allout-do-doublecheck) 2807 (allout-aberrant-container-p)) 2808 (allout-previous-heading) 2809 (point)))) 2810 2811;;;_ > allout-end-of-prefix () 2812(defun allout-end-of-prefix (&optional ignore-decorations) 2813 "Position cursor at beginning of header text. 2814 2815If optional IGNORE-DECORATIONS is non-nil, put just after bullet, 2816otherwise skip white space between bullet and ensuing text." 2817 2818 (if (not (allout-goto-prefix-doublechecked)) 2819 nil 2820 (goto-char allout-recent-prefix-end) 2821 (if ignore-decorations 2822 t 2823 (while (looking-at "[0-9]") (forward-char 1)) 2824 (if (and (not (eolp)) (looking-at "\\s-")) (forward-char 1))) 2825 ;; Reestablish where we are: 2826 (allout-current-depth))) 2827;;;_ > allout-current-bullet-pos () 2828(defun allout-current-bullet-pos () 2829 "Return position of current (visible) topic's bullet." 2830 2831 (if (not (allout-current-depth)) 2832 nil 2833 (1- allout-recent-prefix-end))) 2834;;;_ > allout-back-to-current-heading () 2835(defun allout-back-to-current-heading () 2836 "Move to heading line of current topic, or beginning if not in a topic. 2837 2838If interactive, we position at the end of the prefix. 2839 2840Return value of resulting point, unless we started outside 2841of (before any) topics, in which case we return nil." 2842 2843 (allout-beginning-of-current-line) 2844 (let ((bol-point (point))) 2845 (if (allout-goto-prefix-doublechecked) 2846 (if (<= (point) bol-point) 2847 (if (interactive-p) 2848 (allout-end-of-prefix) 2849 (point)) 2850 (goto-char (point-min)) 2851 nil)))) 2852;;;_ > allout-back-to-heading () 2853(defalias 'allout-back-to-heading 'allout-back-to-current-heading) 2854;;;_ > allout-pre-next-prefix () 2855(defun allout-pre-next-prefix () 2856 "Skip forward to just before the next heading line. 2857 2858Returns that character position." 2859 2860 (if (allout-next-heading) 2861 (goto-char (1- allout-recent-prefix-beginning)))) 2862;;;_ > allout-end-of-subtree (&optional current include-trailing-blank) 2863(defun allout-end-of-subtree (&optional current include-trailing-blank) 2864 "Put point at the end of the last leaf in the containing topic. 2865 2866Optional CURRENT means put point at the end of the containing 2867visible topic. 2868 2869Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if 2870any, as part of the subtree. Otherwise, that trailing blank will be 2871excluded as delimiting whitespace between topics. 2872 2873Returns the value of point." 2874 (interactive "P") 2875 (if current 2876 (allout-back-to-current-heading) 2877 (allout-goto-prefix-doublechecked)) 2878 (let ((level allout-recent-depth)) 2879 (allout-next-heading) 2880 (while (and (not (eobp)) 2881 (> allout-recent-depth level)) 2882 (allout-next-heading)) 2883 (if (eobp) 2884 (allout-end-of-entry) 2885 (forward-char -1)) 2886 (if (and (not include-trailing-blank) (= ?\n (preceding-char))) 2887 (forward-char -1)) 2888 (setq allout-recent-end-of-subtree (point)))) 2889;;;_ > allout-end-of-current-subtree (&optional include-trailing-blank) 2890(defun allout-end-of-current-subtree (&optional include-trailing-blank) 2891 2892 "Put point at end of last leaf in currently visible containing topic. 2893 2894Optional INCLUDE-TRAILING-BLANK means include a trailing blank line, if 2895any, as part of the subtree. Otherwise, that trailing blank will be 2896excluded as delimiting whitespace between topics. 2897 2898Returns the value of point." 2899 (interactive) 2900 (allout-end-of-subtree t include-trailing-blank)) 2901;;;_ > allout-beginning-of-current-entry () 2902(defun allout-beginning-of-current-entry () 2903 "When not already there, position point at beginning of current topic header. 2904 2905If already there, move cursor to bullet for hot-spot operation. 2906\(See `allout-mode' doc string for details of hot-spot operation.)" 2907 (interactive) 2908 (let ((start-point (point))) 2909 (move-beginning-of-line 1) 2910 (if (< 0 (allout-current-depth)) 2911 (goto-char allout-recent-prefix-end) 2912 (goto-char (point-min))) 2913 (allout-end-of-prefix) 2914 (if (and (interactive-p) 2915 (= (point) start-point)) 2916 (goto-char (allout-current-bullet-pos))))) 2917;;;_ > allout-end-of-entry (&optional inclusive) 2918(defun allout-end-of-entry (&optional inclusive) 2919 "Position the point at the end of the current topics' entry. 2920 2921Optional INCLUSIVE means also include trailing empty line, if any. When 2922unset, whitespace between items separates them even when the items are 2923collapsed." 2924 (interactive) 2925 (allout-pre-next-prefix) 2926 (if (and (not inclusive) (not (bobp)) (= ?\n (preceding-char))) 2927 (forward-char -1)) 2928 (point)) 2929;;;_ > allout-end-of-current-heading () 2930(defun allout-end-of-current-heading () 2931 (interactive) 2932 (allout-beginning-of-current-entry) 2933 (search-forward "\n" nil t) 2934 (forward-char -1)) 2935(defalias 'allout-end-of-heading 'allout-end-of-current-heading) 2936;;;_ > allout-get-body-text () 2937(defun allout-get-body-text () 2938 "Return the unmangled body text of the topic immediately containing point." 2939 (save-excursion 2940 (allout-end-of-prefix) 2941 (if (not (search-forward "\n" nil t)) 2942 nil 2943 (backward-char 1) 2944 (let ((pre-body (point))) 2945 (if (not pre-body) 2946 nil 2947 (allout-end-of-entry t) 2948 (if (not (= pre-body (point))) 2949 (buffer-substring-no-properties (1+ pre-body) (point)))) 2950 ) 2951 ) 2952 ) 2953 ) 2954 2955;;;_ - Depth-wise 2956;;;_ > allout-ascend-to-depth (depth) 2957(defun allout-ascend-to-depth (depth) 2958 "Ascend to depth DEPTH, returning depth if successful, nil if not." 2959 (if (and (> depth 0)(<= depth (allout-depth))) 2960 (let (last-ascended) 2961 (while (and (< depth allout-recent-depth) 2962 (setq last-ascended (allout-ascend)))) 2963 (goto-char allout-recent-prefix-beginning) 2964 (if (interactive-p) (allout-end-of-prefix)) 2965 (and last-ascended allout-recent-depth)))) 2966;;;_ > allout-ascend () 2967(defun allout-ascend (&optional dont-move-if-unsuccessful) 2968 "Ascend one level, returning resulting depth if successful, nil if not. 2969 2970Point is left at the beginning of the level whether or not 2971successful, unless optional DONT-MOVE-IF-UNSUCCESSFUL is set, in 2972which case point is returned to its original starting location." 2973 (if dont-move-if-unsuccessful 2974 (setq dont-move-if-unsuccessful (point))) 2975 (prog1 2976 (if (allout-beginning-of-level) 2977 (let ((bolevel (point)) 2978 (bolevel-depth allout-recent-depth)) 2979 (allout-previous-heading) 2980 (cond ((< allout-recent-depth bolevel-depth) 2981 allout-recent-depth) 2982 ((= allout-recent-depth bolevel-depth) 2983 (if dont-move-if-unsuccessful 2984 (goto-char dont-move-if-unsuccessful)) 2985 (allout-depth) 2986 nil) 2987 (t 2988 ;; some topic after very first is lower depth than first: 2989 (goto-char bolevel) 2990 (allout-depth) 2991 nil)))) 2992 (if (interactive-p) (allout-end-of-prefix)))) 2993;;;_ > allout-descend-to-depth (depth) 2994(defun allout-descend-to-depth (depth) 2995 "Descend to depth DEPTH within current topic. 2996 2997Returning depth if successful, nil if not." 2998 (let ((start-point (point)) 2999 (start-depth (allout-depth))) 3000 (while 3001 (and (> (allout-depth) 0) 3002 (not (= depth allout-recent-depth)) ; ... not there yet 3003 (allout-next-heading) ; ... go further 3004 (< start-depth allout-recent-depth))) ; ... still in topic 3005 (if (and (> (allout-depth) 0) 3006 (= allout-recent-depth depth)) 3007 depth 3008 (goto-char start-point) 3009 nil)) 3010 ) 3011;;;_ > allout-up-current-level (arg) 3012(defun allout-up-current-level (arg) 3013 "Move out ARG levels from current visible topic." 3014 (interactive "p") 3015 (let ((start-point (point))) 3016 (allout-back-to-current-heading) 3017 (if (not (allout-ascend)) 3018 (progn (goto-char start-point) 3019 (error "Can't ascend past outermost level")) 3020 (if (interactive-p) (allout-end-of-prefix)) 3021 allout-recent-prefix-beginning))) 3022 3023;;;_ - Linear 3024;;;_ > allout-next-sibling (&optional depth backward) 3025(defun allout-next-sibling (&optional depth backward) 3026 "Like `allout-forward-current-level', but respects invisible topics. 3027 3028Traverse at optional DEPTH, or current depth if none specified. 3029 3030Go backward if optional arg BACKWARD is non-nil. 3031 3032Return the start point of the new topic if successful, nil otherwise." 3033 3034 (if (if backward (bobp) (eobp)) 3035 nil 3036 (let ((target-depth (or depth (allout-depth))) 3037 (start-point (point)) 3038 (start-prefix-beginning allout-recent-prefix-beginning) 3039 (count 0) 3040 leaping 3041 last-depth) 3042 (while (and 3043 ;; done too few single steps to resort to the leap routine: 3044 (not leaping) 3045 ;; not at limit: 3046 (not (if backward (bobp) (eobp))) 3047 ;; still traversable: 3048 (if backward (allout-previous-heading) (allout-next-heading)) 3049 ;; we're below the target depth 3050 (> (setq last-depth allout-recent-depth) target-depth)) 3051 (setq count (1+ count)) 3052 (if (> count 7) ; lists are commonly 7 +- 2, right?-) 3053 (setq leaping t))) 3054 (cond (leaping 3055 (or (allout-next-sibling-leap target-depth backward) 3056 (progn 3057 (goto-char start-point) 3058 (if depth (allout-depth) target-depth) 3059 nil))) 3060 ((and (not (eobp)) 3061 (and (> (or last-depth (allout-depth)) 0) 3062 (= allout-recent-depth target-depth)) 3063 (not (= start-prefix-beginning 3064 allout-recent-prefix-beginning))) 3065 allout-recent-prefix-beginning) 3066 (t 3067 (goto-char start-point) 3068 (if depth (allout-depth) target-depth) 3069 nil))))) 3070;;;_ > allout-next-sibling-leap (&optional depth backward) 3071(defun allout-next-sibling-leap (&optional depth backward) 3072 "Like `allout-next-sibling', but by direct search for topic at depth. 3073 3074Traverse at optional DEPTH, or current depth if none specified. 3075 3076Go backward if optional arg BACKWARD is non-nil. 3077 3078Return the start point of the new topic if successful, nil otherwise. 3079 3080Costs more than regular `allout-next-sibling' for short traversals: 3081 3082 - we have to check the prior (next, if travelling backwards) 3083 item to confirm connectivity with the prior topic, and 3084 - if confirmed, we have to reestablish the allout-recent-* settings with 3085 some extra navigation 3086 - if confirmation fails, we have to do more work to recover 3087 3088It is an increasingly big win when there are many intervening 3089offspring before the next sibling, however, so 3090`allout-next-sibling' resorts to this if it finds itself in that 3091situation." 3092 3093 (if (if backward (bobp) (eobp)) 3094 nil 3095 (let* ((start-point (point)) 3096 (target-depth (or depth (allout-depth))) 3097 (search-whitespace-regexp nil) 3098 (depth-biased (- target-depth 2)) 3099 (expression (if (<= target-depth 1) 3100 allout-depth-one-regexp 3101 (format allout-depth-specific-regexp 3102 depth-biased depth-biased))) 3103 found 3104 done) 3105 (while (not done) 3106 (setq found (if backward 3107 (re-search-backward expression nil 'to-limit) 3108 (forward-char 1) 3109 (re-search-forward expression nil 'to-limit))) 3110 (if (and found (allout-aberrant-container-p)) 3111 (setq found nil)) 3112 (setq done (or found (if backward (bobp) (eobp))))) 3113 (if (not found) 3114 (progn (goto-char start-point) 3115 nil) 3116 ;; rationale: if any intervening items were at a lower depth, we 3117 ;; would now be on the first offspring at the target depth - ie, 3118 ;; the preceeding item (per the search direction) must be at a 3119 ;; lesser depth. that's all we need to check. 3120 (if backward (allout-next-heading) (allout-previous-heading)) 3121 (if (< allout-recent-depth target-depth) 3122 ;; return to start and reestablish allout-recent-*: 3123 (progn 3124 (goto-char start-point) 3125 (allout-depth) 3126 nil) 3127 (goto-char found) 3128 ;; locate cursor and set allout-recent-*: 3129 (allout-goto-prefix)))))) 3130;;;_ > allout-previous-sibling (&optional depth backward) 3131(defun allout-previous-sibling (&optional depth backward) 3132 "Like `allout-forward-current-level' backwards, respecting invisible topics. 3133 3134Optional DEPTH specifies depth to traverse, default current depth. 3135 3136Optional BACKWARD reverses direction. 3137 3138Return depth if successful, nil otherwise." 3139 (allout-next-sibling depth (not backward)) 3140 ) 3141;;;_ > allout-snug-back () 3142(defun allout-snug-back () 3143 "Position cursor at end of previous topic. 3144 3145Presumes point is at the start of a topic prefix." 3146 (if (or (bobp) (eobp)) 3147 nil 3148 (forward-char -1)) 3149 (if (or (bobp) (not (= ?\n (preceding-char)))) 3150 nil 3151 (forward-char -1)) 3152 (point)) 3153;;;_ > allout-beginning-of-level () 3154(defun allout-beginning-of-level () 3155 "Go back to the first sibling at this level, visible or not." 3156 (allout-end-of-level 'backward)) 3157;;;_ > allout-end-of-level (&optional backward) 3158(defun allout-end-of-level (&optional backward) 3159 "Go to the last sibling at this level, visible or not." 3160 3161 (let ((depth (allout-depth))) 3162 (while (allout-previous-sibling depth nil)) 3163 (prog1 allout-recent-depth 3164 (if (interactive-p) (allout-end-of-prefix))))) 3165;;;_ > allout-next-visible-heading (arg) 3166(defun allout-next-visible-heading (arg) 3167 "Move to the next ARG'th visible heading line, backward if arg is negative. 3168 3169Move to buffer limit in indicated direction if headings are exhausted." 3170 3171 (interactive "p") 3172 (let* ((inhibit-field-text-motion t) 3173 (backward (if (< arg 0) (setq arg (* -1 arg)))) 3174 (step (if backward -1 1)) 3175 prev got) 3176 3177 (while (> arg 0) 3178 (while (and 3179 ;; Boundary condition: 3180 (not (if backward (bobp)(eobp))) 3181 ;; Move, skipping over all concealed lines in one fell swoop: 3182 (prog1 (condition-case nil (or (line-move step) t) 3183 (error nil)) 3184 (allout-beginning-of-current-line)) 3185 ;; Deal with apparent header line: 3186 (if (not (looking-at allout-regexp)) 3187 ;; not a header line, keep looking: 3188 t 3189 (allout-prefix-data) 3190 (if (and (allout-do-doublecheck) 3191 (allout-aberrant-container-p)) 3192 ;; skip this aberrant prospective header line: 3193 t 3194 ;; this prospective headerline qualifies - register: 3195 (setq got allout-recent-prefix-beginning) 3196 ;; and break the loop: 3197 nil)))) 3198 ;; Register this got, it may be the last: 3199 (if got (setq prev got)) 3200 (setq arg (1- arg))) 3201 (cond (got ; Last move was to a prefix: 3202 (allout-end-of-prefix)) 3203 (prev ; Last move wasn't, but prev was: 3204 (goto-char prev) 3205 (allout-end-of-prefix)) 3206 ((not backward) (end-of-line) nil)))) 3207;;;_ > allout-previous-visible-heading (arg) 3208(defun allout-previous-visible-heading (arg) 3209 "Move to the previous heading line. 3210 3211With argument, repeats or can move forward if negative. 3212A heading line is one that starts with a `*' (or that `allout-regexp' 3213matches)." 3214 (interactive "p") 3215 (prog1 (allout-next-visible-heading (- arg)) 3216 (if (interactive-p) (allout-end-of-prefix)))) 3217;;;_ > allout-forward-current-level (arg) 3218(defun allout-forward-current-level (arg) 3219 "Position point at the next heading of the same level. 3220 3221Takes optional repeat-count, goes backward if count is negative. 3222 3223Returns resulting position, else nil if none found." 3224 (interactive "p") 3225 (let ((start-depth (allout-current-depth)) 3226 (start-arg arg) 3227 (backward (> 0 arg))) 3228 (if (= 0 start-depth) 3229 (error "No siblings, not in a topic...")) 3230 (if backward (setq arg (* -1 arg))) 3231 (allout-back-to-current-heading) 3232 (while (and (not (zerop arg)) 3233 (if backward 3234 (allout-previous-sibling) 3235 (allout-next-sibling))) 3236 (setq arg (1- arg))) 3237 (if (not (interactive-p)) 3238 nil 3239 (allout-end-of-prefix) 3240 (if (not (zerop arg)) 3241 (error "Hit %s level %d topic, traversed %d of %d requested" 3242 (if backward "first" "last") 3243 allout-recent-depth 3244 (- (abs start-arg) arg) 3245 (abs start-arg)))))) 3246;;;_ > allout-backward-current-level (arg) 3247(defun allout-backward-current-level (arg) 3248 "Inverse of `allout-forward-current-level'." 3249 (interactive "p") 3250 (if (interactive-p) 3251 (let ((current-prefix-arg (* -1 arg))) 3252 (call-interactively 'allout-forward-current-level)) 3253 (allout-forward-current-level (* -1 arg)))) 3254 3255;;;_ #5 Alteration 3256 3257;;;_ - Fundamental 3258;;;_ = allout-post-goto-bullet 3259(defvar allout-post-goto-bullet nil 3260 "Outline internal var, for `allout-pre-command-business' hot-spot operation. 3261 3262When set, tells post-processing to reposition on topic bullet, and 3263then unset it. Set by `allout-pre-command-business' when implementing 3264hot-spot operation, where literal characters typed over a topic bullet 3265are mapped to the command of the corresponding control-key on the 3266`allout-mode-map'.") 3267(make-variable-buffer-local 'allout-post-goto-bullet) 3268;;;_ = allout-command-counter 3269(defvar allout-command-counter 0 3270 "Counter that monotonically increases in allout-mode buffers. 3271 3272Set by `allout-pre-command-business', to support allout addons in 3273coordinating with allout activity.") 3274(make-variable-buffer-local 'allout-command-counter) 3275;;;_ > allout-post-command-business () 3276(defun allout-post-command-business () 3277 "Outline `post-command-hook' function. 3278 3279- Implement (and clear) `allout-post-goto-bullet', for hot-spot 3280 outline commands. 3281 3282- Decrypt topic currently being edited if it was encrypted for a save." 3283 3284 ; Apply any external change func: 3285 (if (not (allout-mode-p)) ; In allout-mode. 3286 nil 3287 3288 (if (and (boundp 'allout-after-save-decrypt) 3289 allout-after-save-decrypt) 3290 (allout-after-saves-handler)) 3291 3292 ;; Implement allout-post-goto-bullet, if set: 3293 (if (and allout-post-goto-bullet 3294 (allout-current-bullet-pos)) 3295 (progn (goto-char (allout-current-bullet-pos)) 3296 (setq allout-post-goto-bullet nil))) 3297 )) 3298;;;_ > allout-pre-command-business () 3299(defun allout-pre-command-business () 3300 "Outline `pre-command-hook' function for outline buffers. 3301 3302Among other things, implements special behavior when the cursor is on the 3303topic bullet character. 3304 3305When the cursor is on the bullet character, self-insert characters are 3306reinterpreted as the corresponding control-character in the 3307`allout-mode-map'. The `allout-mode' `post-command-hook' insures that 3308the cursor which has moved as a result of such reinterpretation is 3309positioned on the bullet character of the destination topic. 3310 3311The upshot is that you can get easy, single (ie, unmodified) key 3312outline maneuvering operations by positioning the cursor on the bullet 3313char. When in this mode you can use regular cursor-positioning 3314command/keystrokes to relocate the cursor off of a bullet character to 3315return to regular interpretation of self-insert characters." 3316 3317 (if (not (allout-mode-p)) 3318 nil 3319 ;; Increment allout-command-counter 3320 (setq allout-command-counter (1+ allout-command-counter)) 3321 ;; Do hot-spot navigation. 3322 (if (and (eq this-command 'self-insert-command) 3323 (eq (point)(allout-current-bullet-pos))) 3324 (allout-hotspot-key-handler)))) 3325;;;_ > allout-hotspot-key-handler () 3326(defun allout-hotspot-key-handler () 3327 "Catchall handling of key bindings in hot-spots. 3328 3329Translates unmodified keystrokes to corresponding allout commands, when 3330they would qualify if prefixed with the allout-command-prefix, and sets 3331this-command accordingly. 3332 3333Returns the qualifying command, if any, else nil." 3334 (interactive) 3335 (let* ((key-string (if (numberp last-command-char) 3336 (char-to-string last-command-char))) 3337 (key-num (cond ((numberp last-command-char) last-command-char) 3338 ;; for XEmacs character type: 3339 ((and (fboundp 'characterp) 3340 (apply 'characterp (list last-command-char))) 3341 (apply 'char-to-int (list last-command-char))) 3342 (t 0))) 3343 mapped-binding) 3344 3345 (if (zerop key-num) 3346 nil 3347 3348 (if (and 3349 ;; exclude control chars and escape: 3350 (<= 33 key-num) 3351 (setq mapped-binding 3352 (or (and (assoc key-string allout-keybindings-list) 3353 ;; translate literal membership on list: 3354 (cadr (assoc key-string allout-keybindings-list))) 3355 ;; translate as a keybinding: 3356 (key-binding (concat allout-command-prefix 3357 (char-to-string 3358 (if (and (<= 97 key-num) ; "a" 3359 (>= 122 key-num)) ; "z" 3360 (- key-num 96) key-num))) 3361 t)))) 3362 ;; Qualified as an allout command - do hot-spot operation. 3363 (setq allout-post-goto-bullet t) 3364 ;; accept-defaults nil, or else we'll get allout-item-icon-key-handler. 3365 (setq mapped-binding (key-binding (char-to-string key-num)))) 3366 3367 (while (keymapp mapped-binding) 3368 (setq mapped-binding 3369 (lookup-key mapped-binding (vector (read-char))))) 3370 3371 (if mapped-binding 3372 (setq this-command mapped-binding))))) 3373 3374;;;_ > allout-find-file-hook () 3375(defun allout-find-file-hook () 3376 "Activate `allout-mode' on non-nil `allout-auto-activation', `allout-layout'. 3377 3378See `allout-init' for setup instructions." 3379 (if (and allout-auto-activation 3380 (not (allout-mode-p)) 3381 allout-layout) 3382 (allout-mode t))) 3383 3384;;;_ - Topic Format Assessment 3385;;;_ > allout-solicit-alternate-bullet (depth &optional current-bullet) 3386(defun allout-solicit-alternate-bullet (depth &optional current-bullet) 3387 3388 "Prompt for and return a bullet char as an alternative to the current one. 3389 3390Offer one suitable for current depth DEPTH as default." 3391 3392 (let* ((default-bullet (or (and (stringp current-bullet) current-bullet) 3393 (allout-bullet-for-depth depth))) 3394 (sans-escapes (regexp-sans-escapes allout-bullets-string)) 3395 choice) 3396 (save-excursion 3397 (goto-char (allout-current-bullet-pos)) 3398 (setq choice (solicit-char-in-string 3399 (format "Select bullet: %s ('%s' default): " 3400 sans-escapes 3401 (substring-no-properties default-bullet)) 3402 sans-escapes 3403 t))) 3404 (message "") 3405 (if (string= choice "") default-bullet choice)) 3406 ) 3407;;;_ > allout-distinctive-bullet (bullet) 3408(defun allout-distinctive-bullet (bullet) 3409 "True if BULLET is one of those on `allout-distinctive-bullets-string'." 3410 (string-match (regexp-quote bullet) allout-distinctive-bullets-string)) 3411;;;_ > allout-numbered-type-prefix (&optional prefix) 3412(defun allout-numbered-type-prefix (&optional prefix) 3413 "True if current header prefix bullet is numbered bullet." 3414 (and allout-numbered-bullet 3415 (string= allout-numbered-bullet 3416 (if prefix 3417 (allout-get-prefix-bullet prefix) 3418 (allout-get-bullet))))) 3419;;;_ > allout-encrypted-type-prefix (&optional prefix) 3420(defun allout-encrypted-type-prefix (&optional prefix) 3421 "True if current header prefix bullet is for an encrypted entry (body)." 3422 (and allout-topic-encryption-bullet 3423 (string= allout-topic-encryption-bullet 3424 (if prefix 3425 (allout-get-prefix-bullet prefix) 3426 (allout-get-bullet))))) 3427;;;_ > allout-bullet-for-depth (&optional depth) 3428(defun allout-bullet-for-depth (&optional depth) 3429 "Return outline topic bullet suited to optional DEPTH, or current depth." 3430 ;; Find bullet in plain-bullets-string modulo DEPTH. 3431 (if allout-stylish-prefixes 3432 (char-to-string (aref allout-plain-bullets-string 3433 (% (max 0 (- depth 2)) 3434 allout-plain-bullets-string-len))) 3435 allout-primary-bullet) 3436 ) 3437 3438;;;_ - Topic Production 3439;;;_ > allout-make-topic-prefix (&optional prior-bullet 3440(defun allout-make-topic-prefix (&optional prior-bullet 3441 new 3442 depth 3443 solicit 3444 number-control 3445 index) 3446 ;; Depth null means use current depth, non-null means we're either 3447 ;; opening a new topic after current topic, lower or higher, or we're 3448 ;; changing level of current topic. 3449 ;; Solicit dominates specified bullet-char. 3450;;;_ . Doc string: 3451 "Generate a topic prefix suitable for optional arg DEPTH, or current depth. 3452 3453All the arguments are optional. 3454 3455PRIOR-BULLET indicates the bullet of the prefix being changed, or 3456nil if none. This bullet may be preserved (other options 3457notwithstanding) if it is on the `allout-distinctive-bullets-string', 3458for instance. 3459 3460Second arg NEW indicates that a new topic is being opened after the 3461topic at point, if non-nil. Default bullet for new topics, eg, may 3462be set (contingent to other args) to numbered bullets if previous 3463sibling is one. The implication otherwise is that the current topic 3464is being adjusted - shifted or rebulleted - and we don't consider 3465bullet or previous sibling. 3466 3467Third arg DEPTH forces the topic prefix to that depth, regardless of 3468the current topics' depth. 3469 3470If SOLICIT is non-nil, then the choice of bullet is solicited from 3471user. If it's a character, then that character is offered as the 3472default, otherwise the one suited to the context (according to 3473distinction or depth) is offered. (This overrides other options, 3474including, eg, a distinctive PRIOR-BULLET.) If non-nil, then the 3475context-specific bullet is used. 3476 3477Fifth arg, NUMBER-CONTROL, matters only if `allout-numbered-bullet' 3478is non-nil *and* soliciting was not explicitly invoked. Then 3479NUMBER-CONTROL non-nil forces prefix to either numbered or 3480denumbered format, depending on the value of the sixth arg, INDEX. 3481 3482\(Note that NUMBER-CONTROL does *not* apply to level 1 topics. Sorry...) 3483 3484If NUMBER-CONTROL is non-nil and sixth arg INDEX is non-nil then 3485the prefix of the topic is forced to be numbered. Non-nil 3486NUMBER-CONTROL and nil INDEX forces non-numbered format on the 3487bullet. Non-nil NUMBER-CONTROL and non-nil, non-number INDEX means 3488that the index for the numbered prefix will be derived, by counting 3489siblings back to start of level. If INDEX is a number, then that 3490number is used as the index for the numbered prefix (allowing, eg, 3491sequential renumbering to not require this function counting back the 3492index for each successive sibling)." 3493;;;_ . Code: 3494 ;; The options are ordered in likely frequence of use, most common 3495 ;; highest, least lowest. Ie, more likely to be doing prefix 3496 ;; adjustments than soliciting, and yet more than numbering. 3497 ;; Current prefix is least dominant, but most likely to be commonly 3498 ;; specified... 3499 3500 (let* (body 3501 numbering 3502 denumbering 3503 (depth (or depth (allout-depth))) 3504 (header-lead allout-header-prefix) 3505 (bullet-char 3506 3507 ;; Getting value for bullet char is practically the whole job: 3508 3509 (cond 3510 ; Simplest situation - level 1: 3511 ((<= depth 1) (setq header-lead "") allout-primary-bullet) 3512 ; Simple, too: all asterisks: 3513 (allout-old-style-prefixes 3514 ;; Cheat - make body the whole thing, null out header-lead and 3515 ;; bullet-char: 3516 (setq body (make-string depth 3517 (string-to-char allout-primary-bullet))) 3518 (setq header-lead "") 3519 "") 3520 3521 ;; (Neither level 1 nor old-style, so we're space padding. 3522 ;; Sneak it in the condition of the next case, whatever it is.) 3523 3524 ;; Solicitation overrides numbering and other cases: 3525 ((progn (setq body (make-string (- depth 2) ?\ )) 3526 ;; The actual condition: 3527 solicit) 3528 (let* ((got (allout-solicit-alternate-bullet depth solicit))) 3529 ;; Gotta check whether we're numbering and got a numbered bullet: 3530 (setq numbering (and allout-numbered-bullet 3531 (not (and number-control (not index))) 3532 (string= got allout-numbered-bullet))) 3533 ;; Now return what we got, regardless: 3534 got)) 3535 3536 ;; Numbering invoked through args: 3537 ((and allout-numbered-bullet number-control) 3538 (if (setq numbering (not (setq denumbering (not index)))) 3539 allout-numbered-bullet 3540 (if (and prior-bullet 3541 (not (string= allout-numbered-bullet 3542 prior-bullet))) 3543 prior-bullet 3544 (allout-bullet-for-depth depth)))) 3545 3546 ;;; Neither soliciting nor controlled numbering ;;; 3547 ;;; (may be controlled denumbering, tho) ;;; 3548 3549 ;; Check wrt previous sibling: 3550 ((and new ; only check for new prefixes 3551 (<= depth (allout-depth)) 3552 allout-numbered-bullet ; ... & numbering enabled 3553 (not denumbering) 3554 (let ((sibling-bullet 3555 (save-excursion 3556 ;; Locate correct sibling: 3557 (or (>= depth (allout-depth)) 3558 (allout-ascend-to-depth depth)) 3559 (allout-get-bullet)))) 3560 (if (and sibling-bullet 3561 (string= allout-numbered-bullet sibling-bullet)) 3562 (setq numbering sibling-bullet))))) 3563 3564 ;; Distinctive prior bullet? 3565 ((and prior-bullet 3566 (allout-distinctive-bullet prior-bullet) 3567 ;; Either non-numbered: 3568 (or (not (and allout-numbered-bullet 3569 (string= prior-bullet allout-numbered-bullet))) 3570 ;; or numbered, and not denumbering: 3571 (setq numbering (not denumbering))) 3572 ;; Here 'tis: 3573 prior-bullet)) 3574 3575 ;; Else, standard bullet per depth: 3576 ((allout-bullet-for-depth depth))))) 3577 3578 (concat header-lead 3579 body 3580 bullet-char 3581 (if numbering 3582 (format "%d" (cond ((and index (numberp index)) index) 3583 (new (1+ (allout-sibling-index depth))) 3584 ((allout-sibling-index)))))) 3585 ) 3586 ) 3587;;;_ > allout-open-topic (relative-depth &optional before offer-recent-bullet) 3588(defun allout-open-topic (relative-depth &optional before offer-recent-bullet) 3589 "Open a new topic at depth DEPTH. 3590 3591New topic is situated after current one, unless optional flag BEFORE 3592is non-nil, or unless current line is completely empty - lacking even 3593whitespace - in which case open is done on the current line. 3594 3595When adding an offspring, it will be added immediately after the parent if 3596the other offspring are exposed, or after the last child if the offspring 3597are hidden. (The intervening offspring will be exposed in the latter 3598case.) 3599 3600If OFFER-RECENT-BULLET is true, offer to use the bullet of the prior sibling. 3601 3602Nuances: 3603 3604- Creation of new topics is with respect to the visible topic 3605 containing the cursor, regardless of intervening concealed ones. 3606 3607- New headers are generally created after/before the body of a 3608 topic. However, they are created right at cursor location if the 3609 cursor is on a blank line, even if that breaks the current topic 3610 body. This is intentional, to provide a simple means for 3611 deliberately dividing topic bodies. 3612 3613- Double spacing of topic lists is preserved. Also, the first 3614 level two topic is created double-spaced (and so would be 3615 subsequent siblings, if that's left intact). Otherwise, 3616 single-spacing is used. 3617 3618- Creation of sibling or nested topics is with respect to the topic 3619 you're starting from, even when creating backwards. This way you 3620 can easily create a sibling in front of the current topic without 3621 having to go to its preceding sibling, and then open forward 3622 from there." 3623 3624 (allout-beginning-of-current-line) 3625 (let* ((inhibit-field-text-motion t) 3626 (depth (+ (allout-current-depth) relative-depth)) 3627 (opening-on-blank (if (looking-at "^\$") 3628 (not (setq before nil)))) 3629 ;; bunch o vars set while computing ref-topic 3630 opening-numbered 3631 ref-depth 3632 ref-bullet 3633 (ref-topic (save-excursion 3634 (cond ((< relative-depth 0) 3635 (allout-ascend-to-depth depth)) 3636 ((>= relative-depth 1) nil) 3637 (t (allout-back-to-current-heading))) 3638 (setq ref-depth allout-recent-depth) 3639 (setq ref-bullet 3640 (if (> allout-recent-prefix-end 1) 3641 (allout-recent-bullet) 3642 "")) 3643 (setq opening-numbered 3644 (save-excursion 3645 (and allout-numbered-bullet 3646 (or (<= relative-depth 0) 3647 (allout-descend-to-depth depth)) 3648 (if (allout-numbered-type-prefix) 3649 allout-numbered-bullet)))) 3650 (point))) 3651 dbl-space 3652 doing-beginning 3653 start end) 3654 3655 (if (not opening-on-blank) 3656 ; Positioning and vertical 3657 ; padding - only if not 3658 ; opening-on-blank: 3659 (progn 3660 (goto-char ref-topic) 3661 (setq dbl-space ; Determine double space action: 3662 (or (and (<= relative-depth 0) ; not descending; 3663 (save-excursion 3664 ;; at b-o-b or preceded by a blank line? 3665 (or (> 0 (forward-line -1)) 3666 (looking-at "^\\s-*$") 3667 (bobp))) 3668 (save-excursion 3669 ;; succeeded by a blank line? 3670 (allout-end-of-current-subtree) 3671 (looking-at "\n\n"))) 3672 (and (= ref-depth 1) 3673 (or before 3674 (= depth 1) 3675 (save-excursion 3676 ;; Don't already have following 3677 ;; vertical padding: 3678 (not (allout-pre-next-prefix))))))) 3679 3680 ;; Position to prior heading, if inserting backwards, and not 3681 ;; going outwards: 3682 (if (and before (>= relative-depth 0)) 3683 (progn (allout-back-to-current-heading) 3684 (setq doing-beginning (bobp)) 3685 (if (not (bobp)) 3686 (allout-previous-heading))) 3687 (if (and before (bobp)) 3688 (open-line 1))) 3689 3690 (if (<= relative-depth 0) 3691 ;; Not going inwards, don't snug up: 3692 (if doing-beginning 3693 (if (not dbl-space) 3694 (open-line 1) 3695 (open-line 2)) 3696 (if before 3697 (progn (end-of-line) 3698 (allout-pre-next-prefix) 3699 (while (and (= ?\n (following-char)) 3700 (save-excursion 3701 (forward-char 1) 3702 (allout-hidden-p))) 3703 (forward-char 1)) 3704 (if (not (looking-at "^$")) 3705 (open-line 1))) 3706 (allout-end-of-current-subtree) 3707 (if (looking-at "\n\n") (forward-char 1)))) 3708 ;; Going inwards - double-space if first offspring is 3709 ;; double-spaced, otherwise snug up. 3710 (allout-end-of-entry) 3711 (if (eobp) 3712 (newline 1) 3713 (line-move 1)) 3714 (allout-beginning-of-current-line) 3715 (backward-char 1) 3716 (if (bolp) 3717 ;; Blank lines between current header body and next 3718 ;; header - get to last substantive (non-white-space) 3719 ;; line in body: 3720 (progn (setq dbl-space t) 3721 (re-search-backward "[^ \t\n]" nil t))) 3722 (if (looking-at "\n\n") 3723 (setq dbl-space t)) 3724 (if (save-excursion 3725 (allout-next-heading) 3726 (when (> allout-recent-depth ref-depth) 3727 ;; This is an offspring. 3728 (forward-line -1) 3729 (looking-at "^\\s-*$"))) 3730 (progn (forward-line 1) 3731 (open-line 1) 3732 (forward-line 1))) 3733 (allout-end-of-current-line)) 3734 3735 ;;(if doing-beginning (goto-char doing-beginning)) 3736 (if (not (bobp)) 3737 ;; We insert a newline char rather than using open-line to 3738 ;; avoid rear-stickiness inheritence of read-only property. 3739 (progn (if (and (not (> depth ref-depth)) 3740 (not before)) 3741 (open-line 1) 3742 (if (and (not dbl-space) (> depth ref-depth)) 3743 (newline 1) 3744 (if dbl-space 3745 (open-line 1) 3746 (if (not before) 3747 (newline 1))))) 3748 (if (and dbl-space (not (> relative-depth 0))) 3749 (newline 1)) 3750 (if (and (not (eobp)) 3751 (or (not (bolp)) 3752 (and (not (bobp)) 3753 ;; bolp doesnt detect concealed 3754 ;; trailing newlines, compensate: 3755 (save-excursion 3756 (forward-char -1) 3757 (allout-hidden-p))))) 3758 (forward-char 1)))) 3759 )) 3760 (setq start (point)) 3761 (insert (concat (allout-make-topic-prefix opening-numbered t depth) 3762 " ")) 3763 (setq end (1+ (point))) 3764 3765 (allout-rebullet-heading (and offer-recent-bullet ref-bullet) 3766 depth nil nil t) 3767 (if (> relative-depth 0) 3768 (save-excursion (goto-char ref-topic) 3769 (allout-show-children))) 3770 (end-of-line) 3771 3772 (run-hook-with-args 'allout-structure-added-hook start end) 3773 ) 3774 ) 3775;;;_ > allout-open-subtopic (arg) 3776(defun allout-open-subtopic (arg) 3777 "Open new topic header at deeper level than the current one. 3778 3779Negative universal arg means to open deeper, but place the new topic 3780prior to the current one." 3781 (interactive "p") 3782 (allout-open-topic 1 (> 0 arg) (< 1 arg))) 3783;;;_ > allout-open-sibtopic (arg) 3784(defun allout-open-sibtopic (arg) 3785 "Open new topic header at same level as the current one. 3786 3787Positive universal arg means to use the bullet of the prior sibling. 3788 3789Negative universal arg means to place the new topic prior to the current 3790one." 3791 (interactive "p") 3792 (allout-open-topic 0 (> 0 arg) (not (= 1 arg)))) 3793;;;_ > allout-open-supertopic (arg) 3794(defun allout-open-supertopic (arg) 3795 "Open new topic header at shallower level than the current one. 3796 3797Negative universal arg means to open shallower, but place the new 3798topic prior to the current one." 3799 3800 (interactive "p") 3801 (allout-open-topic -1 (> 0 arg) (< 1 arg))) 3802 3803;;;_ - Outline Alteration 3804;;;_ : Topic Modification 3805;;;_ = allout-former-auto-filler 3806(defvar allout-former-auto-filler nil 3807 "Name of modal fill function being wrapped by `allout-auto-fill'.") 3808;;;_ > allout-auto-fill () 3809(defun allout-auto-fill () 3810 "`allout-mode' autofill function. 3811 3812Maintains outline hanging topic indentation if 3813`allout-use-hanging-indents' is set." 3814 3815 (when (not allout-inhibit-auto-fill) 3816 (let ((fill-prefix (if allout-use-hanging-indents 3817 ;; Check for topic header indentation: 3818 (save-excursion 3819 (beginning-of-line) 3820 (if (looking-at allout-regexp) 3821 ;; ... construct indentation to account for 3822 ;; length of topic prefix: 3823 (make-string (progn (allout-end-of-prefix) 3824 (current-column)) 3825 ?\ ))))) 3826 (use-auto-fill-function (or allout-outside-normal-auto-fill-function 3827 auto-fill-function 3828 'do-auto-fill))) 3829 (if (or allout-former-auto-filler allout-use-hanging-indents) 3830 (funcall use-auto-fill-function))))) 3831;;;_ > allout-reindent-body (old-depth new-depth &optional number) 3832(defun allout-reindent-body (old-depth new-depth &optional number) 3833 "Reindent body lines which were indented at OLD-DEPTH to NEW-DEPTH. 3834 3835Optional arg NUMBER indicates numbering is being added, and it must 3836be accommodated. 3837 3838Note that refill of indented paragraphs is not done." 3839 3840 (save-excursion 3841 (allout-end-of-prefix) 3842 (let* ((new-margin (current-column)) 3843 excess old-indent-begin old-indent-end 3844 ;; We want the column where the header-prefix text started 3845 ;; *before* the prefix was changed, so we infer it relative 3846 ;; to the new margin and the shift in depth: 3847 (old-margin (+ old-depth (- new-margin new-depth)))) 3848 3849 ;; Process lines up to (but excluding) next topic header: 3850 (allout-unprotected 3851 (save-match-data 3852 (while 3853 (and (re-search-forward "\n\\(\\s-*\\)" 3854 nil 3855 t) 3856 ;; Register the indent data, before we reset the 3857 ;; match data with a subsequent `looking-at': 3858 (setq old-indent-begin (match-beginning 1) 3859 old-indent-end (match-end 1)) 3860 (not (looking-at allout-regexp))) 3861 (if (> 0 (setq excess (- (- old-indent-end old-indent-begin) 3862 old-margin))) 3863 ;; Text starts left of old margin - don't adjust: 3864 nil 3865 ;; Text was hanging at or right of old left margin - 3866 ;; reindent it, preserving its existing indentation 3867 ;; beyond the old margin: 3868 (delete-region old-indent-begin old-indent-end) 3869 (indent-to (+ new-margin excess (current-column)))))))))) 3870;;;_ > allout-rebullet-current-heading (arg) 3871(defun allout-rebullet-current-heading (arg) 3872 "Solicit new bullet for current visible heading." 3873 (interactive "p") 3874 (let ((initial-col (current-column)) 3875 (on-bullet (eq (point)(allout-current-bullet-pos))) 3876 from to 3877 (backwards (if (< arg 0) 3878 (setq arg (* arg -1))))) 3879 (while (> arg 0) 3880 (save-excursion (allout-back-to-current-heading) 3881 (allout-end-of-prefix) 3882 (setq from allout-recent-prefix-beginning 3883 to allout-recent-prefix-end) 3884 (allout-rebullet-heading t ;;; solicit 3885 nil ;;; depth 3886 nil ;;; number-control 3887 nil ;;; index 3888 t) ;;; do-successors 3889 (run-hook-with-args 'allout-exposure-change-hook 3890 from to t)) 3891 (setq arg (1- arg)) 3892 (if (<= arg 0) 3893 nil 3894 (setq initial-col nil) ; Override positioning back to init col 3895 (if (not backwards) 3896 (allout-next-visible-heading 1) 3897 (allout-goto-prefix-doublechecked) 3898 (allout-next-visible-heading -1)))) 3899 (message "Done.") 3900 (cond (on-bullet (goto-char (allout-current-bullet-pos))) 3901 (initial-col (move-to-column initial-col))))) 3902;;;_ > allout-rebullet-heading (&optional solicit ...) 3903(defun allout-rebullet-heading (&optional solicit 3904 new-depth 3905 number-control 3906 index 3907 do-successors) 3908 3909 "Adjust bullet of current topic prefix. 3910 3911All args are optional. 3912 3913If SOLICIT is non-nil, then the choice of bullet is solicited from 3914user. If it's a character, then that character is offered as the 3915default, otherwise the one suited to the context (according to 3916distinction or depth) is offered. If non-nil, then the 3917context-specific bullet is just used. 3918 3919Second arg DEPTH forces the topic prefix to that depth, regardless 3920of the topic's current depth. 3921 3922Third arg NUMBER-CONTROL can force the prefix to or away from 3923numbered form. It has effect only if `allout-numbered-bullet' is 3924non-nil and soliciting was not explicitly invoked (via first arg). 3925Its effect, numbering or denumbering, then depends on the setting 3926of the forth arg, INDEX. 3927 3928If NUMBER-CONTROL is non-nil and forth arg INDEX is nil, then the 3929prefix of the topic is forced to be non-numbered. Null index and 3930non-nil NUMBER-CONTROL forces denumbering. Non-nil INDEX (and 3931non-nil NUMBER-CONTROL) forces a numbered-prefix form. If non-nil 3932INDEX is a number, then that number is used for the numbered 3933prefix. Non-nil and non-number means that the index for the 3934numbered prefix will be derived by allout-make-topic-prefix. 3935 3936Fifth arg DO-SUCCESSORS t means re-resolve count on succeeding 3937siblings. 3938 3939Cf vars `allout-stylish-prefixes', `allout-old-style-prefixes', 3940and `allout-numbered-bullet', which all affect the behavior of 3941this function." 3942 3943 (let* ((current-depth (allout-depth)) 3944 (new-depth (or new-depth current-depth)) 3945 (mb allout-recent-prefix-beginning) 3946 (me allout-recent-prefix-end) 3947 (current-bullet (buffer-substring-no-properties (- me 1) me)) 3948 (has-annotation (get-text-property mb 'allout-was-hidden)) 3949 (new-prefix (allout-make-topic-prefix current-bullet 3950 nil 3951 new-depth 3952 solicit 3953 number-control 3954 index))) 3955 3956 ;; Is new one is identical to old? 3957 (if (and (= current-depth new-depth) 3958 (string= current-bullet 3959 (substring new-prefix (1- (length new-prefix))))) 3960 ;; Nothing to do: 3961 t 3962 3963 ;; New prefix probably different from old: 3964 ; get rid of old one: 3965 (allout-unprotected (delete-region mb me)) 3966 (goto-char mb) 3967 ; Dispense with number if 3968 ; numbered-bullet prefix: 3969 (if (and allout-numbered-bullet 3970 (string= allout-numbered-bullet current-bullet) 3971 (looking-at "[0-9]+")) 3972 (allout-unprotected 3973 (delete-region (match-beginning 0)(match-end 0)))) 3974 3975 ;; convey 'allout-was-hidden annotation, if original had it: 3976 (if has-annotation 3977 (put-text-property 0 (length new-prefix) 'allout-was-hidden t 3978 new-prefix)) 3979 3980 ; Put in new prefix: 3981 (allout-unprotected (insert new-prefix)) 3982 3983 ;; Reindent the body if elected, margin changed, and not encrypted body: 3984 (if (and allout-reindent-bodies 3985 (not (= new-depth current-depth)) 3986 (not (allout-encrypted-topic-p))) 3987 (allout-reindent-body current-depth new-depth)) 3988 3989 ;; Recursively rectify successive siblings of orig topic if 3990 ;; caller elected for it: 3991 (if do-successors 3992 (save-excursion 3993 (while (allout-next-sibling new-depth nil) 3994 (setq index 3995 (cond ((numberp index) (1+ index)) 3996 ((not number-control) (allout-sibling-index)))) 3997 (if (allout-numbered-type-prefix) 3998 (allout-rebullet-heading nil ;;; solicit 3999 new-depth ;;; new-depth 4000 number-control;;; number-control 4001 index ;;; index 4002 nil))))) ;;;(dont!)do-successors 4003 ) ; (if (and (= current-depth new-depth)...)) 4004 ) ; let* ((current-depth (allout-depth))...) 4005 ) ; defun 4006;;;_ > allout-rebullet-topic (arg) 4007(defun allout-rebullet-topic (arg &optional sans-offspring) 4008 "Rebullet the visible topic containing point and all contained subtopics. 4009 4010Descends into invisible as well as visible topics, however. 4011 4012When optional sans-offspring is non-nil, subtopics are not 4013shifted. (Shifting a topic outwards without shifting its 4014offspring is disallowed, since this would create a \"containment 4015discontinuity\", where the depth difference between a topic and 4016its immediate offspring is greater than one.) 4017 4018With repeat count, shift topic depth by that amount." 4019 (interactive "P") 4020 (let ((start-col (current-column))) 4021 (save-excursion 4022 ;; Normalize arg: 4023 (cond ((null arg) (setq arg 0)) 4024 ((listp arg) (setq arg (car arg)))) 4025 ;; Fill the user in, in case we're shifting a big topic: 4026 (if (not (zerop arg)) (message "Shifting...")) 4027 (allout-back-to-current-heading) 4028 (if (<= (+ allout-recent-depth arg) 0) 4029 (error "Attempt to shift topic below level 1")) 4030 (allout-rebullet-topic-grunt arg nil nil nil nil sans-offspring) 4031 (if (not (zerop arg)) (message "Shifting... done."))) 4032 (move-to-column (max 0 (+ start-col arg))))) 4033;;;_ > allout-rebullet-topic-grunt (&optional relative-depth ...) 4034(defun allout-rebullet-topic-grunt (&optional relative-depth 4035 starting-depth 4036 starting-point 4037 index 4038 do-successors 4039 sans-offspring) 4040 "Like `allout-rebullet-topic', but on nearest containing topic 4041\(visible or not). 4042 4043See `allout-rebullet-heading' for rebulleting behavior. 4044 4045All arguments are optional. 4046 4047First arg RELATIVE-DEPTH means to shift the depth of the entire 4048topic that amount. 4049 4050Several subsequent args are for internal recursive use by the function 4051itself: STARTING-DEPTH, STARTING-POINT, and INDEX. 4052 4053Finally, if optional SANS-OFFSPRING is non-nil then the offspring 4054are not shifted. (Shifting a topic outwards without shifting 4055its offspring is disallowed, since this would create a 4056\"containment discontinuity\", where the depth difference between 4057a topic and its immediate offspring is greater than one..)" 4058 4059 ;; XXX the recursion here is peculiar, and in general the routine may 4060 ;; need simplification with refactoring. 4061 4062 (if (and sans-offspring 4063 relative-depth 4064 (< relative-depth 0)) 4065 (error (concat "Attempt to shift topic outwards without offspring," 4066 " would cause containment discontinuity."))) 4067 4068 (let* ((relative-depth (or relative-depth 0)) 4069 (new-depth (allout-depth)) 4070 (starting-depth (or starting-depth new-depth)) 4071 (on-starting-call (null starting-point)) 4072 (index (or index 4073 ;; Leave index null on starting call, so rebullet-heading 4074 ;; calculates it at what might be new depth: 4075 (and (or (zerop relative-depth) 4076 (not on-starting-call)) 4077 (allout-sibling-index)))) 4078 (starting-index index) 4079 (moving-outwards (< 0 relative-depth)) 4080 (starting-point (or starting-point (point))) 4081 (local-point (point))) 4082 4083 ;; Sanity check for excessive promotion done only on starting call: 4084 (and on-starting-call 4085 moving-outwards 4086 (> 0 (+ starting-depth relative-depth)) 4087 (error "Attempt to shift topic out beyond level 1")) 4088 4089 (cond ((= starting-depth new-depth) 4090 ;; We're at depth to work on this one. 4091 4092 ;; When shifting out we work on the children before working on 4093 ;; the parent to avoid interim `allout-aberrant-container-p' 4094 ;; aberrancy, and vice-versa when shifting in: 4095 (if (>= relative-depth 0) 4096 (allout-rebullet-heading nil 4097 (+ starting-depth relative-depth) 4098 nil ;;; number 4099 index 4100 nil)) ;;; do-successors 4101 (when (not sans-offspring) 4102 ;; ... and work on subsequent ones which are at greater depth: 4103 (setq index 0) 4104 (allout-next-heading) 4105 (while (and (not (eobp)) 4106 (< starting-depth (allout-depth))) 4107 (setq index (1+ index)) 4108 (allout-rebullet-topic-grunt relative-depth 4109 (1+ starting-depth) 4110 starting-point 4111 index))) 4112 (when (< relative-depth 0) 4113 (save-excursion 4114 (goto-char local-point) 4115 (allout-rebullet-heading nil ;;; solicit 4116 (+ starting-depth relative-depth) 4117 nil ;;; number 4118 starting-index 4119 nil)))) ;;; do-successors 4120 4121 ((< starting-depth new-depth) 4122 ;; Rare case - subtopic more than one level deeper than parent. 4123 ;; Treat this one at an even deeper level: 4124 (allout-rebullet-topic-grunt relative-depth 4125 new-depth 4126 starting-point 4127 index 4128 sans-offspring))) 4129 4130 (if on-starting-call 4131 (progn 4132 ;; Rectify numbering of former siblings of the adjusted topic, 4133 ;; if topic has changed depth 4134 (if (or do-successors 4135 (and (not (zerop relative-depth)) 4136 (or (= allout-recent-depth starting-depth) 4137 (= allout-recent-depth (+ starting-depth 4138 relative-depth))))) 4139 (allout-rebullet-heading nil nil nil nil t)) 4140 ;; Now rectify numbering of new siblings of the adjusted topic, 4141 ;; if depth has been changed: 4142 (progn (goto-char starting-point) 4143 (if (not (zerop relative-depth)) 4144 (allout-rebullet-heading nil nil nil nil t))))) 4145 ) 4146 ) 4147;;;_ > allout-renumber-to-depth (&optional depth) 4148(defun allout-renumber-to-depth (&optional depth) 4149 "Renumber siblings at current depth. 4150 4151Affects superior topics if optional arg DEPTH is less than current depth. 4152 4153Returns final depth." 4154 4155 ;; Proceed by level, processing subsequent siblings on each, 4156 ;; ascending until we get shallower than the start depth: 4157 4158 (let ((ascender (allout-depth)) 4159 was-eobp) 4160 (while (and (not (eobp)) 4161 (allout-depth) 4162 (>= allout-recent-depth depth) 4163 (>= ascender depth)) 4164 ; Skip over all topics at 4165 ; lesser depths, which can not 4166 ; have been disturbed: 4167 (while (and (not (setq was-eobp (eobp))) 4168 (> allout-recent-depth ascender)) 4169 (allout-next-heading)) 4170 ; Prime ascender for ascension: 4171 (setq ascender (1- allout-recent-depth)) 4172 (if (>= allout-recent-depth depth) 4173 (allout-rebullet-heading nil ;;; solicit 4174 nil ;;; depth 4175 nil ;;; number-control 4176 nil ;;; index 4177 t)) ;;; do-successors 4178 (if was-eobp (goto-char (point-max))))) 4179 allout-recent-depth) 4180;;;_ > allout-number-siblings (&optional denumber) 4181(defun allout-number-siblings (&optional denumber) 4182 "Assign numbered topic prefix to this topic and its siblings. 4183 4184With universal argument, denumber - assign default bullet to this 4185topic and its siblings. 4186 4187With repeated universal argument (`^U^U'), solicit bullet for each 4188rebulleting each topic at this level." 4189 4190 (interactive "P") 4191 4192 (save-excursion 4193 (allout-back-to-current-heading) 4194 (allout-beginning-of-level) 4195 (let ((depth allout-recent-depth) 4196 (index (if (not denumber) 1)) 4197 (use-bullet (equal '(16) denumber)) 4198 (more t)) 4199 (while more 4200 (allout-rebullet-heading use-bullet ;;; solicit 4201 depth ;;; depth 4202 t ;;; number-control 4203 index ;;; index 4204 nil) ;;; do-successors 4205 (if index (setq index (1+ index))) 4206 (setq more (allout-next-sibling depth nil)))))) 4207;;;_ > allout-shift-in (arg) 4208(defun allout-shift-in (arg) 4209 "Increase depth of current heading and any items collapsed within it. 4210 4211With a negative argument, the item is shifted out using 4212`allout-shift-out', instead. 4213 4214With an argument greater than one, shift-in the item but not its 4215offspring, making the item into a sibling of its former children, 4216and a child of sibling that formerly preceeded it. 4217 4218You are not allowed to shift the first offspring of a topic 4219inwards, because that would yield a \"containment 4220discontinuity\", where the depth difference between a topic and 4221its immediate offspring is greater than one. The first topic in 4222the file can be adjusted to any positive depth, however." 4223 4224 (interactive "p") 4225 (if (< arg 0) 4226 (allout-shift-out (* arg -1)) 4227 ;; refuse to create a containment discontinuity: 4228 (save-excursion 4229 (allout-back-to-current-heading) 4230 (if (not (bobp)) 4231 (let* ((current-depth allout-recent-depth) 4232 (start-point (point)) 4233 (predecessor-depth (progn 4234 (forward-char -1) 4235 (allout-goto-prefix-doublechecked) 4236 (if (< (point) start-point) 4237 allout-recent-depth 4238 0)))) 4239 (if (and (> predecessor-depth 0) 4240 (> (1+ current-depth) 4241 (1+ predecessor-depth))) 4242 (error (concat "Disallowed shift deeper than" 4243 " containing topic's children.")) 4244 (allout-back-to-current-heading) 4245 (if (< allout-recent-depth (1+ current-depth)) 4246 (allout-show-children)))))) 4247 (let ((where (point))) 4248 (allout-rebullet-topic 1 (and (> arg 1) 'sans-offspring)) 4249 (run-hook-with-args 'allout-structure-shifted-hook arg where)))) 4250;;;_ > allout-shift-out (arg) 4251(defun allout-shift-out (arg) 4252 "Decrease depth of current heading and any topics collapsed within it. 4253This will make the item a sibling of its former container. 4254 4255With a negative argument, the item is shifted in using 4256`allout-shift-in', instead. 4257 4258With an argument greater than one, shift-out the item's offspring 4259but not the item itself, making the former children siblings of 4260the item. 4261 4262With an argument greater than 1, the item's offspring are shifted 4263out without shifting the item. This will make the immediate 4264subtopics into siblings of the item." 4265 (interactive "p") 4266 (if (< arg 0) 4267 (allout-shift-in (* arg -1)) 4268 ;; Get proper exposure in this area: 4269 (save-excursion (if (allout-ascend) 4270 (allout-show-children))) 4271 ;; Show collapsed children if there's a successor which will become 4272 ;; their sibling: 4273 (if (and (allout-current-topic-collapsed-p) 4274 (save-excursion (allout-next-sibling))) 4275 (allout-show-children)) 4276 (let ((where (and (allout-depth) allout-recent-prefix-beginning))) 4277 (save-excursion 4278 (if (> arg 1) 4279 ;; Shift the offspring but not the topic: 4280 (let ((children-chart (allout-chart-subtree 1))) 4281 (if (listp (car children-chart)) 4282 ;; whoops: 4283 (setq children-chart (allout-flatten children-chart))) 4284 (save-excursion 4285 (dolist (child-point children-chart) 4286 (goto-char child-point) 4287 (allout-shift-out 1)))) 4288 (allout-rebullet-topic (* arg -1)))) 4289 (run-hook-with-args 'allout-structure-shifted-hook (* arg -1) where)))) 4290;;;_ : Surgery (kill-ring) functions with special provisions for outlines: 4291;;;_ > allout-kill-line (&optional arg) 4292(defun allout-kill-line (&optional arg) 4293 "Kill line, adjusting subsequent lines suitably for outline mode." 4294 4295 (interactive "*P") 4296 4297 (if (or (not (allout-mode-p)) 4298 (not (bolp)) 4299 (not (looking-at allout-regexp))) 4300 ;; Just do a regular kill: 4301 (kill-line arg) 4302 ;; Ah, have to watch out for adjustments: 4303 (let* ((beg (point)) 4304 end 4305 (beg-hidden (allout-hidden-p)) 4306 (end-hidden (save-excursion (allout-end-of-current-line) 4307 (setq end (point)) 4308 (allout-hidden-p))) 4309 (depth (allout-depth))) 4310 4311 (allout-annotate-hidden beg end) 4312 (if (and (not beg-hidden) (not end-hidden)) 4313 (allout-unprotected (kill-line arg)) 4314 (kill-line arg)) 4315 (allout-deannotate-hidden beg end) 4316 4317 (if allout-numbered-bullet 4318 (save-excursion ; Renumber subsequent topics if needed: 4319 (if (not (looking-at allout-regexp)) 4320 (allout-next-heading)) 4321 (allout-renumber-to-depth depth))) 4322 (run-hook-with-args 'allout-structure-deleted-hook depth (point))))) 4323;;;_ > allout-copy-line-as-kill () 4324(defun allout-copy-line-as-kill () 4325 "Like allout-kill-topic, but save to kill ring instead of deleting." 4326 (interactive) 4327 (let ((buffer-read-only t)) 4328 (condition-case nil 4329 (allout-kill-line) 4330 (buffer-read-only nil)))) 4331;;;_ > allout-kill-topic () 4332(defun allout-kill-topic () 4333 "Kill topic together with subtopics. 4334 4335Trailing whitespace is killed with a topic if that whitespace: 4336 4337 - would separate the topic from a subsequent sibling 4338 - would separate the topic from the end of buffer 4339 - would not be added to whitespace already separating the topic from the 4340 previous one. 4341 4342Topic exposure is marked with text-properties, to be used by 4343allout-yank-processing for exposure recovery." 4344 4345 (interactive) 4346 (let* ((inhibit-field-text-motion t) 4347 (beg (prog1 (allout-back-to-current-heading) (beginning-of-line))) 4348 end 4349 (depth allout-recent-depth)) 4350 (allout-end-of-current-subtree) 4351 (if (and (/= (current-column) 0) (not (eobp))) 4352 (forward-char 1)) 4353 (if (not (eobp)) 4354 (if (and (looking-at "\n") 4355 (or (save-excursion 4356 (or (not (allout-next-heading)) 4357 (= depth allout-recent-depth))) 4358 (and (> (- beg (point-min)) 3) 4359 (string= (buffer-substring (- beg 2) beg) "\n\n")))) 4360 (forward-char 1))) 4361 4362 (allout-annotate-hidden beg (setq end (point))) 4363 (unwind-protect 4364 (allout-unprotected (kill-region beg end)) 4365 (if buffer-read-only 4366 ;; eg, during copy-as-kill. 4367 (allout-deannotate-hidden beg end))) 4368 4369 (save-excursion 4370 (allout-renumber-to-depth depth)) 4371 (run-hook-with-args 'allout-structure-deleted-hook depth (point)))) 4372;;;_ > allout-copy-topic-as-kill () 4373(defun allout-copy-topic-as-kill () 4374 "Like allout-kill-topic, but save to kill ring instead of deleting." 4375 (interactive) 4376 (let ((buffer-read-only t)) 4377 (condition-case nil 4378 (allout-kill-topic) 4379 (buffer-read-only (message "Topic copied..."))))) 4380;;;_ > allout-annotate-hidden (begin end) 4381(defun allout-annotate-hidden (begin end) 4382 "Qualify text with properties to indicate exposure status." 4383 4384 (let ((was-modified (buffer-modified-p)) 4385 (buffer-read-only nil)) 4386 (allout-deannotate-hidden begin end) 4387 (save-excursion 4388 (goto-char begin) 4389 (let (done next prev overlay) 4390 (while (not done) 4391 ;; at or advance to start of next hidden region: 4392 (if (not (allout-hidden-p)) 4393 (setq next 4394 (max (1+ (point)) 4395 (next-single-char-property-change (point) 4396 'invisible 4397 nil end)))) 4398 (if (or (not next) (eq prev next)) 4399 ;; still not at start of hidden area - must not be any left. 4400 (setq done t) 4401 (goto-char next) 4402 (setq prev next) 4403 (if (not (allout-hidden-p)) 4404 ;; still not at start of hidden area. 4405 (setq done t) 4406 (setq overlay (allout-get-invisibility-overlay)) 4407 (setq next (overlay-end overlay) 4408 prev next) 4409 ;; advance to end of this hidden area: 4410 (when next 4411 (goto-char next) 4412 (allout-unprotected 4413 (let ((buffer-undo-list t)) 4414 (put-text-property (overlay-start overlay) next 4415 'allout-was-hidden t))))))))) 4416 (set-buffer-modified-p was-modified))) 4417;;;_ > allout-deannotate-hidden (begin end) 4418(defun allout-deannotate-hidden (begin end) 4419 "Remove allout hidden-text annotation between BEGIN and END." 4420 4421 (allout-unprotected 4422 (let ((inhibit-read-only t) 4423 (buffer-undo-list t)) 4424 ;(remove-text-properties begin end '(allout-was-hidden t)) 4425 ))) 4426;;;_ > allout-hide-by-annotation (begin end) 4427(defun allout-hide-by-annotation (begin end) 4428 "Translate text properties indicating exposure status into actual exposure." 4429 (save-excursion 4430 (goto-char begin) 4431 (let ((was-modified (buffer-modified-p)) 4432 done next prev) 4433 (while (not done) 4434 ;; at or advance to start of next annotation: 4435 (if (not (get-text-property (point) 'allout-was-hidden)) 4436 (setq next (next-single-char-property-change (point) 4437 'allout-was-hidden 4438 nil end))) 4439 (if (or (not next) (eq prev next)) 4440 ;; no more or not advancing - must not be any left. 4441 (setq done t) 4442 (goto-char next) 4443 (setq prev next) 4444 (if (not (get-text-property (point) 'allout-was-hidden)) 4445 ;; still not at start of annotation. 4446 (setq done t) 4447 ;; advance to just after end of this annotation: 4448 (setq next (next-single-char-property-change (point) 4449 'allout-was-hidden 4450 nil end)) 4451 (overlay-put (make-overlay prev next) 4452 'category 'allout-exposure-category) 4453 (allout-deannotate-hidden prev next) 4454 (setq prev next) 4455 (if next (goto-char next))))) 4456 (set-buffer-modified-p was-modified)))) 4457;;;_ > allout-yank-processing () 4458(defun allout-yank-processing (&optional arg) 4459 4460 "Incidental allout-specific business to be done just after text yanks. 4461 4462Does depth adjustment of yanked topics, when: 4463 44641 the stuff being yanked starts with a valid outline header prefix, and 44652 it is being yanked at the end of a line which consists of only a valid 4466 topic prefix. 4467 4468Also, adjusts numbering of subsequent siblings when appropriate. 4469 4470Depth adjustment alters the depth of all the topics being yanked 4471the amount it takes to make the first topic have the depth of the 4472header into which it's being yanked. 4473 4474The point is left in front of yanked, adjusted topics, rather than 4475at the end (and vice-versa with the mark). Non-adjusted yanks, 4476however, are left exactly like normal, non-allout-specific yanks." 4477 4478 (interactive "*P") 4479 ; Get to beginning, leaving 4480 ; region around subject: 4481 (if (< (allout-mark-marker t) (point)) 4482 (exchange-point-and-mark)) 4483 (let* ((subj-beg (point)) 4484 (into-bol (bolp)) 4485 (subj-end (allout-mark-marker t)) 4486 ;; 'resituate' if yanking an entire topic into topic header: 4487 (resituate (and (let ((allout-inhibit-aberrance-doublecheck t)) 4488 (allout-e-o-prefix-p)) 4489 (looking-at allout-regexp) 4490 (allout-prefix-data))) 4491 ;; `rectify-numbering' if resituating (where several topics may 4492 ;; be resituating) or yanking a topic into a topic slot (bol): 4493 (rectify-numbering (or resituate 4494 (and into-bol (looking-at allout-regexp))))) 4495 (if resituate 4496 ;; Yanking a topic into the start of a topic - reconcile to fit: 4497 (let* ((inhibit-field-text-motion t) 4498 (prefix-len (if (not (match-end 1)) 4499 1 4500 (- (match-end 1) subj-beg))) 4501 (subj-depth allout-recent-depth) 4502 (prefix-bullet (allout-recent-bullet)) 4503 (adjust-to-depth 4504 ;; Nil if adjustment unnecessary, otherwise depth to which 4505 ;; adjustment should be made: 4506 (save-excursion 4507 (and (goto-char subj-end) 4508 (eolp) 4509 (goto-char subj-beg) 4510 (and (looking-at allout-regexp) 4511 (progn 4512 (beginning-of-line) 4513 (not (= (point) subj-beg))) 4514 (looking-at allout-regexp) 4515 (allout-prefix-data)) 4516 allout-recent-depth))) 4517 (more t)) 4518 (setq rectify-numbering allout-numbered-bullet) 4519 (if adjust-to-depth 4520 ; Do the adjustment: 4521 (progn 4522 (save-restriction 4523 (narrow-to-region subj-beg subj-end) 4524 ; Trim off excessive blank 4525 ; line at end, if any: 4526 (goto-char (point-max)) 4527 (if (looking-at "^$") 4528 (allout-unprotected (delete-char -1))) 4529 ; Work backwards, with each 4530 ; shallowest level, 4531 ; successively excluding the 4532 ; last processed topic from 4533 ; the narrow region: 4534 (while more 4535 (allout-back-to-current-heading) 4536 ; go as high as we can in each bunch: 4537 (while (allout-ascend t)) 4538 (save-excursion 4539 (allout-unprotected 4540 (allout-rebullet-topic-grunt (- adjust-to-depth 4541 subj-depth))) 4542 (allout-depth)) 4543 (if (setq more (not (bobp))) 4544 (progn (widen) 4545 (forward-char -1) 4546 (narrow-to-region subj-beg (point)))))) 4547 ;; Preserve new bullet if it's a distinctive one, otherwise 4548 ;; use old one: 4549 (if (string-match (regexp-quote prefix-bullet) 4550 allout-distinctive-bullets-string) 4551 ; Delete from bullet of old to 4552 ; before bullet of new: 4553 (progn 4554 (beginning-of-line) 4555 (allout-unprotected 4556 (delete-region (point) subj-beg)) 4557 (set-marker (allout-mark-marker t) subj-end) 4558 (goto-char subj-beg) 4559 (allout-end-of-prefix)) 4560 ; Delete base subj prefix, 4561 ; leaving old one: 4562 (allout-unprotected 4563 (progn 4564 (delete-region (point) (+ (point) 4565 prefix-len 4566 (- adjust-to-depth 4567 subj-depth))) 4568 ; and delete residual subj 4569 ; prefix digits and space: 4570 (while (looking-at "[0-9]") (delete-char 1)) 4571 (if (looking-at " ") (delete-char 1)))))) 4572 (exchange-point-and-mark)))) 4573 (if rectify-numbering 4574 (progn 4575 (save-excursion 4576 ; Give some preliminary feedback: 4577 (message "... reconciling numbers") 4578 ; ... and renumber, in case necessary: 4579 (goto-char subj-beg) 4580 (if (allout-goto-prefix-doublechecked) 4581 (allout-unprotected 4582 (allout-rebullet-heading nil ;;; solicit 4583 (allout-depth) ;;; depth 4584 nil ;;; number-control 4585 nil ;;; index 4586 t))) 4587 (message "")))) 4588 (if (or into-bol resituate) 4589 (allout-hide-by-annotation (point) (allout-mark-marker t)) 4590 (allout-deannotate-hidden (allout-mark-marker t) (point))) 4591 (if (not resituate) 4592 (exchange-point-and-mark)) 4593 (run-hook-with-args 'allout-structure-added-hook subj-beg subj-end))) 4594;;;_ > allout-yank (&optional arg) 4595(defun allout-yank (&optional arg) 4596 "`allout-mode' yank, with depth and numbering adjustment of yanked topics. 4597 4598Non-topic yanks work no differently than normal yanks. 4599 4600If a topic is being yanked into a bare topic prefix, the depth of the 4601yanked topic is adjusted to the depth of the topic prefix. 4602 4603 1 we're yanking in an `allout-mode' buffer 4604 2 the stuff being yanked starts with a valid outline header prefix, and 4605 3 it is being yanked at the end of a line which consists of only a valid 4606 topic prefix. 4607 4608If these conditions hold then the depth of the yanked topics are all 4609adjusted the amount it takes to make the first one at the depth of the 4610header into which it's being yanked. 4611 4612The point is left in front of yanked, adjusted topics, rather than 4613at the end (and vice-versa with the mark). Non-adjusted yanks, 4614however, (ones that don't qualify for adjustment) are handled 4615exactly like normal yanks. 4616 4617Numbering of yanked topics, and the successive siblings at the depth 4618into which they're being yanked, is adjusted. 4619 4620`allout-yank-pop' works with `allout-yank' just like normal `yank-pop' 4621works with normal `yank' in non-outline buffers." 4622 4623 (interactive "*P") 4624 (setq this-command 'yank) 4625 (allout-unprotected 4626 (yank arg)) 4627 (if (allout-mode-p) 4628 (allout-yank-processing))) 4629;;;_ > allout-yank-pop (&optional arg) 4630(defun allout-yank-pop (&optional arg) 4631 "Yank-pop like `allout-yank' when popping to bare outline prefixes. 4632 4633Adapts level of popped topics to level of fresh prefix. 4634 4635Note - prefix changes to distinctive bullets will stick, if followed 4636by pops to non-distinctive yanks. Bug..." 4637 4638 (interactive "*p") 4639 (setq this-command 'yank) 4640 (yank-pop arg) 4641 (if (allout-mode-p) 4642 (allout-yank-processing))) 4643 4644;;;_ - Specialty bullet functions 4645;;;_ : File Cross references 4646;;;_ > allout-resolve-xref () 4647(defun allout-resolve-xref () 4648 "Pop to file associated with current heading, if it has an xref bullet. 4649 4650\(Works according to setting of `allout-file-xref-bullet')." 4651 (interactive) 4652 (if (not allout-file-xref-bullet) 4653 (error 4654 "Outline cross references disabled - no `allout-file-xref-bullet'") 4655 (if (not (string= (allout-current-bullet) allout-file-xref-bullet)) 4656 (error "Current heading lacks cross-reference bullet `%s'" 4657 allout-file-xref-bullet) 4658 (let ((inhibit-field-text-motion t) 4659 file-name) 4660 (save-excursion 4661 (let* ((text-start allout-recent-prefix-end) 4662 (heading-end (progn (end-of-line) (point)))) 4663 (goto-char text-start) 4664 (setq file-name 4665 (if (re-search-forward "\\s-\\(\\S-*\\)" heading-end t) 4666 (buffer-substring (match-beginning 1) (match-end 1)))))) 4667 (setq file-name (expand-file-name file-name)) 4668 (if (or (file-exists-p file-name) 4669 (if (file-writable-p file-name) 4670 (y-or-n-p (format "%s not there, create one? " 4671 file-name)) 4672 (error "%s not found and can't be created" file-name))) 4673 (condition-case failure 4674 (find-file-other-window file-name) 4675 (error failure)) 4676 (error "%s not found" file-name)) 4677 ) 4678 ) 4679 ) 4680 ) 4681 4682;;;_ #6 Exposure Control 4683 4684;;;_ - Fundamental 4685;;;_ > allout-flag-region (from to flag) 4686(defun allout-flag-region (from to flag) 4687 "Conceal text between FROM and TO if FLAG is non-nil, else reveal it. 4688 4689Exposure-change hook `allout-exposure-change-hook' is run with the same 4690arguments as this function, after the exposure changes are made. (The old 4691`allout-view-change-hook' is being deprecated, and eventually will not be 4692invoked.)" 4693 4694 ;; We use outline invisibility spec. 4695 (remove-overlays from to 'category 'allout-exposure-category) 4696 (when flag 4697 (let ((o (make-overlay from to))) 4698 (overlay-put o 'category 'allout-exposure-category) 4699 (when (featurep 'xemacs) 4700 (let ((props (symbol-plist 'allout-exposure-category))) 4701 (while props 4702 (overlay-put o (pop props) (pop props))))))) 4703 (run-hooks 'allout-view-change-hook) 4704 (run-hook-with-args 'allout-exposure-change-hook from to flag)) 4705;;;_ > allout-flag-current-subtree (flag) 4706(defun allout-flag-current-subtree (flag) 4707 "Conceal currently-visible topic's subtree if FLAG non-nil, else reveal it." 4708 4709 (save-excursion 4710 (allout-back-to-current-heading) 4711 (let ((inhibit-field-text-motion t)) 4712 (end-of-line)) 4713 (allout-flag-region (point) 4714 ;; Exposing must not leave trailing blanks hidden, 4715 ;; but can leave them exposed when hiding, so we 4716 ;; can use flag's inverse as the 4717 ;; include-trailing-blank cue: 4718 (allout-end-of-current-subtree (not flag)) 4719 flag))) 4720 4721;;;_ - Topic-specific 4722;;;_ > allout-show-entry () 4723(defun allout-show-entry () 4724 "Like `allout-show-current-entry', but reveals entries in hidden topics. 4725 4726This is a way to give restricted peek at a concealed locality without the 4727expense of exposing its context, but can leave the outline with aberrant 4728exposure. `allout-show-offshoot' should be used after the peek to rectify 4729the exposure." 4730 4731 (interactive) 4732 (save-excursion 4733 (let (beg end) 4734 (allout-goto-prefix-doublechecked) 4735 (setq beg (if (allout-hidden-p) (1- (point)) (point))) 4736 (setq end (allout-pre-next-prefix)) 4737 (allout-flag-region beg end nil) 4738 (list beg end)))) 4739;;;_ > allout-show-children (&optional level strict) 4740(defun allout-show-children (&optional level strict) 4741 4742 "If point is visible, show all direct subheadings of this heading. 4743 4744Otherwise, do `allout-show-to-offshoot', and then show subheadings. 4745 4746Optional LEVEL specifies how many levels below the current level 4747should be shown, or all levels if t. Default is 1. 4748 4749Optional STRICT means don't resort to -show-to-offshoot, no matter 4750what. This is basically so -show-to-offshoot, which is called by 4751this function, can employ the pure offspring-revealing capabilities of 4752it. 4753 4754Returns point at end of subtree that was opened, if any. (May get a 4755point of non-opened subtree?)" 4756 4757 (interactive "p") 4758 (let ((start-point (point))) 4759 (if (and (not strict) 4760 (allout-hidden-p)) 4761 4762 (progn (allout-show-to-offshoot) ; Point's concealed, open to 4763 ; expose it. 4764 ;; Then recurse, but with "strict" set so we don't 4765 ;; infinite regress: 4766 (allout-show-children level t)) 4767 4768 (save-excursion 4769 (allout-beginning-of-current-line) 4770 (save-restriction 4771 (let* (depth 4772 ;; translate the level spec for this routine to the ones 4773 ;; used by -chart-subtree and -chart-to-reveal: 4774 (chart-level (cond ((not level) 1) 4775 ((eq level t) nil) 4776 (t level))) 4777 (chart (allout-chart-subtree chart-level)) 4778 (to-reveal (or (allout-chart-to-reveal chart chart-level) 4779 ;; interactive, show discontinuous children: 4780 (and chart 4781 (interactive-p) 4782 (save-excursion 4783 (allout-back-to-current-heading) 4784 (setq depth (allout-current-depth)) 4785 (and (allout-next-heading) 4786 (> allout-recent-depth 4787 (1+ depth)))) 4788 (message 4789 "Discontinuous offspring; use `%s %s'%s." 4790 (substitute-command-keys 4791 "\\[universal-argument]") 4792 (substitute-command-keys 4793 "\\[allout-shift-out]") 4794 " to elevate them.") 4795 (allout-chart-to-reveal 4796 chart (- allout-recent-depth depth)))))) 4797 (goto-char start-point) 4798 (when (and strict (allout-hidden-p)) 4799 ;; Concealed root would already have been taken care of, 4800 ;; unless strict was set. 4801 (allout-flag-region (point) (allout-snug-back) nil) 4802 (when allout-show-bodies 4803 (goto-char (car to-reveal)) 4804 (allout-show-current-entry))) 4805 (while to-reveal 4806 (goto-char (car to-reveal)) 4807 (allout-flag-region (save-excursion (allout-snug-back) (point)) 4808 (progn (search-forward "\n" nil t) 4809 (1- (point))) 4810 nil) 4811 (when allout-show-bodies 4812 (goto-char (car to-reveal)) 4813 (allout-show-current-entry)) 4814 (setq to-reveal (cdr to-reveal))))))) 4815 ;; Compensate for `save-excursion's maintenance of point 4816 ;; within invisible text: 4817 (goto-char start-point))) 4818;;;_ > allout-show-to-offshoot () 4819(defun allout-show-to-offshoot () 4820 "Like `allout-show-entry', but reveals all concealed ancestors, as well. 4821 4822Useful for coherently exposing to a random point in a hidden region." 4823 (interactive) 4824 (save-excursion 4825 (let ((inhibit-field-text-motion t) 4826 (orig-pt (point)) 4827 (orig-pref (allout-goto-prefix-doublechecked)) 4828 (last-at (point)) 4829 (bag-it 0)) 4830 (while (or (> bag-it 1) (allout-hidden-p)) 4831 (while (allout-hidden-p) 4832 (move-beginning-of-line 1) 4833 (if (allout-hidden-p) (forward-char -1))) 4834 (if (= last-at (setq last-at (point))) 4835 ;; Oops, we're not making any progress! Show the current topic 4836 ;; completely, and try one more time here, if we haven't already. 4837 (progn (beginning-of-line) 4838 (allout-show-current-subtree) 4839 (goto-char orig-pt) 4840 (setq bag-it (1+ bag-it)) 4841 (if (> bag-it 1) 4842 (error "allout-show-to-offshoot: %s" 4843 "Stumped by aberrant nesting."))) 4844 (if (> bag-it 0) (setq bag-it 0)) 4845 (allout-show-children) 4846 (goto-char orig-pref))) 4847 (goto-char orig-pt))) 4848 (if (allout-hidden-p) 4849 (allout-show-entry))) 4850;;;_ > allout-hide-current-entry () 4851(defun allout-hide-current-entry () 4852 "Hide the body directly following this heading." 4853 (interactive) 4854 (allout-back-to-current-heading) 4855 (save-excursion 4856 (let ((inhibit-field-text-motion t)) 4857 (end-of-line)) 4858 (allout-flag-region (point) 4859 (progn (allout-end-of-entry) (point)) 4860 t))) 4861;;;_ > allout-show-current-entry (&optional arg) 4862(defun allout-show-current-entry (&optional arg) 4863 "Show body following current heading, or hide entry with universal argument." 4864 4865 (interactive "P") 4866 (if arg 4867 (allout-hide-current-entry) 4868 (save-excursion (allout-show-to-offshoot)) 4869 (save-excursion 4870 (allout-flag-region (point) 4871 (progn (allout-end-of-entry t) (point)) 4872 nil) 4873 ))) 4874;;;_ > allout-show-current-subtree (&optional arg) 4875(defun allout-show-current-subtree (&optional arg) 4876 "Show everything within the current topic. With a repeat-count, 4877expose this topic and its siblings." 4878 (interactive "P") 4879 (save-excursion 4880 (if (<= (allout-current-depth) 0) 4881 ;; Outside any topics - try to get to the first: 4882 (if (not (allout-next-heading)) 4883 (error "No topics") 4884 ;; got to first, outermost topic - set to expose it and siblings: 4885 (message "Above outermost topic - exposing all.") 4886 (allout-flag-region (point-min)(point-max) nil)) 4887 (allout-beginning-of-current-line) 4888 (if (not arg) 4889 (allout-flag-current-subtree nil) 4890 (allout-beginning-of-level) 4891 (allout-expose-topic '(* :)))))) 4892;;;_ > allout-current-topic-collapsed-p (&optional include-single-liners) 4893(defun allout-current-topic-collapsed-p (&optional include-single-liners) 4894 "True if the currently visible containing topic is already collapsed. 4895 4896Single line topics intrinsically can be considered as being both 4897collapsed and uncollapsed. If optional INCLUDE-SINGLE-LINERS is 4898true, then single-line topics are considered to be collapsed. By 4899default, they are treated as being uncollapsed." 4900 (save-excursion 4901 (and 4902 ;; Is the topic all on one line (allowing for trailing blank line)? 4903 (>= (progn (allout-back-to-current-heading) 4904 (move-end-of-line 1) 4905 (point)) 4906 (allout-end-of-current-subtree (not (looking-at "\n\n")))) 4907 4908 (or include-single-liners 4909 (progn (backward-char 1) (allout-hidden-p)))))) 4910;;;_ > allout-hide-current-subtree (&optional just-close) 4911(defun allout-hide-current-subtree (&optional just-close) 4912 "Close the current topic, or containing topic if this one is already closed. 4913 4914If this topic is closed and it's a top level topic, close this topic 4915and its siblings. 4916 4917If optional arg JUST-CLOSE is non-nil, do not close the parent or 4918siblings, even if the target topic is already closed." 4919 4920 (interactive) 4921 (let* ((from (point)) 4922 (sibs-msg "Top-level topic already closed - closing siblings...") 4923 (current-exposed (not (allout-current-topic-collapsed-p t)))) 4924 (cond (current-exposed (allout-flag-current-subtree t)) 4925 (just-close nil) 4926 ((allout-ascend) (allout-hide-current-subtree)) 4927 (t (goto-char 0) 4928 (message sibs-msg) 4929 (allout-goto-prefix-doublechecked) 4930 (allout-expose-topic '(0 :)) 4931 (message (concat sibs-msg " Done.")))) 4932 (goto-char from))) 4933;;;_ > allout-show-current-branches () 4934(defun allout-show-current-branches () 4935 "Show all subheadings of this heading, but not their bodies." 4936 (interactive) 4937 (let ((inhibit-field-text-motion t)) 4938 (beginning-of-line)) 4939 (allout-show-children t)) 4940;;;_ > allout-hide-current-leaves () 4941(defun allout-hide-current-leaves () 4942 "Hide the bodies of the current topic and all its offspring." 4943 (interactive) 4944 (allout-back-to-current-heading) 4945 (allout-hide-region-body (point) (progn (allout-end-of-current-subtree) 4946 (point)))) 4947 4948;;;_ - Region and beyond 4949;;;_ > allout-show-all () 4950(defun allout-show-all () 4951 "Show all of the text in the buffer." 4952 (interactive) 4953 (message "Exposing entire buffer...") 4954 (allout-flag-region (point-min) (point-max) nil) 4955 (message "Exposing entire buffer... Done.")) 4956;;;_ > allout-hide-bodies () 4957(defun allout-hide-bodies () 4958 "Hide all of buffer except headings." 4959 (interactive) 4960 (allout-hide-region-body (point-min) (point-max))) 4961;;;_ > allout-hide-region-body (start end) 4962(defun allout-hide-region-body (start end) 4963 "Hide all body lines in the region, but not headings." 4964 (save-excursion 4965 (save-restriction 4966 (narrow-to-region start end) 4967 (goto-char (point-min)) 4968 (let ((inhibit-field-text-motion t)) 4969 (while (not (eobp)) 4970 (end-of-line) 4971 (allout-flag-region (point) (allout-end-of-entry) t) 4972 (if (not (eobp)) 4973 (forward-char 4974 (if (looking-at "\n\n") 4975 2 1)))))))) 4976 4977;;;_ > allout-expose-topic (spec) 4978(defun allout-expose-topic (spec) 4979 "Apply exposure specs to successive outline topic items. 4980 4981Use the more convenient frontend, `allout-new-exposure', if you don't 4982need evaluation of the arguments, or even better, the `allout-layout' 4983variable-keyed mode-activation/auto-exposure feature of allout outline 4984mode. See the respective documentation strings for more details. 4985 4986Cursor is left at start position. 4987 4988SPEC is either a number or a list. 4989 4990Successive specs on a list are applied to successive sibling topics. 4991 4992A simple spec (either a number, one of a few symbols, or the null 4993list) dictates the exposure for the corresponding topic. 4994 4995Non-null lists recursively designate exposure specs for respective 4996subtopics of the current topic. 4997 4998The `:' repeat spec is used to specify exposure for any number of 4999successive siblings, up to the trailing ones for which there are 5000explicit specs following the `:'. 5001 5002Simple (numeric and null-list) specs are interpreted as follows: 5003 5004 Numbers indicate the relative depth to open the corresponding topic. 5005 - negative numbers force the topic to be closed before opening to the 5006 absolute value of the number, so all siblings are open only to 5007 that level. 5008 - positive numbers open to the relative depth indicated by the 5009 number, but do not force already opened subtopics to be closed. 5010 - 0 means to close topic - hide all offspring. 5011 : - `repeat' 5012 apply prior element to all siblings at current level, *up to* 5013 those siblings that would be covered by specs following the `:' 5014 on the list. Ie, apply to all topics at level but the last 5015 ones. (Only first of multiple colons at same level is 5016 respected - subsequent ones are discarded.) 5017 * - completely opens the topic, including bodies. 5018 + - shows all the sub headers, but not the bodies 5019 - - exposes the body of the corresponding topic. 5020 5021Examples: 5022\(allout-expose-topic '(-1 : 0)) 5023 Close this and all following topics at current level, exposing 5024 only their immediate children, but close down the last topic 5025 at this current level completely. 5026\(allout-expose-topic '(-1 () : 1 0)) 5027 Close current topic so only the immediate subtopics are shown; 5028 show the children in the second to last topic, and completely 5029 close the last one. 5030\(allout-expose-topic '(-2 : -1 *)) 5031 Expose children and grandchildren of all topics at current 5032 level except the last two; expose children of the second to 5033 last and completely open the last one." 5034 5035 (interactive "xExposure spec: ") 5036 (if (not (listp spec)) 5037 nil 5038 (let ((depth (allout-depth)) 5039 (max-pos 0) 5040 prev-elem curr-elem 5041 stay) 5042 (while spec 5043 (setq prev-elem curr-elem 5044 curr-elem (car spec) 5045 spec (cdr spec)) 5046 (cond ; Do current element: 5047 ((null curr-elem) nil) 5048 ((symbolp curr-elem) 5049 (cond ((eq curr-elem '*) (allout-show-current-subtree) 5050 (if (> allout-recent-end-of-subtree max-pos) 5051 (setq max-pos allout-recent-end-of-subtree))) 5052 ((eq curr-elem '+) 5053 (if (not (allout-hidden-p)) 5054 (save-excursion (allout-hide-current-subtree t))) 5055 (allout-show-current-branches) 5056 (if (> allout-recent-end-of-subtree max-pos) 5057 (setq max-pos allout-recent-end-of-subtree))) 5058 ((eq curr-elem '-) (allout-show-current-entry)) 5059 ((eq curr-elem ':) 5060 (setq stay t) 5061 ;; Expand the `repeat' spec to an explicit version, 5062 ;; w.r.t. remaining siblings: 5063 (let ((residue ; = # of sibs not covered by remaining spec 5064 ;; Dang - could be nice to make use of the chart, sigh: 5065 (- (length (allout-chart-siblings)) 5066 (length spec)))) 5067 (if (< 0 residue) 5068 ;; Some residue - cover it with prev-elem: 5069 (setq spec (append (make-list residue prev-elem) 5070 spec))))))) 5071 ((numberp curr-elem) 5072 (if (and (>= 0 curr-elem) (not (allout-hidden-p))) 5073 (save-excursion (allout-hide-current-subtree t) 5074 (if (> 0 curr-elem) 5075 nil 5076 (if (> allout-recent-end-of-subtree max-pos) 5077 (setq max-pos 5078 allout-recent-end-of-subtree))))) 5079 (if (> (abs curr-elem) 0) 5080 (progn (allout-show-children (abs curr-elem)) 5081 (if (> allout-recent-end-of-subtree max-pos) 5082 (setq max-pos allout-recent-end-of-subtree))))) 5083 ((listp curr-elem) 5084 (if (allout-descend-to-depth (1+ depth)) 5085 (let ((got (allout-expose-topic curr-elem))) 5086 (if (and got (> got max-pos)) (setq max-pos got)))))) 5087 (cond (stay (setq stay nil)) 5088 ((listp (car spec)) nil) 5089 ((> max-pos (point)) 5090 ;; Capitalize on max-pos state to get us nearer next sibling: 5091 (progn (goto-char (min (point-max) max-pos)) 5092 (allout-next-heading))) 5093 ((allout-next-sibling depth)))) 5094 max-pos))) 5095;;;_ > allout-old-expose-topic (spec &rest followers) 5096(defun allout-old-expose-topic (spec &rest followers) 5097 5098 "Deprecated. Use `allout-expose-topic' (with different schema 5099format) instead. 5100 5101Dictate wholesale exposure scheme for current topic, according to SPEC. 5102 5103SPEC is either a number or a list. Optional successive args 5104dictate exposure for subsequent siblings of current topic. 5105 5106A simple spec (either a number, a special symbol, or the null list) 5107dictates the overall exposure for a topic. Non null lists are 5108composite specs whose first element dictates the overall exposure for 5109a topic, with the subsequent elements in the list interpreted as specs 5110that dictate the exposure for the successive offspring of the topic. 5111 5112Simple (numeric and null-list) specs are interpreted as follows: 5113 5114 - Numbers indicate the relative depth to open the corresponding topic: 5115 - negative numbers force the topic to be close before opening to the 5116 absolute value of the number. 5117 - positive numbers just open to the relative depth indicated by the number. 5118 - 0 just closes 5119 - `*' completely opens the topic, including bodies. 5120 - `+' shows all the sub headers, but not the bodies 5121 - `-' exposes the body and immediate offspring of the corresponding topic. 5122 5123If the spec is a list, the first element must be a number, which 5124dictates the exposure depth of the topic as a whole. Subsequent 5125elements of the list are nested SPECs, dictating the specific exposure 5126for the corresponding offspring of the topic. 5127 5128Optional FOLLOWERS arguments dictate exposure for succeeding siblings." 5129 5130 (interactive "xExposure spec: ") 5131 (let ((inhibit-field-text-motion t) 5132 (depth (allout-current-depth)) 5133 max-pos) 5134 (cond ((null spec) nil) 5135 ((symbolp spec) 5136 (if (eq spec '*) (allout-show-current-subtree)) 5137 (if (eq spec '+) (allout-show-current-branches)) 5138 (if (eq spec '-) (allout-show-current-entry))) 5139 ((numberp spec) 5140 (if (>= 0 spec) 5141 (save-excursion (allout-hide-current-subtree t) 5142 (end-of-line) 5143 (if (or (not max-pos) 5144 (> (point) max-pos)) 5145 (setq max-pos (point))) 5146 (if (> 0 spec) 5147 (setq spec (* -1 spec))))) 5148 (if (> spec 0) 5149 (allout-show-children spec))) 5150 ((listp spec) 5151 ;(let ((got (allout-old-expose-topic (car spec)))) 5152 ; (if (and got (or (not max-pos) (> got max-pos))) 5153 ; (setq max-pos got))) 5154 (let ((new-depth (+ (allout-current-depth) 1)) 5155 got) 5156 (setq max-pos (allout-old-expose-topic (car spec))) 5157 (setq spec (cdr spec)) 5158 (if (and spec 5159 (allout-descend-to-depth new-depth) 5160 (not (allout-hidden-p))) 5161 (progn (setq got (apply 'allout-old-expose-topic spec)) 5162 (if (and got (or (not max-pos) (> got max-pos))) 5163 (setq max-pos got))))))) 5164 (while (and followers 5165 (progn (if (and max-pos (< (point) max-pos)) 5166 (progn (goto-char max-pos) 5167 (setq max-pos nil))) 5168 (end-of-line) 5169 (allout-next-sibling depth))) 5170 (allout-old-expose-topic (car followers)) 5171 (setq followers (cdr followers))) 5172 max-pos)) 5173;;;_ > allout-new-exposure '() 5174(defmacro allout-new-exposure (&rest spec) 5175 "Literal frontend for `allout-expose-topic', doesn't evaluate arguments. 5176Some arguments that would need to be quoted in `allout-expose-topic' 5177need not be quoted in `allout-new-exposure'. 5178 5179Cursor is left at start position. 5180 5181Use this instead of obsolete `allout-exposure'. 5182 5183Examples: 5184\(allout-new-exposure (-1 () () () 1) 0) 5185 Close current topic at current level so only the immediate 5186 subtopics are shown, except also show the children of the 5187 third subtopic; and close the next topic at the current level. 5188\(allout-new-exposure : -1 0) 5189 Close all topics at current level to expose only their 5190 immediate children, except for the last topic at the current 5191 level, in which even its immediate children are hidden. 5192\(allout-new-exposure -2 : -1 *) 5193 Expose children and grandchildren of first topic at current 5194 level, and expose children of subsequent topics at current 5195 level *except* for the last, which should be opened completely." 5196 (list 'save-excursion 5197 '(if (not (or (allout-goto-prefix-doublechecked) 5198 (allout-next-heading))) 5199 (error "allout-new-exposure: Can't find any outline topics")) 5200 (list 'allout-expose-topic (list 'quote spec)))) 5201 5202;;;_ #7 Systematic outline presentation - copying, printing, flattening 5203 5204;;;_ - Mapping and processing of topics 5205;;;_ ( See also Subtree Charting, in Navigation code.) 5206;;;_ > allout-stringify-flat-index (flat-index) 5207(defun allout-stringify-flat-index (flat-index &optional context) 5208 "Convert list representing section/subsection/... to document string. 5209 5210Optional arg CONTEXT indicates interior levels to include." 5211 (let ((delim ".") 5212 result 5213 numstr 5214 (context-depth (or (and context 2) 1))) 5215 ;; Take care of the explicit context: 5216 (while (> context-depth 0) 5217 (setq numstr (int-to-string (car flat-index)) 5218 flat-index (cdr flat-index) 5219 result (if flat-index 5220 (cons delim (cons numstr result)) 5221 (cons numstr result)) 5222 context-depth (if flat-index (1- context-depth) 0))) 5223 (setq delim " ") 5224 ;; Take care of the indentation: 5225 (if flat-index 5226 (progn 5227 (while flat-index 5228 (setq result 5229 (cons delim 5230 (cons (make-string 5231 (1+ (truncate (if (zerop (car flat-index)) 5232 1 5233 (log10 (car flat-index))))) 5234 ? ) 5235 result))) 5236 (setq flat-index (cdr flat-index))) 5237 ;; Dispose of single extra delim: 5238 (setq result (cdr result)))) 5239 (apply 'concat result))) 5240;;;_ > allout-stringify-flat-index-plain (flat-index) 5241(defun allout-stringify-flat-index-plain (flat-index) 5242 "Convert list representing section/subsection/... to document string." 5243 (let ((delim ".") 5244 result) 5245 (while flat-index 5246 (setq result (cons (int-to-string (car flat-index)) 5247 (if result 5248 (cons delim result)))) 5249 (setq flat-index (cdr flat-index))) 5250 (apply 'concat result))) 5251;;;_ > allout-stringify-flat-index-indented (flat-index) 5252(defun allout-stringify-flat-index-indented (flat-index) 5253 "Convert list representing section/subsection/... to document string." 5254 (let ((delim ".") 5255 result 5256 numstr) 5257 ;; Take care of the explicit context: 5258 (setq numstr (int-to-string (car flat-index)) 5259 flat-index (cdr flat-index) 5260 result (if flat-index 5261 (cons delim (cons numstr result)) 5262 (cons numstr result))) 5263 (setq delim " ") 5264 ;; Take care of the indentation: 5265 (if flat-index 5266 (progn 5267 (while flat-index 5268 (setq result 5269 (cons delim 5270 (cons (make-string 5271 (1+ (truncate (if (zerop (car flat-index)) 5272 1 5273 (log10 (car flat-index))))) 5274 ? ) 5275 result))) 5276 (setq flat-index (cdr flat-index))) 5277 ;; Dispose of single extra delim: 5278 (setq result (cdr result)))) 5279 (apply 'concat result))) 5280;;;_ > allout-listify-exposed (&optional start end format) 5281(defun allout-listify-exposed (&optional start end format) 5282 5283 "Produce a list representing exposed topics in current region. 5284 5285This list can then be used by `allout-process-exposed' to manipulate 5286the subject region. 5287 5288Optional START and END indicate bounds of region. 5289 5290optional arg, FORMAT, designates an alternate presentation form for 5291the prefix: 5292 5293 list - Present prefix as numeric section.subsection..., starting with 5294 section indicated by the list, innermost nesting first. 5295 `indent' (symbol) - Convert header prefixes to all white space, 5296 except for distinctive bullets. 5297 5298The elements of the list produced are lists that represents a topic 5299header and body. The elements of that list are: 5300 5301 - a number representing the depth of the topic, 5302 - a string representing the header-prefix, including trailing whitespace and 5303 bullet. 5304 - a string representing the bullet character, 5305 - and a series of strings, each containing one line of the exposed 5306 portion of the topic entry." 5307 5308 (interactive "r") 5309 (save-excursion 5310 (let* 5311 ((inhibit-field-text-motion t) 5312 ;; state vars: 5313 strings prefix result depth new-depth out gone-out bullet beg 5314 next done) 5315 5316 (goto-char start) 5317 (beginning-of-line) 5318 ;; Goto initial topic, and register preceeding stuff, if any: 5319 (if (> (allout-goto-prefix-doublechecked) start) 5320 ;; First topic follows beginning point - register preliminary stuff: 5321 (setq result (list (list 0 "" nil 5322 (buffer-substring start (1- (point))))))) 5323 (while (and (not done) 5324 (not (eobp)) ; Loop until we've covered the region. 5325 (not (> (point) end))) 5326 (setq depth allout-recent-depth ; Current topics depth, 5327 bullet (allout-recent-bullet) ; ... bullet, 5328 prefix (allout-recent-prefix) 5329 beg (progn (allout-end-of-prefix t) (point))) ; and beginning. 5330 (setq done ; The boundary for the current topic: 5331 (not (allout-next-visible-heading 1))) 5332 (setq new-depth allout-recent-depth) 5333 (setq gone-out out 5334 out (< new-depth depth)) 5335 (beginning-of-line) 5336 (setq next (point)) 5337 (goto-char beg) 5338 (setq strings nil) 5339 (while (> next (point)) ; Get all the exposed text in 5340 (setq strings 5341 (cons (buffer-substring 5342 beg 5343 ;To hidden text or end of line: 5344 (progn 5345 (end-of-line) 5346 (allout-back-to-visible-text))) 5347 strings)) 5348 (when (< (point) next) ; Resume from after hid text, if any. 5349 (line-move 1) 5350 (beginning-of-line)) 5351 (setq beg (point))) 5352 ;; Accumulate list for this topic: 5353 (setq strings (nreverse strings)) 5354 (setq result 5355 (cons 5356 (if format 5357 (let ((special (if (string-match 5358 (regexp-quote bullet) 5359 allout-distinctive-bullets-string) 5360 bullet))) 5361 (cond ((listp format) 5362 (list depth 5363 (if allout-abbreviate-flattened-numbering 5364 (allout-stringify-flat-index format 5365 gone-out) 5366 (allout-stringify-flat-index-plain 5367 format)) 5368 strings 5369 special)) 5370 ((eq format 'indent) 5371 (if special 5372 (list depth 5373 (concat (make-string (1+ depth) ? ) 5374 (substring prefix -1)) 5375 strings) 5376 (list depth 5377 (make-string depth ? ) 5378 strings))) 5379 (t (error "allout-listify-exposed: %s %s" 5380 "invalid format" format)))) 5381 (list depth prefix strings)) 5382 result)) 5383 ;; Reasses format, if any: 5384 (if (and format (listp format)) 5385 (cond ((= new-depth depth) 5386 (setq format (cons (1+ (car format)) 5387 (cdr format)))) 5388 ((> new-depth depth) ; descending - assume by 1: 5389 (setq format (cons 1 format))) 5390 (t 5391 ; Pop the residue: 5392 (while (< new-depth depth) 5393 (setq format (cdr format)) 5394 (setq depth (1- depth))) 5395 ; And increment the current one: 5396 (setq format 5397 (cons (1+ (or (car format) 5398 -1)) 5399 (cdr format))))))) 5400 ;; Put the list with first at front, to last at back: 5401 (nreverse result)))) 5402;;;_ > my-region-active-p () 5403(defmacro my-region-active-p () 5404 (if (fboundp 'region-active-p) 5405 '(region-active-p) 5406 'mark-active)) 5407;;;_ > allout-process-exposed (&optional func from to frombuf 5408;;; tobuf format) 5409(defun allout-process-exposed (&optional func from to frombuf tobuf 5410 format start-num) 5411 "Map function on exposed parts of current topic; results to another buffer. 5412 5413All args are options; default values itemized below. 5414 5415Apply FUNCTION to exposed portions FROM position TO position in buffer 5416FROMBUF to buffer TOBUF. Sixth optional arg, FORMAT, designates an 5417alternate presentation form: 5418 5419 `flat' - Present prefix as numeric section.subsection..., starting with 5420 section indicated by the start-num, innermost nesting first. 5421 X`flat-indented' - Prefix is like `flat' for first topic at each 5422 X level, but subsequent topics have only leaf topic 5423 X number, padded with blanks to line up with first. 5424 `indent' (symbol) - Convert header prefixes to all white space, 5425 except for distinctive bullets. 5426 5427Defaults: 5428 FUNCTION: `allout-insert-listified' 5429 FROM: region start, if region active, else start of buffer 5430 TO: region end, if region active, else end of buffer 5431 FROMBUF: current buffer 5432 TOBUF: buffer name derived: \"*current-buffer-name exposed*\" 5433 FORMAT: nil" 5434 5435 ; Resolve arguments, 5436 ; defaulting if necessary: 5437 (if (not func) (setq func 'allout-insert-listified)) 5438 (if (not (and from to)) 5439 (if (my-region-active-p) 5440 (setq from (region-beginning) to (region-end)) 5441 (setq from (point-min) to (point-max)))) 5442 (if frombuf 5443 (if (not (bufferp frombuf)) 5444 ;; Specified but not a buffer - get it: 5445 (let ((got (get-buffer frombuf))) 5446 (if (not got) 5447 (error (concat "allout-process-exposed: source buffer " 5448 frombuf 5449 " not found.")) 5450 (setq frombuf got)))) 5451 ;; not specified - default it: 5452 (setq frombuf (current-buffer))) 5453 (if tobuf 5454 (if (not (bufferp tobuf)) 5455 (setq tobuf (get-buffer-create tobuf))) 5456 ;; not specified - default it: 5457 (setq tobuf (concat "*" (buffer-name frombuf) " exposed*"))) 5458 (if (listp format) 5459 (nreverse format)) 5460 5461 (let* ((listified 5462 (progn (set-buffer frombuf) 5463 (allout-listify-exposed from to format)))) 5464 (set-buffer tobuf) 5465 (mapcar func listified) 5466 (pop-to-buffer tobuf))) 5467 5468;;;_ - Copy exposed 5469;;;_ > allout-insert-listified (listified) 5470(defun allout-insert-listified (listified) 5471 "Insert contents of listified outline portion in current buffer. 5472 5473LISTIFIED is a list representing each topic header and body: 5474 5475 \`(depth prefix text)' 5476 5477or \`(depth prefix text bullet-plus)' 5478 5479If `bullet-plus' is specified, it is inserted just after the entire prefix." 5480 (setq listified (cdr listified)) 5481 (let ((prefix (prog1 5482 (car listified) 5483 (setq listified (cdr listified)))) 5484 (text (prog1 5485 (car listified) 5486 (setq listified (cdr listified)))) 5487 (bullet-plus (car listified))) 5488 (insert prefix) 5489 (if bullet-plus (insert (concat " " bullet-plus))) 5490 (while text 5491 (insert (car text)) 5492 (if (setq text (cdr text)) 5493 (insert "\n"))) 5494 (insert "\n"))) 5495;;;_ > allout-copy-exposed-to-buffer (&optional arg tobuf format) 5496(defun allout-copy-exposed-to-buffer (&optional arg tobuf format) 5497 "Duplicate exposed portions of current outline to another buffer. 5498 5499Other buffer has current buffers name with \" exposed\" appended to it. 5500 5501With repeat count, copy the exposed parts of only the current topic. 5502 5503Optional second arg TOBUF is target buffer name. 5504 5505Optional third arg FORMAT, if non-nil, symbolically designates an 5506alternate presentation format for the outline: 5507 5508 `flat' - Convert topic header prefixes to numeric 5509 section.subsection... identifiers. 5510 `indent' - Convert header prefixes to all white space, except for 5511 distinctive bullets. 5512 `indent-flat' - The best of both - only the first of each level has 5513 the full path, the rest have only the section number 5514 of the leaf, preceded by the right amount of indentation." 5515 5516 (interactive "P") 5517 (if (not tobuf) 5518 (setq tobuf (get-buffer-create (concat "*" (buffer-name) " exposed*")))) 5519 (let* ((start-pt (point)) 5520 (beg (if arg (allout-back-to-current-heading) (point-min))) 5521 (end (if arg (allout-end-of-current-subtree) (point-max))) 5522 (buf (current-buffer)) 5523 (start-list ())) 5524 (if (eq format 'flat) 5525 (setq format (if arg (save-excursion 5526 (goto-char beg) 5527 (allout-topic-flat-index)) 5528 '(1)))) 5529 (save-excursion (set-buffer tobuf)(erase-buffer)) 5530 (allout-process-exposed 'allout-insert-listified 5531 beg 5532 end 5533 (current-buffer) 5534 tobuf 5535 format start-list) 5536 (goto-char (point-min)) 5537 (pop-to-buffer buf) 5538 (goto-char start-pt))) 5539;;;_ > allout-flatten-exposed-to-buffer (&optional arg tobuf) 5540(defun allout-flatten-exposed-to-buffer (&optional arg tobuf) 5541 "Present numeric outline of outline's exposed portions in another buffer. 5542 5543The resulting outline is not compatible with outline mode - use 5544`allout-copy-exposed-to-buffer' if you want that. 5545 5546Use `allout-indented-exposed-to-buffer' for indented presentation. 5547 5548With repeat count, copy the exposed portions of only current topic. 5549 5550Other buffer has current buffer's name with \" exposed\" appended to 5551it, unless optional second arg TOBUF is specified, in which case it is 5552used verbatim." 5553 (interactive "P") 5554 (allout-copy-exposed-to-buffer arg tobuf 'flat)) 5555;;;_ > allout-indented-exposed-to-buffer (&optional arg tobuf) 5556(defun allout-indented-exposed-to-buffer (&optional arg tobuf) 5557 "Present indented outline of outline's exposed portions in another buffer. 5558 5559The resulting outline is not compatible with outline mode - use 5560`allout-copy-exposed-to-buffer' if you want that. 5561 5562Use `allout-flatten-exposed-to-buffer' for numeric sectional presentation. 5563 5564With repeat count, copy the exposed portions of only current topic. 5565 5566Other buffer has current buffer's name with \" exposed\" appended to 5567it, unless optional second arg TOBUF is specified, in which case it is 5568used verbatim." 5569 (interactive "P") 5570 (allout-copy-exposed-to-buffer arg tobuf 'indent)) 5571 5572;;;_ - LaTeX formatting 5573;;;_ > allout-latex-verb-quote (string &optional flow) 5574(defun allout-latex-verb-quote (string &optional flow) 5575 "Return copy of STRING for literal reproduction across LaTeX processing. 5576Expresses the original characters (including carriage returns) of the 5577string across LaTeX processing." 5578 (mapconcat (function 5579 (lambda (char) 5580 (cond ((memq char '(?\\ ?$ ?% ?# ?& ?{ ?} ?_ ?^ ?- ?*)) 5581 (concat "\\char" (number-to-string char) "{}")) 5582 ((= char ?\n) "\\\\") 5583 (t (char-to-string char))))) 5584 string 5585 "")) 5586;;;_ > allout-latex-verbatim-quote-curr-line () 5587(defun allout-latex-verbatim-quote-curr-line () 5588 "Express line for exact (literal) representation across LaTeX processing. 5589 5590Adjust line contents so it is unaltered (from the original line) 5591across LaTeX processing, within the context of a `verbatim' 5592environment. Leaves point at the end of the line." 5593 (let ((inhibit-field-text-motion t)) 5594 (beginning-of-line) 5595 (let ((beg (point)) 5596 (end (progn (end-of-line)(point)))) 5597 (goto-char beg) 5598 (while (re-search-forward "\\\\" 5599 ;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#" 5600 end ; bounded by end-of-line 5601 1) ; no matches, move to end & return nil 5602 (goto-char (match-beginning 2)) 5603 (insert "\\") 5604 (setq end (1+ end)) 5605 (goto-char (1+ (match-end 2))))))) 5606;;;_ > allout-insert-latex-header (buffer) 5607(defun allout-insert-latex-header (buffer) 5608 "Insert initial LaTeX commands at point in BUFFER." 5609 ;; Much of this is being derived from the stuff in appendix of E in 5610 ;; the TeXBook, pg 421. 5611 (set-buffer buffer) 5612 (let ((doc-style (format "\n\\documentstyle{%s}\n" 5613 "report")) 5614 (page-numbering (if allout-number-pages 5615 "\\pagestyle{empty}\n" 5616 "")) 5617 (titlecmd (format "\\newcommand{\\titlecmd}[1]{{%s #1}}\n" 5618 allout-title-style)) 5619 (labelcmd (format "\\newcommand{\\labelcmd}[1]{{%s #1}}\n" 5620 allout-label-style)) 5621 (headlinecmd (format "\\newcommand{\\headlinecmd}[1]{{%s #1}}\n" 5622 allout-head-line-style)) 5623 (bodylinecmd (format "\\newcommand{\\bodylinecmd}[1]{{%s #1}}\n" 5624 allout-body-line-style)) 5625 (setlength (format "%s%s%s%s" 5626 "\\newlength{\\stepsize}\n" 5627 "\\setlength{\\stepsize}{" 5628 allout-indent 5629 "}\n")) 5630 (oneheadline (format "%s%s%s%s%s%s%s" 5631 "\\newcommand{\\OneHeadLine}[3]{%\n" 5632 "\\noindent%\n" 5633 "\\hspace*{#2\\stepsize}%\n" 5634 "\\labelcmd{#1}\\hspace*{.2cm}" 5635 "\\headlinecmd{#3}\\\\[" 5636 allout-line-skip 5637 "]\n}\n")) 5638 (onebodyline (format "%s%s%s%s%s%s" 5639 "\\newcommand{\\OneBodyLine}[2]{%\n" 5640 "\\noindent%\n" 5641 "\\hspace*{#1\\stepsize}%\n" 5642 "\\bodylinecmd{#2}\\\\[" 5643 allout-line-skip 5644 "]\n}\n")) 5645 (begindoc "\\begin{document}\n\\begin{center}\n") 5646 (title (format "%s%s%s%s" 5647 "\\titlecmd{" 5648 (allout-latex-verb-quote (if allout-title 5649 (condition-case nil 5650 (eval allout-title) 5651 (error "<unnamed buffer>")) 5652 "Unnamed Outline")) 5653 "}\n" 5654 "\\end{center}\n\n")) 5655 (hsize "\\hsize = 7.5 true in\n") 5656 (hoffset "\\hoffset = -1.5 true in\n") 5657 (vspace "\\vspace{.1cm}\n\n")) 5658 (insert (concat doc-style 5659 page-numbering 5660 titlecmd 5661 labelcmd 5662 headlinecmd 5663 bodylinecmd 5664 setlength 5665 oneheadline 5666 onebodyline 5667 begindoc 5668 title 5669 hsize 5670 hoffset 5671 vspace) 5672 ))) 5673;;;_ > allout-insert-latex-trailer (buffer) 5674(defun allout-insert-latex-trailer (buffer) 5675 "Insert concluding LaTeX commands at point in BUFFER." 5676 (set-buffer buffer) 5677 (insert "\n\\end{document}\n")) 5678;;;_ > allout-latexify-one-item (depth prefix bullet text) 5679(defun allout-latexify-one-item (depth prefix bullet text) 5680 "Insert LaTeX commands for formatting one outline item. 5681 5682Args are the topics numeric DEPTH, the header PREFIX lead string, the 5683BULLET string, and a list of TEXT strings for the body." 5684 (let* ((head-line (if text (car text))) 5685 (body-lines (cdr text)) 5686 (curr-line) 5687 body-content bop) 5688 ; Do the head line: 5689 (insert (concat "\\OneHeadLine{\\verb\1 " 5690 (allout-latex-verb-quote bullet) 5691 "\1}{" 5692 depth 5693 "}{\\verb\1 " 5694 (if head-line 5695 (allout-latex-verb-quote head-line) 5696 "") 5697 "\1}\n")) 5698 (if (not body-lines) 5699 nil 5700 ;;(insert "\\beginlines\n") 5701 (insert "\\begin{verbatim}\n") 5702 (while body-lines 5703 (setq curr-line (car body-lines)) 5704 (if (and (not body-content) 5705 (not (string-match "^\\s-*$" curr-line))) 5706 (setq body-content t)) 5707 ; Mangle any occurrences of 5708 ; "\end{verbatim}" in text, 5709 ; it's special: 5710 (if (and body-content 5711 (setq bop (string-match "\\end{verbatim}" curr-line))) 5712 (setq curr-line (concat (substring curr-line 0 bop) 5713 ">" 5714 (substring curr-line bop)))) 5715 ;;(insert "|" (car body-lines) "|") 5716 (insert curr-line) 5717 (allout-latex-verbatim-quote-curr-line) 5718 (insert "\n") 5719 (setq body-lines (cdr body-lines))) 5720 (if body-content 5721 (setq body-content nil) 5722 (forward-char -1) 5723 (insert "\\ ") 5724 (forward-char 1)) 5725 ;;(insert "\\endlines\n") 5726 (insert "\\end{verbatim}\n") 5727 ))) 5728;;;_ > allout-latexify-exposed (arg &optional tobuf) 5729(defun allout-latexify-exposed (arg &optional tobuf) 5730 "Format current topics exposed portions to TOBUF for LaTeX processing. 5731TOBUF defaults to a buffer named the same as the current buffer, but 5732with \"*\" prepended and \" latex-formed*\" appended. 5733 5734With repeat count, copy the exposed portions of entire buffer." 5735 5736 (interactive "P") 5737 (if (not tobuf) 5738 (setq tobuf 5739 (get-buffer-create (concat "*" (buffer-name) " latexified*")))) 5740 (let* ((start-pt (point)) 5741 (beg (if arg (point-min) (allout-back-to-current-heading))) 5742 (end (if arg (point-max) (allout-end-of-current-subtree))) 5743 (buf (current-buffer))) 5744 (set-buffer tobuf) 5745 (erase-buffer) 5746 (allout-insert-latex-header tobuf) 5747 (goto-char (point-max)) 5748 (allout-process-exposed 'allout-latexify-one-item 5749 beg 5750 end 5751 buf 5752 tobuf) 5753 (goto-char (point-max)) 5754 (allout-insert-latex-trailer tobuf) 5755 (goto-char (point-min)) 5756 (pop-to-buffer buf) 5757 (goto-char start-pt))) 5758 5759;;;_ #8 Encryption 5760;;;_ > allout-toggle-current-subtree-encryption (&optional fetch-pass) 5761(defun allout-toggle-current-subtree-encryption (&optional fetch-pass) 5762 "Encrypt clear or decrypt encoded text of visibly-containing topic's contents. 5763 5764Optional FETCH-PASS universal argument provokes key-pair encryption with 5765single universal argument. With doubled universal argument (value = 16), 5766it forces prompting for the passphrase regardless of availability from the 5767passphrase cache. With no universal argument, the appropriate passphrase 5768is obtained from the cache, if available, else from the user. 5769 5770Only GnuPG encryption is supported. 5771 5772\*NOTE WELL* that the encrypted text must be ascii-armored. For gnupg 5773encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file. 5774 5775Both symmetric-key and key-pair encryption is implemented. Symmetric is 5776the default, use a single (x4) universal argument for keypair mode. 5777 5778Encrypted topic's bullet is set to a `~' to signal that the contents of the 5779topic (body and subtopics, but not heading) is pending encryption or 5780encrypted. `*' asterisk immediately after the bullet signals that the body 5781is encrypted, its' absence means the topic is meant to be encrypted but is 5782not. When a file with topics pending encryption is saved, topics pending 5783encryption are encrypted. See allout-encrypt-unencrypted-on-saves for 5784auto-encryption specifics. 5785 5786\*NOTE WELL* that automatic encryption that happens during saves will 5787default to symmetric encryption - you must deliberately (re)encrypt key-pair 5788encrypted topics if you want them to continue to use the key-pair cipher. 5789 5790Level-one topics, with prefix consisting solely of an `*' asterisk, cannot be 5791encrypted. If you want to encrypt the contents of a top-level topic, use 5792\\[allout-shift-in] to increase its depth. 5793 5794 Passphrase Caching 5795 5796The encryption passphrase is solicited if not currently available in the 5797passphrase cache from a recent encryption action. 5798 5799The solicited passphrase is retained for reuse in a cache, if enabled. See 5800`pgg-cache-passphrase' and `pgg-passphrase-cache-expiry' for details. 5801 5802 Symmetric Passphrase Hinting and Verification 5803 5804If the file previously had no associated passphrase, or had a different 5805passphrase than specified, the user is prompted to repeat the new one for 5806corroboration. A random string encrypted by the new passphrase is set on 5807the buffer-specific variable `allout-passphrase-verifier-string', for 5808confirmation of the passphrase when next obtained, before encrypting or 5809decrypting anything with it. This helps avoid mistakenly shifting between 5810keys. 5811 5812If allout customization var `allout-passphrase-verifier-handling' is 5813non-nil, an entry for `allout-passphrase-verifier-string' and its value is 5814added to an Emacs 'local variables' section at the end of the file, which 5815is created if necessary. That setting is for retention of the passphrase 5816verifier across Emacs sessions. 5817 5818Similarly, `allout-passphrase-hint-string' stores a user-provided reminder 5819about their passphrase, and `allout-passphrase-hint-handling' specifies 5820when the hint is presented, or if passphrase hints are disabled. If 5821enabled (see the `allout-passphrase-hint-handling' docstring for details), 5822the hint string is stored in the local-variables section of the file, and 5823solicited whenever the passphrase is changed." 5824 (interactive "P") 5825 (save-excursion 5826 (allout-back-to-current-heading) 5827 (allout-toggle-subtree-encryption fetch-pass) 5828 ) 5829 ) 5830;;;_ > allout-toggle-subtree-encryption (&optional fetch-pass) 5831(defun allout-toggle-subtree-encryption (&optional fetch-pass) 5832 "Encrypt clear text or decrypt encoded topic contents (body and subtopics.) 5833 5834Optional FETCH-PASS universal argument provokes key-pair encryption with 5835single universal argument. With doubled universal argument (value = 16), 5836it forces prompting for the passphrase regardless of availability from the 5837passphrase cache. With no universal argument, the appropriate passphrase 5838is obtained from the cache, if available, else from the user. 5839 5840Currently only GnuPG encryption is supported, and integration 5841with gpg-agent is not yet implemented. 5842 5843\**NOTE WELL** that the encrypted text must be ascii-armored. For gnupg 5844encryption, include the option ``armor'' in your ~/.gnupg/gpg.conf file. 5845 5846See `allout-toggle-current-subtree-encryption' for more details." 5847 5848 (interactive "P") 5849 (save-excursion 5850 (allout-end-of-prefix t) 5851 5852 (if (= allout-recent-depth 1) 5853 (error (concat "Cannot encrypt or decrypt level 1 topics -" 5854 " shift it in to make it encryptable"))) 5855 5856 (let* ((allout-buffer (current-buffer)) 5857 ;; Assess location: 5858 (bullet-pos allout-recent-prefix-beginning) 5859 (after-bullet-pos (point)) 5860 (was-encrypted 5861 (progn (if (= (point-max) after-bullet-pos) 5862 (error "no body to encrypt")) 5863 (allout-encrypted-topic-p))) 5864 (was-collapsed (if (not (search-forward "\n" nil t)) 5865 nil 5866 (backward-char 1) 5867 (allout-hidden-p))) 5868 (subtree-beg (1+ (point))) 5869 (subtree-end (allout-end-of-subtree)) 5870 (subject-text (buffer-substring-no-properties subtree-beg 5871 subtree-end)) 5872 (subtree-end-char (char-after (1- subtree-end))) 5873 (subtree-trailing-char (char-after subtree-end)) 5874 ;; kluge - result-text needs to be nil, but we also want to 5875 ;; check for the error condition 5876 (result-text (if (or (string= "" subject-text) 5877 (string= "\n" subject-text)) 5878 (error "No topic contents to %scrypt" 5879 (if was-encrypted "de" "en")) 5880 nil)) 5881 ;; Assess key parameters: 5882 (key-info (or 5883 ;; detect the type by which it is already encrypted 5884 (and was-encrypted 5885 (allout-encrypted-key-info subject-text)) 5886 (and (member fetch-pass '(4 (4))) 5887 '(keypair nil)) 5888 '(symmetric nil))) 5889 (for-key-type (car key-info)) 5890 (for-key-identity (cadr key-info)) 5891 (fetch-pass (and fetch-pass (member fetch-pass '(16 (16))))) 5892 (was-coding-system buffer-file-coding-system)) 5893 5894 (when (not was-encrypted) 5895 ;; ensure that non-ascii chars pending encryption are noticed before 5896 ;; they're encrypted, so the coding system is set to accomodate 5897 ;; them. 5898 (setq buffer-file-coding-system 5899 (select-safe-coding-system subtree-beg subtree-end)) 5900 ;; if the coding system for the text being encrypted is different 5901 ;; than that prevailing, then there a real risk that the coding 5902 ;; system can't be noticed by emacs when the file is visited. to 5903 ;; mitigate that, offer to preserve the coding system using a file 5904 ;; local variable. 5905 (if (and (not (equal buffer-file-coding-system 5906 was-coding-system)) 5907 (yes-or-no-p 5908 (format (concat "Register coding system %s as file local" 5909 " var? Necessary when only encrypted text" 5910 " is in that coding system. ") 5911 buffer-file-coding-system))) 5912 (allout-adjust-file-variable "buffer-file-coding-system" 5913 buffer-file-coding-system))) 5914 5915 (setq result-text 5916 (allout-encrypt-string subject-text was-encrypted 5917 (current-buffer) 5918 for-key-type for-key-identity fetch-pass)) 5919 5920 ;; Replace the subtree with the processed product. 5921 (allout-unprotected 5922 (progn 5923 (set-buffer allout-buffer) 5924 (delete-region subtree-beg subtree-end) 5925 (insert result-text) 5926 (if was-collapsed 5927 (allout-flag-region (1- subtree-beg) (point) t)) 5928 ;; adjust trailing-blank-lines to preserve topic spacing: 5929 (if (not was-encrypted) 5930 (if (and (= subtree-end-char ?\n) 5931 (= subtree-trailing-char ?\n)) 5932 (insert subtree-trailing-char))) 5933 ;; Ensure that the item has an encrypted-entry bullet: 5934 (if (not (string= (buffer-substring-no-properties 5935 (1- after-bullet-pos) after-bullet-pos) 5936 allout-topic-encryption-bullet)) 5937 (progn (goto-char (1- after-bullet-pos)) 5938 (delete-char 1) 5939 (insert allout-topic-encryption-bullet))) 5940 (if was-encrypted 5941 ;; Remove the is-encrypted bullet qualifier: 5942 (progn (goto-char after-bullet-pos) 5943 (delete-char 1)) 5944 ;; Add the is-encrypted bullet qualifier: 5945 (goto-char after-bullet-pos) 5946 (insert "*")))) 5947 (run-hook-with-args 'allout-structure-added-hook 5948 bullet-pos subtree-end)))) 5949;;;_ > allout-encrypt-string (text decrypt allout-buffer key-type for-key 5950;;; fetch-pass &optional retried verifying 5951;;; passphrase) 5952(defun allout-encrypt-string (text decrypt allout-buffer key-type for-key 5953 fetch-pass &optional retried rejected 5954 verifying passphrase) 5955 "Encrypt or decrypt message TEXT. 5956 5957If DECRYPT is true (default false), then decrypt instead of encrypt. 5958 5959FETCH-PASS (default false) forces fresh prompting for the passphrase. 5960 5961KEY-TYPE indicates whether to use a 'symmetric or 'keypair cipher. 5962 5963FOR-KEY is human readable identification of the first of the user's 5964eligible secret keys a keypair decryption targets, or else nil. 5965 5966Optional RETRIED is for internal use - conveys the number of failed keys 5967that have been solicited in sequence leading to this current call. 5968 5969Optional PASSPHRASE enables explicit delivery of the decryption passphrase, 5970for verification purposes. 5971 5972Optional REJECTED is for internal use - conveys the number of 5973rejections due to matches against 5974`allout-encryption-ciphertext-rejection-regexps', as limited by 5975`allout-encryption-ciphertext-rejection-ceiling'. 5976 5977Returns the resulting string, or nil if the transformation fails." 5978 5979 (require 'pgg) 5980 5981 (if (not (fboundp 'pgg-encrypt-symmetric)) 5982 (error "Allout encryption depends on a newer version of pgg")) 5983 5984 (let* ((scheme (upcase 5985 (format "%s" (or pgg-scheme pgg-default-scheme "GPG")))) 5986 (for-key (and (equal key-type 'keypair) 5987 (or for-key 5988 (split-string (read-string 5989 (format "%s message recipients: " 5990 scheme)) 5991 "[ \t,]+")))) 5992 (target-prompt-id (if (equal key-type 'keypair) 5993 (if (= (length for-key) 1) 5994 (car for-key) for-key) 5995 (buffer-name allout-buffer))) 5996 (target-cache-id (format "%s-%s" 5997 key-type 5998 (if (equal key-type 'keypair) 5999 target-prompt-id 6000 (or (buffer-file-name allout-buffer) 6001 target-prompt-id)))) 6002 (encoding (with-current-buffer allout-buffer 6003 buffer-file-coding-system)) 6004 (multibyte (with-current-buffer allout-buffer 6005 enable-multibyte-characters)) 6006 (strip-plaintext-regexps 6007 (if (not decrypt) 6008 (allout-get-configvar-values 6009 'allout-encryption-plaintext-sanitization-regexps))) 6010 (reject-ciphertext-regexps 6011 (if (not decrypt) 6012 (allout-get-configvar-values 6013 'allout-encryption-ciphertext-rejection-regexps))) 6014 (rejected (or rejected 0)) 6015 (rejections-left (- allout-encryption-ciphertext-rejection-ceiling 6016 rejected)) 6017 result-text status 6018 ) 6019 6020 (if (and fetch-pass (not passphrase)) 6021 ;; Force later fetch by evicting passphrase from the cache. 6022 (pgg-remove-passphrase-from-cache target-cache-id t)) 6023 6024 (catch 'encryption-failed 6025 6026 ;; We handle only symmetric-key passphrase caching. 6027 (if (and (not passphrase) 6028 (not (equal key-type 'keypair))) 6029 (setq passphrase (allout-obtain-passphrase for-key 6030 target-cache-id 6031 target-prompt-id 6032 key-type 6033 allout-buffer 6034 retried fetch-pass))) 6035 6036 (with-temp-buffer 6037 6038 (insert text) 6039 6040 ;; convey the text characteristics of the original buffer: 6041 (set-buffer-multibyte multibyte) 6042 (when encoding 6043 (set-buffer-file-coding-system encoding) 6044 (if (not decrypt) 6045 (encode-coding-region (point-min) (point-max) encoding))) 6046 6047 (when (and strip-plaintext-regexps (not decrypt)) 6048 (dolist (re strip-plaintext-regexps) 6049 (let ((re (if (listp re) (car re) re)) 6050 (replacement (if (listp re) (cadr re) ""))) 6051 (goto-char (point-min)) 6052 (while (re-search-forward re nil t) 6053 (replace-match replacement nil nil))))) 6054 6055 (cond 6056 6057 ;; symmetric: 6058 ((equal key-type 'symmetric) 6059 (setq status 6060 (if decrypt 6061 6062 (pgg-decrypt (point-min) (point-max) passphrase) 6063 6064 (pgg-encrypt-symmetric (point-min) (point-max) 6065 passphrase))) 6066 6067 (if status 6068 (pgg-situate-output (point-min) (point-max)) 6069 ;; failed - handle passphrase caching 6070 (if verifying 6071 (throw 'encryption-failed nil) 6072 (pgg-remove-passphrase-from-cache target-cache-id t) 6073 (error "Symmetric-cipher %scryption failed - %s" 6074 (if decrypt "de" "en") 6075 "try again with different passphrase.")))) 6076 6077 ;; encrypt 'keypair: 6078 ((not decrypt) 6079 6080 (setq status 6081 6082 (pgg-encrypt for-key 6083 nil (point-min) (point-max) passphrase)) 6084 6085 (if status 6086 (pgg-situate-output (point-min) (point-max)) 6087 (error (pgg-remove-passphrase-from-cache target-cache-id t) 6088 (error "encryption failed")))) 6089 6090 ;; decrypt 'keypair: 6091 (t 6092 6093 (setq status 6094 (pgg-decrypt (point-min) (point-max) passphrase)) 6095 6096 (if status 6097 (pgg-situate-output (point-min) (point-max)) 6098 (error (pgg-remove-passphrase-from-cache target-cache-id t) 6099 (error "decryption failed"))))) 6100 6101 (setq result-text 6102 (buffer-substring-no-properties 6103 1 (- (point-max) (if decrypt 0 1)))) 6104 ) 6105 6106 ;; validate result - non-empty 6107 (cond ((not result-text) 6108 (if verifying 6109 nil 6110 ;; transform was fruitless, retry w/new passphrase. 6111 (pgg-remove-passphrase-from-cache target-cache-id t) 6112 (allout-encrypt-string text decrypt allout-buffer 6113 key-type for-key nil 6114 (if retried (1+ retried) 1) 6115 rejected verifying nil))) 6116 6117 ;; Retry (within limit) if ciphertext contains rejections: 6118 ((and (not decrypt) 6119 ;; Check for disqualification of this ciphertext: 6120 (let ((regexps reject-ciphertext-regexps) 6121 reject-it) 6122 (while (and regexps (not reject-it)) 6123 (setq reject-it (string-match (car regexps) 6124 result-text)) 6125 (pop regexps)) 6126 reject-it)) 6127 (setq rejections-left (1- rejections-left)) 6128 (if (<= rejections-left 0) 6129 (error (concat "Ciphertext rejected too many times" 6130 " (%s), per `%s'") 6131 allout-encryption-ciphertext-rejection-ceiling 6132 'allout-encryption-ciphertext-rejection-regexps) 6133 (allout-encrypt-string text decrypt allout-buffer 6134 key-type for-key nil 6135 retried (1+ rejected) 6136 verifying passphrase))) 6137 ;; Barf if encryption yields extraordinary control chars: 6138 ((and (not decrypt) 6139 (string-match "[\C-a\C-k\C-o-\C-z\C-@]" 6140 result-text)) 6141 (error (concat "Encryption produced non-armored text, which" 6142 "conflicts with allout mode - reconfigure!"))) 6143 6144 ;; valid result and just verifying or non-symmetric: 6145 ((or verifying (not (equal key-type 'symmetric))) 6146 (if (or verifying decrypt) 6147 (pgg-add-passphrase-to-cache target-cache-id 6148 passphrase t)) 6149 result-text) 6150 6151 ;; valid result and regular symmetric - "register" 6152 ;; passphrase with mnemonic aids/cache. 6153 (t 6154 (set-buffer allout-buffer) 6155 (if passphrase 6156 (pgg-add-passphrase-to-cache target-cache-id 6157 passphrase t)) 6158 (allout-update-passphrase-mnemonic-aids for-key passphrase 6159 allout-buffer) 6160 result-text) 6161 ) 6162 ) 6163 ) 6164 ) 6165;;;_ > allout-obtain-passphrase (for-key cache-id prompt-id key-type 6166;;; allout-buffer retried fetch-pass) 6167(defun allout-obtain-passphrase (for-key cache-id prompt-id key-type 6168 allout-buffer retried fetch-pass) 6169 "Obtain passphrase for a key from the cache or else from the user. 6170 6171When obtaining from the user, symmetric-cipher passphrases are verified 6172against either, if available and enabled, a random string that was 6173encrypted against the passphrase, or else against repeated entry by the 6174user for corroboration. 6175 6176FOR-KEY is the key for which the passphrase is being obtained. 6177 6178CACHE-ID is the cache id of the key for the passphrase. 6179 6180PROMPT-ID is the id for use when prompting the user. 6181 6182KEY-TYPE is either 'symmetric or 'keypair. 6183 6184ALLOUT-BUFFER is the buffer containing the entry being en/decrypted. 6185 6186RETRIED is the number of this attempt to obtain this passphrase. 6187 6188FETCH-PASS causes the passphrase to be solicited from the user, regardless 6189of the availability of a cached copy." 6190 6191 (if (not (equal key-type 'symmetric)) 6192 ;; do regular passphrase read on non-symmetric passphrase: 6193 (pgg-read-passphrase (format "%s passphrase%s: " 6194 (upcase (format "%s" (or pgg-scheme 6195 pgg-default-scheme 6196 "GPG"))) 6197 (if prompt-id 6198 (format " for %s" prompt-id) 6199 "")) 6200 cache-id t) 6201 6202 ;; Symmetric hereon: 6203 6204 (save-excursion 6205 (set-buffer allout-buffer) 6206 (let* ((hint (if (and (not (string= allout-passphrase-hint-string "")) 6207 (or (equal allout-passphrase-hint-handling 'always) 6208 (and (equal allout-passphrase-hint-handling 6209 'needed) 6210 retried))) 6211 (format " [%s]" allout-passphrase-hint-string) 6212 "")) 6213 (retry-message (if retried (format " (%s retry)" retried) "")) 6214 (prompt-sans-hint (format "'%s' symmetric passphrase%s: " 6215 prompt-id retry-message)) 6216 (full-prompt (format "'%s' symmetric passphrase%s%s: " 6217 prompt-id hint retry-message)) 6218 (prompt full-prompt) 6219 (verifier-string (allout-get-encryption-passphrase-verifier)) 6220 6221 (cached (and (not fetch-pass) 6222 (pgg-read-passphrase-from-cache cache-id t))) 6223 (got-pass (or cached 6224 (pgg-read-passphrase full-prompt cache-id t))) 6225 confirmation) 6226 6227 (if (not got-pass) 6228 nil 6229 6230 ;; Duplicate our handle on the passphrase so it's not clobbered by 6231 ;; deactivate-passwd memory clearing: 6232 (setq got-pass (copy-sequence got-pass)) 6233 6234 (cond (verifier-string 6235 (save-window-excursion 6236 (if (allout-encrypt-string verifier-string 'decrypt 6237 allout-buffer 'symmetric 6238 for-key nil 0 0 'verifying 6239 (copy-sequence got-pass)) 6240 (setq confirmation (format "%s" got-pass)))) 6241 6242 (if (and (not confirmation) 6243 (if (yes-or-no-p 6244 (concat "Passphrase differs from established" 6245 " - use new one instead? ")) 6246 ;; deactivate password for subsequent 6247 ;; confirmation: 6248 (progn 6249 (pgg-remove-passphrase-from-cache cache-id t) 6250 (setq prompt prompt-sans-hint) 6251 nil) 6252 t)) 6253 (progn (pgg-remove-passphrase-from-cache cache-id t) 6254 (error "Wrong passphrase.")))) 6255 ;; No verifier string - force confirmation by repetition of 6256 ;; (new) passphrase: 6257 ((or fetch-pass (not cached)) 6258 (pgg-remove-passphrase-from-cache cache-id t)))) 6259 ;; confirmation vs new input - doing pgg-read-passphrase will do the 6260 ;; right thing, in either case: 6261 (if (not confirmation) 6262 (setq confirmation 6263 (pgg-read-passphrase (concat prompt 6264 " ... confirm spelling: ") 6265 cache-id t))) 6266 (prog1 6267 (if (equal got-pass confirmation) 6268 confirmation 6269 (if (yes-or-no-p (concat "spelling of original and" 6270 " confirmation differ - retry? ")) 6271 (progn (setq retried (if retried (1+ retried) 1)) 6272 (pgg-remove-passphrase-from-cache cache-id t) 6273 ;; recurse to this routine: 6274 (pgg-read-passphrase prompt-sans-hint cache-id t)) 6275 (pgg-remove-passphrase-from-cache cache-id t) 6276 (error "Confirmation failed.")))))))) 6277;;;_ > allout-encrypted-topic-p () 6278(defun allout-encrypted-topic-p () 6279 "True if the current topic is encryptable and encrypted." 6280 (save-excursion 6281 (allout-end-of-prefix t) 6282 (and (string= (buffer-substring-no-properties (1- (point)) (point)) 6283 allout-topic-encryption-bullet) 6284 (looking-at "\\*")) 6285 ) 6286 ) 6287;;;_ > allout-encrypted-key-info (text) 6288;; XXX gpg-specific, alas 6289(defun allout-encrypted-key-info (text) 6290 "Return a pair of the key type and identity of a recipient's secret key. 6291 6292The key type is one of 'symmetric or 'keypair. 6293 6294if 'keypair, and some of the user's secret keys are among those for which 6295the message was encoded, return the identity of the first. otherwise, 6296return nil for the second item of the pair. 6297 6298An error is raised if the text is not encrypted." 6299 (require 'pgg-parse) 6300 (save-excursion 6301 (with-temp-buffer 6302 (insert text) 6303 (let* ((parsed-armor (pgg-parse-armor-region (point-min) (point-max))) 6304 (type (if (pgg-gpg-symmetric-key-p parsed-armor) 6305 'symmetric 6306 'keypair)) 6307 secret-keys first-secret-key for-key-owner) 6308 (if (equal type 'keypair) 6309 (setq secret-keys (pgg-gpg-lookup-all-secret-keys) 6310 first-secret-key (pgg-gpg-select-matching-key parsed-armor 6311 secret-keys) 6312 for-key-owner (and first-secret-key 6313 (pgg-gpg-lookup-key-owner 6314 first-secret-key)))) 6315 (list type (pgg-gpg-key-id-from-key-owner for-key-owner)) 6316 ) 6317 ) 6318 ) 6319 ) 6320;;;_ > allout-create-encryption-passphrase-verifier (passphrase) 6321(defun allout-create-encryption-passphrase-verifier (passphrase) 6322 "Encrypt random message for later validation of symmetric key's passphrase." 6323 ;; use 20 random ascii characters, across the entire ascii range. 6324 (random t) 6325 (let ((spew (make-string 20 ?\0))) 6326 (dotimes (i (length spew)) 6327 (aset spew i (1+ (random 254)))) 6328 (allout-encrypt-string spew nil (current-buffer) 'symmetric 6329 nil nil 0 0 passphrase)) 6330 ) 6331;;;_ > allout-update-passphrase-mnemonic-aids (for-key passphrase 6332;;; outline-buffer) 6333(defun allout-update-passphrase-mnemonic-aids (for-key passphrase 6334 outline-buffer) 6335 "Update passphrase verifier and hint strings if necessary. 6336 6337See `allout-passphrase-verifier-string' and `allout-passphrase-hint-string' 6338settings. 6339 6340PASSPHRASE is the passphrase being mnemonicized 6341 6342OUTLINE-BUFFER is the buffer of the outline being adjusted. 6343 6344These are used to help the user keep track of the passphrase they use for 6345symmetric encryption in the file. 6346 6347Behavior is governed by `allout-passphrase-verifier-handling', 6348`allout-passphrase-hint-handling', and also, controlling whether the values 6349are preserved on Emacs local file variables, 6350`allout-enable-file-variable-adjustment'." 6351 6352 ;; If passphrase doesn't agree with current verifier: 6353 ;; - adjust the verifier 6354 ;; - if passphrase hint handling is enabled, adjust the passphrase hint 6355 ;; - if file var settings are enabled, adjust the file vars 6356 6357 (let* ((new-verifier-needed (not (allout-verify-passphrase 6358 for-key passphrase outline-buffer))) 6359 (new-verifier-string 6360 (if new-verifier-needed 6361 ;; Collapse to a single line and enclose in string quotes: 6362 (subst-char-in-string 6363 ?\n ?\C-a (allout-create-encryption-passphrase-verifier 6364 passphrase)))) 6365 new-hint) 6366 (when new-verifier-string 6367 ;; do the passphrase hint first, since it's interactive 6368 (when (and allout-passphrase-hint-handling 6369 (not (equal allout-passphrase-hint-handling 'disabled))) 6370 (setq new-hint 6371 (read-from-minibuffer "Passphrase hint to jog your memory: " 6372 allout-passphrase-hint-string)) 6373 (when (not (string= new-hint allout-passphrase-hint-string)) 6374 (setq allout-passphrase-hint-string new-hint) 6375 (allout-adjust-file-variable "allout-passphrase-hint-string" 6376 allout-passphrase-hint-string))) 6377 (when allout-passphrase-verifier-handling 6378 (setq allout-passphrase-verifier-string new-verifier-string) 6379 (allout-adjust-file-variable "allout-passphrase-verifier-string" 6380 allout-passphrase-verifier-string)) 6381 ) 6382 ) 6383 ) 6384;;;_ > allout-get-encryption-passphrase-verifier () 6385(defun allout-get-encryption-passphrase-verifier () 6386 "Return text of the encrypt passphrase verifier, unmassaged, or nil if none. 6387 6388Derived from value of `allout-passphrase-verifier-string'." 6389 6390 (let ((verifier-string (and (boundp 'allout-passphrase-verifier-string) 6391 allout-passphrase-verifier-string))) 6392 (if verifier-string 6393 ;; Return it uncollapsed 6394 (subst-char-in-string ?\C-a ?\n verifier-string)) 6395 ) 6396 ) 6397;;;_ > allout-verify-passphrase (key passphrase allout-buffer) 6398(defun allout-verify-passphrase (key passphrase allout-buffer) 6399 "True if passphrase successfully decrypts verifier, nil otherwise. 6400 6401\"Otherwise\" includes absence of passphrase verifier." 6402 (save-excursion 6403 (set-buffer allout-buffer) 6404 (and (boundp 'allout-passphrase-verifier-string) 6405 allout-passphrase-verifier-string 6406 (allout-encrypt-string (allout-get-encryption-passphrase-verifier) 6407 'decrypt allout-buffer 'symmetric 6408 key nil 0 0 'verifying passphrase) 6409 t))) 6410;;;_ > allout-next-topic-pending-encryption (&optional except-mark) 6411(defun allout-next-topic-pending-encryption (&optional except-mark) 6412 "Return the point of the next topic pending encryption, or nil if none. 6413 6414EXCEPT-MARK identifies a point whose containing topics should be excluded 6415from encryption. This supports 'except-current mode of 6416`allout-encrypt-unencrypted-on-saves'. 6417 6418Such a topic has the allout-topic-encryption-bullet without an 6419immediately following '*' that would mark the topic as being encrypted. It 6420must also have content." 6421 (let (done got content-beg) 6422 (while (not done) 6423 6424 (if (not (re-search-forward 6425 (format "\\(\\`\\|\n\\)%s *%s[^*]" 6426 (regexp-quote allout-header-prefix) 6427 (regexp-quote allout-topic-encryption-bullet)) 6428 nil t)) 6429 (setq got nil 6430 done t) 6431 (goto-char (setq got (match-beginning 0))) 6432 (if (looking-at "\n") 6433 (forward-char 1)) 6434 (setq got (point))) 6435 6436 (cond ((not got) 6437 (setq done t)) 6438 6439 ((not (search-forward "\n")) 6440 (setq got nil 6441 done t)) 6442 6443 ((eobp) 6444 (setq got nil 6445 done t)) 6446 6447 (t 6448 (setq content-beg (point)) 6449 (backward-char 1) 6450 (allout-end-of-subtree) 6451 (if (or (<= (point) content-beg) 6452 (and except-mark 6453 (<= content-beg except-mark) 6454 (>= (point) except-mark))) 6455 ;; Continue looking 6456 (setq got nil) 6457 ;; Got it! 6458 (setq done t))) 6459 ) 6460 ) 6461 (if got 6462 (goto-char got)) 6463 ) 6464 ) 6465;;;_ > allout-encrypt-decrypted (&optional except-mark) 6466(defun allout-encrypt-decrypted (&optional except-mark) 6467 "Encrypt topics pending encryption except those containing exemption point. 6468 6469EXCEPT-MARK identifies a point whose containing topics should be excluded 6470from encryption. This supports 'except-current mode of 6471`allout-encrypt-unencrypted-on-saves'. 6472 6473If a topic that is currently being edited was encrypted, we return a list 6474containing the location of the topic and the location of the cursor just 6475before the topic was encrypted. This can be used, eg, to decrypt the topic 6476and exactly resituate the cursor if this is being done as part of a file 6477save. See `allout-encrypt-unencrypted-on-saves' for more info." 6478 6479 (interactive "p") 6480 (save-excursion 6481 (let* ((current-mark (point-marker)) 6482 (current-mark-position (marker-position current-mark)) 6483 was-modified 6484 bo-subtree 6485 editing-topic editing-point) 6486 (goto-char (point-min)) 6487 (while (allout-next-topic-pending-encryption except-mark) 6488 (setq was-modified (buffer-modified-p)) 6489 (when (save-excursion 6490 (and (boundp 'allout-encrypt-unencrypted-on-saves) 6491 allout-encrypt-unencrypted-on-saves 6492 (setq bo-subtree (re-search-forward "$")) 6493 (not (allout-hidden-p)) 6494 (>= current-mark (point)) 6495 (allout-end-of-current-subtree) 6496 (<= current-mark (point)))) 6497 (setq editing-topic (point) 6498 ;; we had to wait for this 'til now so prior topics are 6499 ;; encrypted, any relevant text shifts are in place: 6500 editing-point (- current-mark-position 6501 (count-trailing-whitespace-region 6502 bo-subtree current-mark-position)))) 6503 (allout-toggle-subtree-encryption) 6504 (if (not was-modified) 6505 (set-buffer-modified-p nil)) 6506 ) 6507 (if (not was-modified) 6508 (set-buffer-modified-p nil)) 6509 (if editing-topic (list editing-topic editing-point)) 6510 ) 6511 ) 6512 ) 6513 6514;;;_ #9 miscellaneous 6515;;;_ : Mode: 6516;;;_ > outlineify-sticky () 6517;; outlinify-sticky is correct spelling; provide this alias for sticklers: 6518;;;###autoload 6519(defalias 'outlinify-sticky 'outlineify-sticky) 6520;;;###autoload 6521(defun outlineify-sticky (&optional arg) 6522 "Activate outline mode and establish file var so it is started subsequently. 6523 6524See doc-string for `allout-layout' and `allout-init' for details on 6525setup for auto-startup." 6526 6527 (interactive "P") 6528 6529 (allout-mode t) 6530 6531 (save-excursion 6532 (goto-char (point-min)) 6533 (if (allout-goto-prefix) 6534 t 6535 (allout-open-topic 2) 6536 (insert (concat "Dummy outline topic header - see" 6537 "`allout-mode' docstring: `^Hm'.")) 6538 (allout-adjust-file-variable 6539 "allout-layout" (or allout-layout '(-1 : 0)))))) 6540;;;_ > allout-file-vars-section-data () 6541(defun allout-file-vars-section-data () 6542 "Return data identifying the file-vars section, or nil if none. 6543 6544Returns list `(beginning-point prefix-string suffix-string)'." 6545 ;; minimally gleaned from emacs 21.4 files.el hack-local-variables function. 6546 (let (beg prefix suffix) 6547 (save-excursion 6548 (goto-char (point-max)) 6549 (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move) 6550 (if (let ((case-fold-search t)) 6551 (not (search-forward "Local Variables:" nil t))) 6552 nil 6553 (setq beg (- (point) 16)) 6554 (setq suffix (buffer-substring-no-properties 6555 (point) 6556 (progn (if (search-forward "\n" nil t) 6557 (forward-char -1)) 6558 (point)))) 6559 (setq prefix (buffer-substring-no-properties 6560 (progn (if (search-backward "\n" nil t) 6561 (forward-char 1)) 6562 (point)) 6563 beg)) 6564 (list beg prefix suffix)) 6565 ) 6566 ) 6567 ) 6568;;;_ > allout-adjust-file-variable (varname value) 6569(defun allout-adjust-file-variable (varname value) 6570 "Adjust the setting of an Emacs file variable named VARNAME to VALUE. 6571 6572This activity is inhibited if either `enable-local-variables' 6573`allout-enable-file-variable-adjustment' are nil. 6574 6575When enabled, an entry for the variable is created if not already present, 6576or changed if established with a different value. The section for the file 6577variables, itself, is created if not already present. When created, the 6578section lines (including the section line) exist as second-level topics in 6579a top-level topic at the end of the file. 6580 6581`enable-local-variables' must be true for any of this to happen." 6582 (if (not (and enable-local-variables 6583 allout-enable-file-variable-adjustment)) 6584 nil 6585 (save-excursion 6586 (let ((inhibit-field-text-motion t) 6587 (section-data (allout-file-vars-section-data)) 6588 beg prefix suffix) 6589 (if section-data 6590 (setq beg (car section-data) 6591 prefix (cadr section-data) 6592 suffix (car (cddr section-data))) 6593 ;; create the section 6594 (goto-char (point-max)) 6595 (open-line 1) 6596 (allout-open-topic 0) 6597 (end-of-line) 6598 (insert "Local emacs vars.\n") 6599 (allout-open-topic 1) 6600 (setq beg (point) 6601 suffix "" 6602 prefix (buffer-substring-no-properties (progn 6603 (beginning-of-line) 6604 (point)) 6605 beg)) 6606 (goto-char beg) 6607 (insert "Local variables:\n") 6608 (allout-open-topic 0) 6609 (insert "End:\n") 6610 ) 6611 ;; look for existing entry or create one, leaving point for insertion 6612 ;; of new value: 6613 (goto-char beg) 6614 (allout-show-to-offshoot) 6615 (if (search-forward (concat "\n" prefix varname ":") nil t) 6616 (let* ((value-beg (point)) 6617 (line-end (progn (if (search-forward "\n" nil t) 6618 (forward-char -1)) 6619 (point))) 6620 (value-end (- line-end (length suffix)))) 6621 (if (> value-end value-beg) 6622 (delete-region value-beg value-end))) 6623 (end-of-line) 6624 (open-line 1) 6625 (forward-line 1) 6626 (insert (concat prefix varname ":"))) 6627 (insert (format " %S%s" value suffix)) 6628 ) 6629 ) 6630 ) 6631 ) 6632;;;_ > allout-get-configvar-values (varname) 6633(defun allout-get-configvar-values (configvar-name) 6634 "Return a list of values of the symbols in list bound to CONFIGVAR-NAME. 6635 6636The user is prompted for removal of symbols that are unbound, and they 6637otherwise are ignored. 6638 6639CONFIGVAR-NAME should be the name of the configuration variable, 6640not its value." 6641 6642 (let ((configvar-value (symbol-value configvar-name)) 6643 got) 6644 (dolist (sym configvar-value) 6645 (if (not (boundp sym)) 6646 (if (yes-or-no-p (format "%s entry `%s' is unbound - remove it? " 6647 configvar-name sym)) 6648 (delq sym (symbol-value configvar-name))) 6649 (push (symbol-value sym) got))) 6650 (reverse got))) 6651;;;_ : Topics: 6652;;;_ > allout-mark-topic () 6653(defun allout-mark-topic () 6654 "Put the region around topic currently containing point." 6655 (interactive) 6656 (let ((inhibit-field-text-motion t)) 6657 (beginning-of-line)) 6658 (allout-goto-prefix-doublechecked) 6659 (push-mark (point)) 6660 (allout-end-of-current-subtree) 6661 (exchange-point-and-mark)) 6662;;;_ : UI: 6663;;;_ > solicit-char-in-string (prompt string &optional do-defaulting) 6664(defun solicit-char-in-string (prompt string &optional do-defaulting) 6665 "Solicit (with first arg PROMPT) choice of a character from string STRING. 6666 6667Optional arg DO-DEFAULTING indicates to accept empty input (CR)." 6668 6669 (let ((new-prompt prompt) 6670 got) 6671 6672 (while (not got) 6673 (message "%s" new-prompt) 6674 6675 ;; We do our own reading here, so we can circumvent, eg, special 6676 ;; treatment for `?' character. (Oughta use minibuffer keymap instead.) 6677 (setq got 6678 (char-to-string (let ((cursor-in-echo-area nil)) (read-char)))) 6679 6680 (setq got 6681 (cond ((string-match (regexp-quote got) string) got) 6682 ((and do-defaulting (string= got "\r")) 6683 ;; Return empty string to default: 6684 "") 6685 ((string= got "\C-g") (signal 'quit nil)) 6686 (t 6687 (setq new-prompt (concat prompt 6688 got 6689 " ...pick from: " 6690 string 6691 "")) 6692 nil)))) 6693 ;; got something out of loop - return it: 6694 got) 6695 ) 6696;;;_ : Strings: 6697;;;_ > regexp-sans-escapes (string) 6698(defun regexp-sans-escapes (regexp &optional successive-backslashes) 6699 "Return a copy of REGEXP with all character escapes stripped out. 6700 6701Representations of actual backslashes - '\\\\\\\\' - are left as a 6702single backslash. 6703 6704Optional arg SUCCESSIVE-BACKSLASHES is used internally for recursion." 6705 6706 (if (string= regexp "") 6707 "" 6708 ;; Set successive-backslashes to number if current char is 6709 ;; backslash, or else to nil: 6710 (setq successive-backslashes 6711 (if (= (aref regexp 0) ?\\) 6712 (if successive-backslashes (1+ successive-backslashes) 1) 6713 nil)) 6714 (if (or (not successive-backslashes) (= 2 successive-backslashes)) 6715 ;; Include first char: 6716 (concat (substring regexp 0 1) 6717 (regexp-sans-escapes (substring regexp 1))) 6718 ;; Exclude first char, but maintain count: 6719 (regexp-sans-escapes (substring regexp 1) successive-backslashes)))) 6720;;;_ > count-trailing-whitespace-region (beg end) 6721(defun count-trailing-whitespace-region (beg end) 6722 "Return number of trailing whitespace chars between BEG and END. 6723 6724If BEG is bigger than END we return 0." 6725 (if (> beg end) 6726 0 6727 (save-excursion 6728 (goto-char beg) 6729 (let ((count 0)) 6730 (while (re-search-forward "[ ][ ]*$" end t) 6731 (goto-char (1+ (match-beginning 2))) 6732 (setq count (1+ count))) 6733 count)))) 6734;;;_ > allout-format-quote (string) 6735(defun allout-format-quote (string) 6736 "Return a copy of string with all \"%\" characters doubled." 6737 (apply 'concat 6738 (mapcar (lambda (char) (if (= char ?%) "%%" (char-to-string char))) 6739 string))) 6740;;;_ : lists 6741;;;_ > allout-flatten (list) 6742(defun allout-flatten (list) 6743 "Return a list of all atoms in list." 6744 ;; classic. 6745 (cond ((null list) nil) 6746 ((atom (car list)) (cons (car list) (allout-flatten (cdr list)))) 6747 (t (append (allout-flatten (car list)) (allout-flatten (cdr list)))))) 6748;;;_ : Compatability: 6749;;;_ > allout-mark-marker to accommodate divergent emacsen: 6750(defun allout-mark-marker (&optional force buffer) 6751 "Accommodate the different signature for `mark-marker' across Emacsen. 6752 6753XEmacs takes two optional args, while mainline GNU Emacs does not, 6754so pass them along when appropriate." 6755 (if (featurep 'xemacs) 6756 (apply 'mark-marker force buffer) 6757 (mark-marker))) 6758;;;_ > subst-char-in-string if necessary 6759(if (not (fboundp 'subst-char-in-string)) 6760 (defun subst-char-in-string (fromchar tochar string &optional inplace) 6761 "Replace FROMCHAR with TOCHAR in STRING each time it occurs. 6762Unless optional argument INPLACE is non-nil, return a new string." 6763 (let ((i (length string)) 6764 (newstr (if inplace string (copy-sequence string)))) 6765 (while (> i 0) 6766 (setq i (1- i)) 6767 (if (eq (aref newstr i) fromchar) 6768 (aset newstr i tochar))) 6769 newstr))) 6770;;;_ > wholenump if necessary 6771(if (not (fboundp 'wholenump)) 6772 (defalias 'wholenump 'natnump)) 6773;;;_ > remove-overlays if necessary 6774(if (not (fboundp 'remove-overlays)) 6775 (defun remove-overlays (&optional beg end name val) 6776 "Clear BEG and END of overlays whose property NAME has value VAL. 6777Overlays might be moved and/or split. 6778BEG and END default respectively to the beginning and end of buffer." 6779 (unless beg (setq beg (point-min))) 6780 (unless end (setq end (point-max))) 6781 (if (< end beg) 6782 (setq beg (prog1 end (setq end beg)))) 6783 (save-excursion 6784 (dolist (o (overlays-in beg end)) 6785 (when (eq (overlay-get o name) val) 6786 ;; Either push this overlay outside beg...end 6787 ;; or split it to exclude beg...end 6788 ;; or delete it entirely (if it is contained in beg...end). 6789 (if (< (overlay-start o) beg) 6790 (if (> (overlay-end o) end) 6791 (progn 6792 (move-overlay (copy-overlay o) 6793 (overlay-start o) beg) 6794 (move-overlay o end (overlay-end o))) 6795 (move-overlay o (overlay-start o) beg)) 6796 (if (> (overlay-end o) end) 6797 (move-overlay o end (overlay-end o)) 6798 (delete-overlay o))))))) 6799 ) 6800;;;_ > copy-overlay if necessary - xemacs ~ 21.4 6801(if (not (fboundp 'copy-overlay)) 6802 (defun copy-overlay (o) 6803 "Return a copy of overlay O." 6804 (let ((o1 (make-overlay (overlay-start o) (overlay-end o) 6805 ;; FIXME: there's no easy way to find the 6806 ;; insertion-type of the two markers. 6807 (overlay-buffer o))) 6808 (props (overlay-properties o))) 6809 (while props 6810 (overlay-put o1 (pop props) (pop props))) 6811 o1))) 6812;;;_ > add-to-invisibility-spec if necessary - xemacs ~ 21.4 6813(if (not (fboundp 'add-to-invisibility-spec)) 6814 (defun add-to-invisibility-spec (element) 6815 "Add ELEMENT to `buffer-invisibility-spec'. 6816See documentation for `buffer-invisibility-spec' for the kind of elements 6817that can be added." 6818 (if (eq buffer-invisibility-spec t) 6819 (setq buffer-invisibility-spec (list t))) 6820 (setq buffer-invisibility-spec 6821 (cons element buffer-invisibility-spec)))) 6822;;;_ > remove-from-invisibility-spec if necessary - xemacs ~ 21.4 6823(if (not (fboundp 'remove-from-invisibility-spec)) 6824 (defun remove-from-invisibility-spec (element) 6825 "Remove ELEMENT from `buffer-invisibility-spec'." 6826 (if (consp buffer-invisibility-spec) 6827 (setq buffer-invisibility-spec (delete element 6828 buffer-invisibility-spec))))) 6829;;;_ > move-beginning-of-line if necessary - older emacs, xemacs 6830(if (not (fboundp 'move-beginning-of-line)) 6831 (defun move-beginning-of-line (arg) 6832 "Move point to beginning of current line as displayed. 6833\(This disregards invisible newlines such as those 6834which are part of the text that an image rests on.) 6835 6836With argument ARG not nil or 1, move forward ARG - 1 lines first. 6837If point reaches the beginning or end of buffer, it stops there. 6838To ignore intangibility, bind `inhibit-point-motion-hooks' to t." 6839 (interactive "p") 6840 (or arg (setq arg 1)) 6841 (if (/= arg 1) 6842 (condition-case nil (line-move (1- arg)) (error nil))) 6843 6844 ;; Move to beginning-of-line, ignoring fields and invisibles. 6845 (skip-chars-backward "^\n") 6846 (while (and (not (bobp)) (line-move-invisible-p (1- (point)))) 6847 (goto-char (if (featurep 'xemacs) 6848 (previous-property-change (point)) 6849 (previous-char-property-change (point)))) 6850 (skip-chars-backward "^\n")) 6851 (vertical-motion 0)) 6852) 6853;;;_ > move-end-of-line if necessary - older emacs, xemacs 6854(if (not (fboundp 'move-end-of-line)) 6855 (defun move-end-of-line (arg) 6856 "Move point to end of current line as displayed. 6857\(This disregards invisible newlines such as those 6858which are part of the text that an image rests on.) 6859 6860With argument ARG not nil or 1, move forward ARG - 1 lines first. 6861If point reaches the beginning or end of buffer, it stops there. 6862To ignore intangibility, bind `inhibit-point-motion-hooks' to t." 6863 (interactive "p") 6864 (or arg (setq arg 1)) 6865 (let (done) 6866 (while (not done) 6867 (let ((newpos 6868 (save-excursion 6869 (let ((goal-column 0)) 6870 (and (condition-case nil 6871 (or (line-move arg) t) 6872 (error nil)) 6873 (not (bobp)) 6874 (progn 6875 (while (and (not (bobp)) 6876 (line-move-invisible-p (1- (point)))) 6877 (goto-char 6878 (previous-char-property-change (point)))) 6879 (backward-char 1))) 6880 (point))))) 6881 (goto-char newpos) 6882 (if (and (> (point) newpos) 6883 (eq (preceding-char) ?\n)) 6884 (backward-char 1) 6885 (if (and (> (point) newpos) (not (eobp)) 6886 (not (eq (following-char) ?\n))) 6887 ;; If we skipped something intangible 6888 ;; and now we're not really at eol, 6889 ;; keep going. 6890 (setq arg 1) 6891 (setq done t))))))) 6892 ) 6893;;;_ > line-move-invisible-p if necessary 6894(if (not (fboundp 'line-move-invisible-p)) 6895 (defun line-move-invisible-p (pos) 6896 "Return non-nil if the character after POS is currently invisible." 6897 (let ((prop 6898 (get-char-property pos 'invisible))) 6899 (if (eq buffer-invisibility-spec t) 6900 prop 6901 (or (memq prop buffer-invisibility-spec) 6902 (assq prop buffer-invisibility-spec)))))) 6903 6904;;;_ #10 Unfinished 6905;;;_ > allout-bullet-isearch (&optional bullet) 6906(defun allout-bullet-isearch (&optional bullet) 6907 "Isearch (regexp) for topic with bullet BULLET." 6908 (interactive) 6909 (if (not bullet) 6910 (setq bullet (solicit-char-in-string 6911 "ISearch for topic with bullet: " 6912 (regexp-sans-escapes allout-bullets-string)))) 6913 6914 (let ((isearch-regexp t) 6915 (isearch-string (concat "^" 6916 allout-header-prefix 6917 "[ \t]*" 6918 bullet))) 6919 (isearch-repeat 'forward) 6920 (isearch-mode t))) 6921 6922;;;_ #11 Unit tests - this should be last item before "Provide" 6923;;;_ > allout-run-unit-tests () 6924(defun allout-run-unit-tests () 6925 "Run the various allout unit tests." 6926 (message "Running allout tests...") 6927 (allout-test-resumptions) 6928 (message "Running allout tests... Done.") 6929 (sit-for .5)) 6930;;;_ : test resumptions: 6931;;;_ > allout-tests-obliterate-variable (name) 6932(defun allout-tests-obliterate-variable (name) 6933 "Completely unbind variable with NAME." 6934 (if (local-variable-p name) (kill-local-variable name)) 6935 (while (boundp name) (makunbound name))) 6936;;;_ > allout-test-resumptions () 6937(defvar allout-tests-globally-unbound nil 6938 "Fodder for allout resumptions tests - defvar just for byte compiler.") 6939(defvar allout-tests-globally-true nil 6940 "Fodder for allout resumptions tests - defvar just just for byte compiler.") 6941(defvar allout-tests-locally-true nil 6942 "Fodder for allout resumptions tests - defvar just for byte compiler.") 6943(defun allout-test-resumptions () 6944 "Exercise allout resumptions." 6945 ;; for each resumption case, we also test that the right local/global 6946 ;; scopes are affected during resumption effects: 6947 6948 ;; ensure that previously unbound variables return to the unbound state. 6949 (with-temp-buffer 6950 (allout-tests-obliterate-variable 'allout-tests-globally-unbound) 6951 (allout-add-resumptions '(allout-tests-globally-unbound t)) 6952 (assert (not (default-boundp 'allout-tests-globally-unbound))) 6953 (assert (local-variable-p 'allout-tests-globally-unbound)) 6954 (assert (boundp 'allout-tests-globally-unbound)) 6955 (assert (equal allout-tests-globally-unbound t)) 6956 (allout-do-resumptions) 6957 (assert (not (local-variable-p 'allout-tests-globally-unbound))) 6958 (assert (not (boundp 'allout-tests-globally-unbound)))) 6959 6960 ;; ensure that variable with prior global value is resumed 6961 (with-temp-buffer 6962 (allout-tests-obliterate-variable 'allout-tests-globally-true) 6963 (setq allout-tests-globally-true t) 6964 (allout-add-resumptions '(allout-tests-globally-true nil)) 6965 (assert (equal (default-value 'allout-tests-globally-true) t)) 6966 (assert (local-variable-p 'allout-tests-globally-true)) 6967 (assert (equal allout-tests-globally-true nil)) 6968 (allout-do-resumptions) 6969 (assert (not (local-variable-p 'allout-tests-globally-true))) 6970 (assert (boundp 'allout-tests-globally-true)) 6971 (assert (equal allout-tests-globally-true t))) 6972 6973 ;; ensure that prior local value is resumed 6974 (with-temp-buffer 6975 (allout-tests-obliterate-variable 'allout-tests-locally-true) 6976 (set (make-local-variable 'allout-tests-locally-true) t) 6977 (assert (not (default-boundp 'allout-tests-locally-true)) 6978 nil (concat "Test setup mistake - variable supposed to" 6979 " not have global binding, but it does.")) 6980 (assert (local-variable-p 'allout-tests-locally-true) 6981 nil (concat "Test setup mistake - variable supposed to have" 6982 " local binding, but it lacks one.")) 6983 (allout-add-resumptions '(allout-tests-locally-true nil)) 6984 (assert (not (default-boundp 'allout-tests-locally-true))) 6985 (assert (local-variable-p 'allout-tests-locally-true)) 6986 (assert (equal allout-tests-locally-true nil)) 6987 (allout-do-resumptions) 6988 (assert (boundp 'allout-tests-locally-true)) 6989 (assert (local-variable-p 'allout-tests-locally-true)) 6990 (assert (equal allout-tests-locally-true t)) 6991 (assert (not (default-boundp 'allout-tests-locally-true)))) 6992 6993 ;; ensure that last of multiple resumptions holds, for various scopes. 6994 (with-temp-buffer 6995 (allout-tests-obliterate-variable 'allout-tests-globally-unbound) 6996 (allout-tests-obliterate-variable 'allout-tests-globally-true) 6997 (setq allout-tests-globally-true t) 6998 (allout-tests-obliterate-variable 'allout-tests-locally-true) 6999 (set (make-local-variable 'allout-tests-locally-true) t) 7000 (allout-add-resumptions '(allout-tests-globally-unbound t) 7001 '(allout-tests-globally-true nil) 7002 '(allout-tests-locally-true nil)) 7003 (allout-add-resumptions '(allout-tests-globally-unbound 2) 7004 '(allout-tests-globally-true 3) 7005 '(allout-tests-locally-true 4)) 7006 ;; reestablish many of the basic conditions are maintained after re-add: 7007 (assert (not (default-boundp 'allout-tests-globally-unbound))) 7008 (assert (local-variable-p 'allout-tests-globally-unbound)) 7009 (assert (equal allout-tests-globally-unbound 2)) 7010 (assert (default-boundp 'allout-tests-globally-true)) 7011 (assert (local-variable-p 'allout-tests-globally-true)) 7012 (assert (equal allout-tests-globally-true 3)) 7013 (assert (not (default-boundp 'allout-tests-locally-true))) 7014 (assert (local-variable-p 'allout-tests-locally-true)) 7015 (assert (equal allout-tests-locally-true 4)) 7016 (allout-do-resumptions) 7017 (assert (not (local-variable-p 'allout-tests-globally-unbound))) 7018 (assert (not (boundp 'allout-tests-globally-unbound))) 7019 (assert (not (local-variable-p 'allout-tests-globally-true))) 7020 (assert (boundp 'allout-tests-globally-true)) 7021 (assert (equal allout-tests-globally-true t)) 7022 (assert (boundp 'allout-tests-locally-true)) 7023 (assert (local-variable-p 'allout-tests-locally-true)) 7024 (assert (equal allout-tests-locally-true t)) 7025 (assert (not (default-boundp 'allout-tests-locally-true)))) 7026 7027 ;; ensure that deliberately unbinding registered variables doesn't foul things 7028 (with-temp-buffer 7029 (allout-tests-obliterate-variable 'allout-tests-globally-unbound) 7030 (allout-tests-obliterate-variable 'allout-tests-globally-true) 7031 (setq allout-tests-globally-true t) 7032 (allout-tests-obliterate-variable 'allout-tests-locally-true) 7033 (set (make-local-variable 'allout-tests-locally-true) t) 7034 (allout-add-resumptions '(allout-tests-globally-unbound t) 7035 '(allout-tests-globally-true nil) 7036 '(allout-tests-locally-true nil)) 7037 (allout-tests-obliterate-variable 'allout-tests-globally-unbound) 7038 (allout-tests-obliterate-variable 'allout-tests-globally-true) 7039 (allout-tests-obliterate-variable 'allout-tests-locally-true) 7040 (allout-do-resumptions)) 7041 ) 7042;;;_ % Run unit tests if `allout-run-unit-tests-after-load' is true: 7043(when allout-run-unit-tests-on-load 7044 (allout-run-unit-tests)) 7045 7046;;;_ #12 Provide 7047(provide 'allout) 7048 7049;;;_* Local emacs vars. 7050;; The following `allout-layout' local variable setting: 7051;; - closes all topics from the first topic to just before the third-to-last, 7052;; - shows the children of the third to last (config vars) 7053;; - and the second to last (code section), 7054;; - and closes the last topic (this local-variables section). 7055;;Local variables: 7056;;allout-layout: (0 : -1 -1 0) 7057;;End: 7058 7059;; arch-tag: cf38fbc3-c044-450f-8bff-afed8ba5681c 7060;;; allout.el ends here 7061