Navigation

← Previous Change
Next Change →

allout.el

Timestamp:

2006年07月16日 08時36分52秒 (2 years ago)

Author:

miyoshi

Message:

Sync up with Emacs CVS HEAD.

Files:

trunk/lisp/allout.el (modified) (24 diffs)

Legend:

: Unmodified
: Added
: Removed
: Modified
: Copied
: Moved

trunk/lisp/allout.el

r4085	r4111
9	9	;; Version: 2.2.1
10	10	;; Keywords: outlines wp languages
	11	;; Website: http://myriadicity.net/Sundry/EmacsAllout
11	12
12	13	;; This file is part of GNU Emacs.
…	…
38	39	;; - Customizable bullet format - enables programming-language specific
39	40	;; outlining, for code-folding editing. (Allout code itself is to try it;
40		;; formatted as an outline - do ESC-x eval-~~current-~~buffer in allout.el; but
	41	;; formatted as an outline - do ESC-x eval-buffer in allout.el; but
41	42	;; emacs local file variables need to be enabled when the
42	43	;; file was visited - see `enable-local-variables'.)
…	…
59	60	;;
60	61	;; See the `allout-mode' function's docstring for an introduction to the
61		;; mode. The development version and helpful notes are available at
	62	;; mode.
	63	;;
	64	;; The latest development version and helpful notes are available at
62	65	;; http://myriadicity.net/Sundry/EmacsAllout .
63	66	;;
…	…
73	76	;;
74	77	;; Note - the lines beginning with `;;;_' are outline topic headers.
75		;; Just `ESC-x eval-~~current-~~buffer' to give it a whirl.
	78	;; Just `ESC-x eval-buffer' to give it a whirl.
76	79
77	80	;; ken manheimer (ken dot manheimer at gmail dot com)
…	…
81	84	;;;_* Dependency autoloads
82	85	(require 'overlay)
83		(eval-when-compile (progn (require 'pgg)
84		(require 'pgg-gpg)
85		(require 'overlay)
86		))
	86	(eval-when-compile
	87	;; Most of the requires here are for stuff covered by autoloads.
	88	;; Since just byte-compiling doesn't trigger autoloads, so that
	89	;; "function not found" warnings would occur without these requires.
	90	(progn
	91	(require 'pgg)
	92	(require 'pgg-gpg)
	93	(require 'overlay)
	94	;; `cl' is required for `assert'. `assert' is not covered by a standard
	95	;; autoload, but it is a macro, so that eval-when-compile is sufficient
	96	;; to byte-compile it in, or to do the require when the buffer evalled.
	97	(require 'cl)
	98	))
87	99
88	100	;;;_* USER CUSTOMIZATION VARIABLES:
…	…
557	569	(make-variable-buffer-local 'allout-encrypt-unencrypted-on-saves)
558	570
	571	;;;_ + Developer
	572	;;;_ = allout-developer group
	573	(defgroup allout-developer nil
	574	"Settings for topic encryption features of allout outliner."
	575	:group 'allout)
	576	;;;_ = allout-run-unit-tests-on-load
	577	(defcustom allout-run-unit-tests-on-load nil
	578	"*When non-nil, unit tests will be run at end of loading the allout module.
	579
	580	Generally, allout code developers are the only ones who'll want to set this.
	581
	582	\(If set, this makes it an even better practice to exercise changes by
	583	doing byte-compilation with a repeat count, so the file is loaded at the
	584	of compilation.)
	585
	586	See `allout-run-unit-tests' to see what's run."
	587	:type 'boolean
	588	:group 'allout-developer)
	589
559	590	;;;_ + Miscellaneous customization
560	591
…	…
615	646	("=t" allout-latexify-exposed)
616	647	("=p" allout-flatten-exposed-to-buffer)))
	648
	649	;;;_ = allout-inhibit-auto-fill
	650	(defcustom allout-inhibit-auto-fill nil
	651	"*If non-nil, auto-fill will be inhibited in the allout buffers.
	652
	653	You can customize this setting to set it for all allout buffers, or set it
	654	in individual buffers if you want to inhibit auto-fill only in particular
	655	buffers. \(You could use a function on `allout-mode-hook' to inhibit
	656	auto-fill according, eg, to the major mode.\)
	657
	658	If you don't set this and auto-fill-mode is enabled, allout will use the
	659	value that `normal-auto-fill-function', if any, when allout mode starts, or
	660	else allout's special hanging-indent maintaining auto-fill function,
	661	`allout-auto-fill'."
	662	:type 'boolean
	663	:group 'allout)
	664	(make-variable-buffer-local 'allout-inhibit-auto-fill)
617	665
618	666	;;;_ = allout-use-hanging-indents
…	…
994	1042	["Set Header Lead" allout-reset-header-lead t]
995	1043	["Set New Exposure" allout-expose-topic t])))
996		;;;_ : ~~Mode-Specific Variable Maintenance~~ Utilities
	1044	;;;_ : Allout Modal-Variables Utilities
997	1045	;;;_ = allout-mode-prior-settings
998	1046	(defvar allout-mode-prior-settings nil
999		"Internal `allout-mode' use; settings to be resumed on mode deactivation.")
	1047	"Internal `allout-mode' use; settings to be resumed on mode deactivation.
	1048
	1049	See `allout-add-resumptions' and `allout-do-resumptions'.")
1000	1050	(make-variable-buffer-local 'allout-mode-prior-settings)
1001		;;;_ > allout-resumptions (name &optional value)
1002		(defun allout-resumptions (name &optional value)
1003
1004		"Registers or resumes settings over `allout-mode' activation/deactivation.
1005
1006		First arg is NAME of variable affected. Optional second arg is list
1007		containing allout-mode-specific VALUE to be imposed on named
1008		variable, and to be registered. \(It's a list so you can specify
1009		registrations of null values.) If no value is specified, the
1010		registered value is returned (encapsulated in the list, so the caller
1011		can distinguish nil vs no value), and the registration is popped
1012		from the list."
1013
1014		(let ((on-list (assq name allout-mode-prior-settings))
1015		prior-capsule ; By `capsule' i mean a list
1016		; containing a value, so we can
1017		; distinguish nil from no value.
1018		)
1019
1020		(if value
1021
1022		;; Registering:
1023		(progn
1024		(if on-list
1025		nil ; Already preserved prior value - don't mess with it.
1026		;; Register the old value, or nil if previously unbound:
1027		(setq allout-mode-prior-settings
1028		(cons (list name
1029		(if (boundp name) (list (symbol-value name))))
1030		allout-mode-prior-settings)))
1031		; And impose the new value, locally:
1032		(progn (make-local-variable name)
1033		(set name (car value))))
1034
1035		;; Relinquishing:
1036		(if (not on-list)
1037
1038		;; Oops, not registered - leave it be:
1039		nil
1040
1041		;; Some registration:
1042		; reestablish it:
1043		(setq prior-capsule (car (cdr on-list)))
1044		(if prior-capsule
1045		(set name (car prior-capsule)) ; Some prior value - reestablish it.
1046		(makunbound name)) ; Previously unbound - demolish var.
1047		; Remove registration:
1048		(let (rebuild)
1049		(while allout-mode-prior-settings
1050		(if (not (eq (car allout-mode-prior-settings)
1051		on-list))
1052		(setq rebuild
1053		(cons (car allout-mode-prior-settings)
1054		rebuild)))
1055		(setq allout-mode-prior-settings
1056		(cdr allout-mode-prior-settings)))
1057		(setq allout-mode-prior-settings rebuild)))))
1058		)
	1051	;;;_ > allout-add-resumptions (&rest pairs)
	1052	(defun allout-add-resumptions (&rest pairs)
	1053	"Set name/value pairs.
	1054
	1055	Old settings are preserved for later resumption using `allout-do-resumptions'.
	1056
	1057	The pairs are lists whose car is the name of the variable and car of the
	1058	cdr is the new value: '(some-var some-value)'.
	1059
	1060	The new value is set as a buffer local.
	1061
	1062	If the variable was not previously buffer-local, then that is noted and the
	1063	`allout-do-resumptions' will just `kill-local-variable' of that binding.
	1064
	1065	If it previously was buffer-local, the old value is noted and resurrected
	1066	by `allout-do-resumptions'. \(If the local value was previously void, then
	1067	it is left as nil on resumption.\)
	1068
	1069	The settings are stored on `allout-mode-prior-settings'."
	1070	(while pairs
	1071	(let* ((pair (pop pairs))
	1072	(name (car pair))
	1073	(value (cadr pair)))
	1074	(if (not (symbolp name))
	1075	(error "Pair's name, %S, must be a symbol, not %s"
	1076	name (type-of name)))
	1077	(when (not (assoc name allout-mode-prior-settings))
	1078	;; Not already added as a resumption, create the prior setting entry.
	1079	(if (local-variable-p name)
	1080	;; is already local variable - preserve the prior value:
	1081	(push (list name (condition-case err
	1082	(symbol-value name)
	1083	(void-variable nil)))
	1084	allout-mode-prior-settings)
	1085	;; wasn't local variable, indicate so for resumption by killing
	1086	;; local value, and make it local:
	1087	(push (list name) allout-mode-prior-settings)
	1088	(make-local-variable name)))
	1089	(set name value))))
	1090	;;;_ > allout-do-resumptions ()
	1091	(defun allout-do-resumptions ()
	1092	"Resume all name/value settings registered by `allout-add-resumptions'.
	1093
	1094	This is used when concluding allout-mode, to resume selected variables to
	1095	their settings before allout-mode was started."
	1096
	1097	(while allout-mode-prior-settings
	1098	(let* ((pair (pop allout-mode-prior-settings))
	1099	(name (car pair))
	1100	(value-cell (cdr pair)))
	1101	(if (not value-cell)
	1102	;; Prior value was global:
	1103	(kill-local-variable name)
	1104	;; Prior value was explicit:
	1105	(set name (car value-cell))))))
1059	1106	;;;_ : Mode-specific incidentals
1060	1107	;;;_ > allout-unprotected (expr)
…	…
1066	1113	(defvar allout-mode-hook nil
1067	1114	"*Hook that's run when allout mode starts.")
1068		;;;_ = allout-overlay-category
1069		(defvar allout-overlay-category nil
1070		"Symbol for use in allout invisible-text overlays as the category.")
	1115	;;;_ = allout-mode-deactivate-hook
	1116	(defvar allout-mode-deactivate-hook nil
	1117	"*Hook that's run when allout mode ends.")
	1118	;;;_ = allout-exposure-category
	1119	(defvar allout-exposure-category nil
	1120	"Symbol for use as allout invisible-text overlay category.")
1071	1121	;;;_ x allout-view-change-hook
1072	1122	(defvar allout-view-change-hook nil
…	…
1294	1344	menus (cdr menus))
1295	1345	(easy-menu-add cur))))
1296		;;;_ > allout-~~set-overlay-category~~
1297		(defun allout-~~set-overlay-category~~ ()
1298		"Set the properties of the allout invisible-text overlay."
1299		(setplist 'allout-~~overlay~~-category nil)
1300		(put 'allout-~~overlay~~-category 'invisible 'allout)
1301		(put 'allout-~~overlay~~-category 'evaporate t)
	1346	;;;_ > allout-overlay-preparations
	1347	(defun allout-overlay-preparations ()
	1348	"Set the properties of the allout invisible-text overlay and others."
	1349	(setplist 'allout-exposure-category nil)
	1350	(put 'allout-exposure-category 'invisible 'allout)
	1351	(put 'allout-exposure-category 'evaporate t)
1302	1352	;; XXX We use isearch-open-invisible and isearch-mode-end-hook. The
1303	1353	;; latter would be sufficient, but it seems that a separate behavior -
…	…
1306	1356	;; property controls the isearch _arrival_ behavior. This is the case at
1307	1357	;; least in emacs 21, 22.0, and xemacs 21.4.
1308		(put 'allout-~~overlay~~-category 'isearch-open-invisible
	1358	(put 'allout-exposure-category 'isearch-open-invisible
1309	1359	'allout-isearch-end-handler)
1310	1360	(if (featurep 'xemacs)
1311		(put 'allout-~~overlay~~-category 'start-open t)
1312		(put 'allout-~~overlay~~-category 'insert-in-front-hooks
	1361	(put 'allout-exposure-category 'start-open t)
	1362	(put 'allout-exposure-category 'insert-in-front-hooks
1313	1363	'(allout-overlay-insert-in-front-handler)))
1314		(if (featurep 'xemacs)
1315		(progn (make-variable-buffer-local 'before-change-functions)
1316		(add-hook 'before-change-functions
1317		'allout-before-change-handler))
1318		(put 'allout-overlay-category 'modification-hooks
1319		'(allout-overlay-interior-modification-handler))))
	1364	(put 'allout-exposure-category 'modification-hooks
	1365	'(allout-overlay-interior-modification-handler)))
1320	1366	;;;_ > allout-mode (&optional toggle)
1321	1367	;;;_ : Defun:
…	…
1576	1622	; specifically requested:
1577	1623	(setq allout-explicitly-deactivated t)
1578		(if (string-match "^18\." emacs-version)
1579		; Revoke those keys that remain
1580		; as we set them:
1581		(let ((curr-loc (current-local-map)))
1582		(mapcar (function
1583		(lambda (cell)
1584		(if (eq (lookup-key curr-loc (car cell))
1585		(car (cdr cell)))
1586		(define-key curr-loc (car cell)
1587		(assq (car cell) allout-prior-bindings)))))
1588		allout-added-bindings)
1589		(allout-resumptions 'allout-added-bindings)
1590		(allout-resumptions 'allout-prior-bindings)))
1591
1592		(if allout-old-style-prefixes
1593		(progn
1594		(allout-resumptions 'allout-primary-bullet)
1595		(allout-resumptions 'allout-old-style-prefixes)))
1596		;;(allout-resumptions 'selective-display)
	1624
	1625	(allout-do-resumptions)
	1626
1597	1627	(remove-from-invisibility-spec '(allout . t))
1598		(set write-file-hook-var-name
1599		(delq 'allout-write-file-hook-handler
1600		(symbol-value write-file-hook-var-name)))
1601		(setq auto-save-hook
1602		(delq 'allout-auto-save-hook-handler
1603		auto-save-hook))
1604		(allout-resumptions 'paragraph-start)
1605		(allout-resumptions 'paragraph-separate)
1606		(allout-resumptions 'auto-fill-function)
1607		(allout-resumptions 'normal-auto-fill-function)
1608		(allout-resumptions 'allout-former-auto-filler)
	1628	(remove-hook 'pre-command-hook 'allout-pre-command-business t)
	1629	(remove-hook 'post-command-hook 'allout-post-command-business t)
	1630	(when (featurep 'xemacs)
	1631	(remove-hook 'before-change-functions 'allout-before-change-handler t))
	1632	(remove-hook 'isearch-mode-end-hook 'allout-isearch-end-handler t)
	1633	(remove-hook write-file-hook-var-name 'allout-write-file-hook-handler t)
	1634	(remove-hook 'auto-save-hook 'allout-auto-save-hook-handler t)
	1635
	1636	(remove-overlays (point-min) (point-max)
	1637	'category 'allout-exposure-category)
	1638
	1639	(run-hooks 'allout-mode-deactivate-hook)
1609	1640	(setq allout-mode nil))
1610	1641
…	…
1613	1644	(setq allout-explicitly-deactivated nil)
1614	1645	(if allout-old-style-prefixes
1615		~~(progn~~ ; Inhibit all the fancy formatting:
1616		~~(allout-resumptions 'allout-primary-bullet '("*")~~)
1617		~~(allout-resumptions 'allout-old-style-prefixes '(~~()))))
1618
1619		(allout-~~set-overlay-category~~) ; Doesn't hurt to redo this.
	1646	;; Inhibit all the fancy formatting:
	1647	(allout-add-resumptions '((allout-primary-bullet "*")
	1648	(allout-old-style-prefixes ()))))
	1649
	1650	(allout-overlay-preparations) ; Doesn't hurt to redo this.
1620	1651
1621	1652	(allout-infer-header-lead)
…	…
1624	1655	(set-allout-regexp)
1625	1656
1626		; Produce map from current version
1627		; of allout-keybindings-list:
1628		(if (boundp 'minor-mode-map-alist)
1629
1630		(progn ; V19, and maybe lucid and
1631		; epoch, minor-mode key bindings:
1632		(setq allout-mode-map
1633		(produce-allout-mode-map allout-keybindings-list))
1634		(substitute-key-definition 'beginning-of-line
1635		'move-beginning-of-line
1636		allout-mode-map global-map)
1637		(substitute-key-definition 'end-of-line
1638		'move-end-of-line
1639		allout-mode-map global-map)
1640		(produce-allout-mode-menubar-entries)
1641		(fset 'allout-mode-map allout-mode-map)
1642		; Include on minor-mode-map-alist,
1643		; if not already there:
1644		(if (not (member '(allout-mode . allout-mode-map)
1645		minor-mode-map-alist))
1646		(setq minor-mode-map-alist
1647		(cons '(allout-mode . allout-mode-map)
1648		minor-mode-map-alist))))
1649
1650		; V18 minor-mode key bindings:
1651		; Stash record of added bindings
1652		; for later revocation:
1653		(allout-resumptions 'allout-added-bindings
1654		(list allout-keybindings-list))
1655		(allout-resumptions 'allout-prior-bindings
1656		(list (current-local-map)))
1657		; and add them:
1658		(use-local-map (produce-allout-mode-map allout-keybindings-list
1659		(current-local-map)))
1660		)
	1657	;; Produce map from current version of allout-keybindings-list:
	1658	(setq allout-mode-map
	1659	(produce-allout-mode-map allout-keybindings-list))
	1660	(substitute-key-definition 'beginning-of-line
	1661	'move-beginning-of-line
	1662	allout-mode-map global-map)
	1663	(substitute-key-definition 'end-of-line
	1664	'move-end-of-line
	1665	allout-mode-map global-map)
	1666	(produce-allout-mode-menubar-entries)
	1667	(fset 'allout-mode-map allout-mode-map)
	1668
	1669	;; Include on minor-mode-map-alist, if not already there:
	1670	(if (not (member '(allout-mode . allout-mode-map)
	1671	minor-mode-map-alist))
	1672	(setq minor-mode-map-alist
	1673	(cons '(allout-mode . allout-mode-map)
	1674	minor-mode-map-alist)))
1661	1675
1662	1676	(add-to-invisibility-spec '(allout . t))
1663		(make-local-variable 'line-move-ignore-invisible)
1664		(setq line-move-ignore-invisible t)
1665		(add-hook 'pre-command-hook 'allout-pre-command-business)
1666		(add-hook 'post-command-hook 'allout-post-command-business)
1667		(add-hook 'isearch-mode-end-hook 'allout-isearch-end-handler)
1668		(add-hook write-file-hook-var-name 'allout-write-file-hook-handler)
1669		(add-hook 'auto-save-hook 'allout-auto-save-hook-handler)
1670		; Custom auto-fill func, to support
1671		; respect for topic headline,
1672		; hanging-indents, etc:
1673		;; Register prevailing fill func for use by allout-auto-fill:
1674		(allout-resumptions 'allout-former-auto-filler (list auto-fill-function))
1675		;; Register allout-auto-fill to be used if filling is active:
1676		(allout-resumptions 'auto-fill-function '(allout-auto-fill))
1677		(allout-resumptions 'allout-outside-normal-auto-fill-function
1678		(list normal-auto-fill-function))
1679		(allout-resumptions 'normal-auto-fill-function '(allout-auto-fill))
1680		;; Paragraphs are broken by topic headlines.
1681		(make-local-variable 'paragraph-start)
1682		(allout-resumptions 'paragraph-start
1683		(list (concat paragraph-start "\\\|^\\("
1684		allout-regexp "\\)")))
1685		(make-local-variable 'paragraph-separate)
1686		(allout-resumptions 'paragraph-separate
1687		(list (concat paragraph-separate "\\\|^\\("
1688		allout-regexp "\\)")))
1689
	1677	(allout-add-resumptions '(line-move-ignore-invisible t))
	1678	(add-hook 'pre-command-hook 'allout-pre-command-business nil t)
	1679	(add-hook 'post-command-hook 'allout-post-command-business nil t)
	1680	(when (featurep 'xemacs)
	1681	(add-hook 'before-change-functions 'allout-before-change-handler
	1682	nil t))
	1683	(add-hook 'isearch-mode-end-hook 'allout-isearch-end-handler nil t)
	1684	(add-hook write-file-hook-var-name 'allout-write-file-hook-handler
	1685	nil t)
	1686	(add-hook 'auto-save-hook 'allout-auto-save-hook-handler
	1687	nil t)
	1688
	1689	;; Stash auto-fill settings and adjust so custom allout auto-fill
	1690	;; func will be used if auto-fill is active or activated. (The
	1691	;; custom func respects topic headline, maintains hanging-indents,
	1692	;; etc.)
	1693	(if (and auto-fill-function (not allout-inhibit-auto-fill))
	1694	;; allout-auto-fill will use the stashed values and so forth.
	1695	(allout-add-resumptions '(auto-fill-function allout-auto-fill)))
	1696	(allout-add-resumptions (list 'allout-former-auto-filler
	1697	auto-fill-function)
	1698	;; Register allout-auto-fill to be used if
	1699	;; filling is active:
	1700	(list 'allout-outside-normal-auto-fill-function
	1701	normal-auto-fill-function)
	1702	'(normal-auto-fill-function allout-auto-fill)
	1703	;; Paragraphs are broken by topic headlines.
	1704	(list 'paragraph-start
	1705	(concat paragraph-start "\\\|^\\("
	1706	allout-regexp "\\)"))
	1707	(list 'paragraph-separate
	1708	(concat paragraph-separate "\\\|^\\("
	1709	allout-regexp "\\)")))
1690	1710	(or (assq 'allout-mode minor-mode-alist)
1691	1711	(setq minor-mode-alist
…	…
1703	1723	((setq do-layout t)
1704	1724	(allout-infer-body-reindent))
1705		) ; cond
1706
	1725	) ;; end of activation-mode cases.
	1726
	1727	;; Do auto layout if warranted:
1707	1728	(let ((use-layout (if (listp allout-layout)
1708	1729	allout-layout
…	…
1803	1824	This before-change handler is used only where modification-hooks
1804	1825	overlay property is not supported."
1805		(if (not (allout-mode-p))
1806		nil
1807		(allout-overlay-interior-modification-handler nil nil beg end nil)))
	1826	;; allout-overlay-interior-modification-handler on an overlay handles
	1827	;; this in other emacs, via `allout-exposure-category's 'modification-hooks.
	1828	(when (and (featurep 'xemacs) (allout-mode-p))
	1829	;; process all of the pending overlays:
	1830	(dolist (overlay (overlays-in beg end))
	1831	(if (eq (overlay-get ol 'invisible) 'allout)
	1832	(allout-overlay-interior-modification-handler
	1833	overlay nil beg end nil)))))
1808	1834	;;;_ > allout-isearch-end-handler (&optional overlay)
1809	1835	(defun allout-isearch-end-handler (&optional overlay)
…	…
2019	2045	;;;_ > allout-next-heading ()
2020	2046	(defsubst allout-next-heading ()
2021		"Move to the heading for the topic \(possibly invisible) ~~before~~ this one.
	2047	"Move to the heading for the topic \(possibly invisible) after this one.
2022	2048
2023	2049	Returns the location of the heading, or nil if none found."
2024	2050
2025		(if (and (bobp) (not (eobp)))
2026		(forward-char 1))
	2051	(if (and (bobp) (not (eobp)) (looking-at allout-regexp))
	2052	(forward-char 1))
2027	2053
2028	2054	(if (re-search-forward allout-line-boundary-regexp nil 0)
…	…
2689	2715	(if (not (allout-mode-p))
2690	2716	nil
2691		~~;; Hot-spot navigation provisions:~~
2692	2717	(if (and (eq this-command 'self-insert-command)
2693	2718	(eq (point)(allout-current-bullet-pos)))
2694		(let* ((this-key-num (cond
2695		((numberp last-command-char)
2696		last-command-char)
2697		;; Only xemacs has characterp.
2698		((and (fboundp 'characterp)
2699		(apply 'characterp
2700		(list last-command-char)))
2701		(apply 'char-to-int (list last-command-char)))
2702		(t 0)))
2703		mapped-binding)
2704		(if (zerop this-key-num)
2705		nil
2706		; Map upper-register literals
2707		; to lower register:
2708		(if (<= 96 this-key-num)
2709		(setq this-key-num (- this-key-num 32)))
2710		; Check if we have a literal:
2711		(if (and (<= 64 this-key-num)
2712		(>= 96 this-key-num))
2713		(setq mapped-binding
2714		(lookup-key 'allout-mode-map
2715		(concat allout-command-prefix
2716		(char-to-string (- this-key-num
2717		64))))))
2718		(if mapped-binding
2719		(setq allout-post-goto-bullet t
2720		this-command mapped-binding)))))))
	2719	(allout-hotspot-key-handler))))
	2720	;;;_ > allout-hotspot-key-handler ()
	2721	(defun allout-hotspot-key-handler ()
	2722	"Catchall handling of key bindings in hot-spots.
	2723
	2724	Translates unmodified keystrokes to corresponding allout commands, when
	2725	they would qualify if prefixed with the allout-command-prefix, and sets
	2726	this-command accordingly.
	2727
	2728	Returns the qualifying command, if any, else nil."
	2729	(interactive)
	2730	(let* ((key-num (cond ((numberp last-command-char) last-command-char)
	2731	;; for XEmacs character type:
	2732	((and (fboundp 'characterp)
	2733	(apply 'characterp (list last-command-char)))
	2734	(apply 'char-to-int (list last-command-char)))
	2735	(t 0)))
	2736	mapped-binding
	2737	(on-bullet (eq (point) (allout-current-bullet-pos))))
	2738
	2739	(if (zerop key-num)
	2740	nil
	2741
	2742	(if (and (<= 33 key-num)
	2743	(setq mapped-binding
	2744	(key-binding (concat allout-command-prefix
	2745	(char-to-string
	2746	(if (and (<= 97 key-num) ; "a"
	2747	(>= 122 key-num)) ; "z"
	2748	(- key-num 96) key-num)))
	2749	t)))
	2750	;; Qualified with the allout prefix - do hot-spot operation.
	2751	(setq allout-post-goto-bullet t)
	2752	;; accept-defaults nil, or else we'll get allout-item-icon-key-handler.
	2753	(setq mapped-binding (key-binding (char-to-string key-num))))
	2754
	2755	(while (keymapp mapped-binding)
	2756	(setq mapped-binding
	2757	(lookup-key mapped-binding (read-key-sequence-vector nil t))))
	2758
	2759	(if mapped-binding
	2760	(setq allout-post-goto-bullet on-bullet
	2761	this-command mapped-binding)))))
	2762
2721	2763	;;;_ > allout-find-file-hook ()
2722	2764	(defun allout-find-file-hook ()
…	…
3147	3189	Maintains outline hanging topic indentation if
3148	3190	`allout-use-hanging-indents' is set."
3149		(let ((fill-prefix (if allout-use-hanging-indents
3150		;; Check for topic header indentation:
3151		(save-excursion
3152		(beginning-of-line)
3153		(if (looking-at allout-regexp)
3154		;; ... construct indentation to account for
3155		;; length of topic prefix:
3156		(make-string (progn (allout-end-of-prefix)
3157		(current-column))
3158		?\ )))))
3159		(use-auto-fill-function (or allout-outside-normal-auto-fill-function
3160		auto-fill-function
3161		'do-auto-fill)))
3162		(if (or allout-former-auto-filler allout-use-hanging-indents)
3163		(funcall use-auto-fill-function))))
	3191
	3192	(when (not allout-inhibit-auto-fill)
	3193	(let ((fill-prefix (if allout-use-hanging-indents
	3194	;; Check for topic header indentation:
	3195	(save-excursion
	3196	(beginning-of-line)
	3197	(if (looking-at allout-regexp)
	3198	;; ... construct indentation to account for
	3199	;; length of topic prefix:
	3200	(make-string (progn (allout-end-of-prefix)
	3201	(current-column))
	3202	?\ )))))
	3203	(use-auto-fill-function (or allout-outside-normal-auto-fill-function
	3204	auto-fill-function
	3205	'do-auto-fill)))
	3206	(if (or allout-former-auto-filler allout-use-hanging-indents)
	3207	(funcall use-auto-fill-function)))))
3164	3208	;;;_ > allout-reindent-body (old-depth new-depth &optional number)
3165	3209	(defun allout-reindent-body (old-depth new-depth &optional number)
…	…
3602	3646
3603	3647	(if collapsed
3604		(put-text-property beg (1+ beg) 'allout-was-collapsed t)
3605		(remove-text-properties beg (1+ beg) '(allout-was-collapsed t)))
	3648	(allout-unprotected
	3649	(put-text-property beg (1+ beg) 'allout-was-collapsed t))
	3650	(allout-unprotected
	3651	(remove-text-properties beg (1+ beg) '(allout-was-collapsed t))))
3606	3652	(allout-unprotected (kill-region beg (point)))
3607	3653	(sit-for 0)
…	…
3835	3881	Text is shown if flag is nil and hidden otherwise."
3836	3882	;; We use outline invisibility spec.
3837		(remove-overlays from to 'category 'allout-~~overlay~~-category)
	3883	(remove-overlays from to 'category 'allout-exposure-category)
3838	3884	(when flag
3839	3885	(let ((o (make-overlay from to)))
3840		(overlay-put o 'category 'allout-~~overlay~~-category)
	3886	(overlay-put o 'category 'allout-exposure-category)
3841	3887	(when (featurep 'xemacs)
3842		(let ((props (symbol-plist 'allout-~~overlay~~-category)))
	3888	(let ((props (symbol-plist 'allout-exposure-category)))
3843	3889	(while props
3844	3890	(overlay-put o (pop props) (pop props)))))))
…	…
3861	3907
3862	3908	;;;_ - Topic-specific
3863		;;;_ > allout-show-entry (~~&optional inclusive~~)
3864		(defun allout-show-entry (~~&optional inclusive~~)
3865		"Like `allout-show-current-entry', ~~reveals entries nested~~ in hidden topics.
	3909	;;;_ > allout-show-entry ()
	3910	(defun allout-show-entry ()
	3911	"Like `allout-show-current-entry', but reveals entries in hidden topics.
3866	3912
3867	3913	This is a way to give restricted peek at a concealed locality without the
…	…
3978	4024	;;;_ > allout-show-current-entry (&optional arg)
3979	4025	(defun allout-show-current-entry (&optional arg)
3980
3981	4026	"Show body following current heading, or hide entry with universal argument."
3982	4027
…	…
5920	5965	(isearch-mode t)))
5921	5966
5922		;;;_ #11 Provide
	5967	;;;_ #11 Unit tests - this should be last item before "Provide"
	5968	;;;_ > allout-run-unit-tests ()
	5969	(defun allout-run-unit-tests ()
	5970	"Run the various allout unit tests."
	5971	(message "Running allout tests...")
	5972	(allout-test-resumptions)
	5973	(message "Running allout tests... Done.")
	5974	(sit-for .5))
	5975	;;;_ : test resumptions:
	5976	;;;_ > allout-tests-obliterate-variable (name)
	5977	(defun allout-tests-obliterate-variable (name)
	5978	"Completely unbind variable with NAME."
	5979	(if (local-variable-p name) (kill-local-variable name))
	5980	(while (boundp name) (makunbound name)))
	5981	;;;_ > allout-test-resumptions ()
	5982	(defvar allout-tests-globally-unbound nil
	5983	"Fodder for allout resumptions tests - defvar just for byte compiler.")
	5984	(defvar allout-tests-globally-true nil
	5985	"Fodder for allout resumptions tests - defvar just just for byte compiler.")
	5986	(defvar allout-tests-locally-true nil
	5987	"Fodder for allout resumptions tests - defvar just for byte compiler.")
	5988	(defun allout-test-resumptions ()
	5989	"Exercise allout resumptions."
	5990	;; for each resumption case, we also test that the right local/global
	5991	;; scopes are affected during resumption effects:
	5992
	5993	;; ensure that previously unbound variables return to the unbound state.
	5994	(with-temp-buffer
	5995	(allout-tests-obliterate-variable 'allout-tests-globally-unbound)
	5996	(allout-add-resumptions '(allout-tests-globally-unbound t))
	5997	(assert (not (default-boundp 'allout-tests-globally-unbound)))
	5998	(assert (local-variable-p 'allout-tests-globally-unbound))
	5999	(assert (boundp 'allout-tests-globally-unbound))
	6000	(assert (equal allout-tests-globally-unbound t))
	6001	(allout-do-resumptions)
	6002	(assert (not (local-variable-p 'allout-tests-globally-unbound)))
	6003	(assert (not (boundp 'allout-tests-globally-unbound))))
	6004
	6005	;; ensure that variable with prior global value is resumed
	6006	(with-temp-buffer
	6007	(allout-tests-obliterate-variable 'allout-tests-globally-true)
	6008	(setq allout-tests-globally-true t)
	6009	(allout-add-resumptions '(allout-tests-globally-true nil))
	6010	(assert (equal (default-value 'allout-tests-globally-true) t))
	6011	(assert (local-variable-p 'allout-tests-globally-true))
	6012	(assert (equal allout-tests-globally-true nil))
	6013	(allout-do-resumptions)
	6014	(assert (not (local-variable-p 'allout-tests-globally-true)))
	6015	(assert (boundp 'allout-tests-globally-true))
	6016	(assert (equal allout-tests-globally-true t)))
	6017
	6018	;; ensure that prior local value is resumed
	6019	(with-temp-buffer
	6020	(allout-tests-obliterate-variable 'allout-tests-locally-true)
	6021	(set (make-local-variable 'allout-tests-locally-true) t)
	6022	(assert (not (default-boundp 'allout-tests-locally-true))
	6023	nil (concat "Test setup mistake - variable supposed to"
	6024	" not have global binding, but it does."))
	6025	(assert (local-variable-p 'allout-tests-locally-true)
	6026	nil (concat "Test setup mistake - variable supposed to have"
	6027	" local binding, but it lacks one."))
	6028	(allout-add-resumptions '(allout-tests-locally-true nil))
	6029	(assert (not (default-boundp 'allout-tests-locally-true)))
	6030	(assert (local-variable-p 'allout-tests-locally-true))
	6031	(assert (equal allout-tests-locally-true nil))
	6032	(allout-do-resumptions)
	6033	(assert (boundp 'allout-tests-locally-true))
	6034	(assert (local-variable-p 'allout-tests-locally-true))
	6035	(assert (equal allout-tests-locally-true t))
	6036	(assert (not (default-boundp 'allout-tests-locally-true))))
	6037
	6038	;; ensure that last of multiple resumptions holds, for various scopes.
	6039	(with-temp-buffer
	6040	(allout-tests-obliterate-variable 'allout-tests-globally-unbound)
	6041	(allout-tests-obliterate-variable 'allout-tests-globally-true)
	6042	(setq allout-tests-globally-true t)
	6043	(allout-tests-obliterate-variable 'allout-tests-locally-true)
	6044	(set (make-local-variable 'allout-tests-locally-true) t)
	6045	(allout-add-resumptions '(allout-tests-globally-unbound t)
	6046	'(allout-tests-globally-true nil)
	6047	'(allout-tests-locally-true nil))
	6048	(allout-add-resumptions '(allout-tests-globally-unbound 2)
	6049	'(allout-tests-globally-true 3)
	6050	'(allout-tests-locally-true 4))
	6051	;; reestablish many of the basic conditions are maintained after re-add:
	6052	(assert (not (default-boundp 'allout-tests-globally-unbound)))
	6053	(assert (local-variable-p 'allout-tests-globally-unbound))
	6054	(assert (equal allout-tests-globally-unbound 2))
	6055	(assert (default-boundp 'allout-tests-globally-true))
	6056	(assert (local-variable-p 'allout-tests-globally-true))
	6057	(assert (equal allout-tests-globally-true 3))
	6058	(assert (not (default-boundp 'allout-tests-locally-true)))
	6059	(assert (local-variable-p 'allout-tests-locally-true))
	6060	(assert (equal allout-tests-locally-true 4))
	6061	(allout-do-resumptions)
	6062	(assert (not (local-variable-p 'allout-tests-globally-unbound)))
	6063	(assert (not (boundp 'allout-tests-globally-unbound)))
	6064	(assert (not (local-variable-p 'allout-tests-globally-true)))
	6065	(assert (boundp 'allout-tests-globally-true))
	6066	(assert (equal allout-tests-globally-true t))
	6067	(assert (boundp 'allout-tests-locally-true))
	6068	(assert (local-variable-p 'allout-tests-locally-true))
	6069	(assert (equal allout-tests-locally-true t))
	6070	(assert (not (default-boundp 'allout-tests-locally-true))))
	6071
	6072	;; ensure that deliberately unbinding registered variables doesn't foul things
	6073	(with-temp-buffer
	6074	(allout-tests-obliterate-variable 'allout-tests-globally-unbound)
	6075	(allout-tests-obliterate-variable 'allout-tests-globally-true)
	6076	(setq allout-tests-globally-true t)
	6077	(allout-tests-obliterate-variable 'allout-tests-locally-true)
	6078	(set (make-local-variable 'allout-tests-locally-true) t)
	6079	(allout-add-resumptions '(allout-tests-globally-unbound t)
	6080	'(allout-tests-globally-true nil)
	6081	'(allout-tests-locally-true nil))
	6082	(allout-tests-obliterate-variable 'allout-tests-globally-unbound)
	6083	(allout-tests-obliterate-variable 'allout-tests-globally-true)
	6084	(allout-tests-obliterate-variable 'allout-tests-locally-true)
	6085	(allout-do-resumptions))
	6086	)
	6087	;;;_ % Run unit tests if `allout-run-unit-tests-after-load' is true:
	6088	(when allout-run-unit-tests-on-load
	6089	(allout-run-unit-tests))
	6090
	6091	;;;_ #12 Provide
5923	6092	(provide 'allout)
5924	6093

Navigation

Changeset 4111 for trunk/lisp/allout.el

Legend:

trunk/lisp/allout.el

Download in other formats: