Mercurial > hg > xemacs-beta
annotate lisp/behavior.el @ 5569:d19b6e3bdf91
#'cl-defsubst-expand; avoid mutually-recursive symbol macros.
lisp/ChangeLog addition:
2011-09-10 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (cl-defsubst-expand):
Change set 2a6a8da4dd7c of
http://mid.gmane.org/19966.17522.332164.615228@parhasard.net
wasn't sufficiently comprehensive, symbol macros can be mutually
rather than simply recursive, and they can equally hang. Thanks
for the bug report, Michael Sperber, and for the test case,
Stephen Turnbull.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 10 Sep 2011 13:17:29 +0100 |
| parents | e05d98bf9644 |
| children | 5d3bb1100832 |
| rev | line source |
|---|---|
| 2546 | 1 ;;; behavior.el --- consistent interface onto packages |
| 502 | 2 |
| 2546 | 3 ;; Copyright (C) 2000, 2001, 2002, 2003 Ben Wing. |
| 502 | 4 |
| 5 ;; Author: Ben Wing | |
| 6 ;; Maintainer: XEmacs Development Team | |
| 7 ;; Keywords: internal, dumped | |
| 8 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5271
diff
changeset
|
11 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5271
diff
changeset
|
12 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5271
diff
changeset
|
13 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5271
diff
changeset
|
14 ;; option) any later version. |
| 502 | 15 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5271
diff
changeset
|
16 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5271
diff
changeset
|
17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5271
diff
changeset
|
18 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5271
diff
changeset
|
19 ;; for more details. |
| 502 | 20 |
| 21 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5271
diff
changeset
|
22 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 502 | 23 |
| 24 ;;; Synched up with: Not in FSF. | |
| 25 | |
| 26 ;;; Authorship: | |
| 27 | |
| 28 ;; Created July 2000 by Ben Wing. | |
| 29 | |
| 30 ;;; Commentary: | |
| 31 | |
| 2546 | 32 ;; This file is dumped with XEmacs. |
| 33 | |
| 34 ;; This file is part of the "Behaviors" project and is a work in progress. | |
| 35 ;; The purpose of the project is to provide (a) a consistent interface (at | |
| 36 ;; the API level) onto the functionality provided by packages, and (b) an | |
| 37 ;; easy-to-use user interface for this functionality, something that | |
| 38 ;; *really works*. | |
| 39 ;; | |
| 40 ;; First, what characteristics do/should packages have? (NOTE: In this | |
| 41 ;; discussion below, `package' and `behavior' are being used more or less | |
| 42 ;; interchangeably. Eventually this will get resolved.) | |
| 43 | |
| 44 ;; 1) A file, or one or more file, containing the code of the package. In | |
| 45 ;; addition, a "head" file in the case that the package needs to be | |
| 46 ;; loaded in order to get its functionality (e.g. "load-to-enable" | |
| 47 ;; packages -- an abomination that is tolerated only with severe | |
| 48 ;; displeasure). | |
| 49 ;; 2) A Lisp name -- a fairly short symbol (2-3 words max), uncapitalized, | |
| 50 ;; without use of excessive abbreviation and with words set off by | |
| 51 ;; dashes. This should be the same as the name of the topmost custom | |
| 52 ;; group associated with the package (see next item), and preferably the | |
| 53 ;; same as the common prefix used for variables defined by your package | |
| 54 ;; and the name of the head file of the package. | |
| 55 ;; 3) Associated custom group listing the settings associated with the package. | |
| 56 ;; 4) Enable and disable methods for turning on or off the functionality of | |
| 57 ;; the package, if it's amenable to such a model. Most packages are of two | |
| 58 ;; types: | |
| 59 ;; | |
| 60 ;; (a) They add some functionality to XEmacs, which is incorporated | |
| 61 ;; into and makes changes to the normal functionality of XEmacs. Once the | |
| 62 ;; package is enabled, the user doesn't have to do anything specific for | |
| 63 ;; the package to do its thing -- it happens automatically if the user is | |
| 64 ;; using the area whose behavior has been changed. These include packages | |
| 65 ;; such as `avoid' (which makes the mouse poointer move when the cursor | |
| 66 ;; gets too close), EFS (which adds the ability to treat an FTP site as | |
| 67 ;; part of the local file system), the packages that supply the | |
| 68 ;; mode-specific handling for various files, etc | |
| 69 ;; | |
| 70 ;; (b) They provide functionality in the form of specific command to be | |
| 71 ;; invoked. This can be as simple as the `hippie-expand' command (tries | |
| 72 ;; lots of different expansion methods for the text before point, to | |
| 73 ;; try and get a result) and as complicated as GNUS or VM. | |
| 74 ;; | |
| 75 ;; Some packages might provide both -- you can enable them and they | |
| 76 ;; incorporate some functionality into the XEmacs base, but while | |
| 77 ;; they're enabled they provide certain commands. #### We need some | |
| 78 ;; thought here, and case-by-case analysis, to determine if this really | |
| 79 ;; makes sense -- can the enable/disable be removed and whatever needs | |
| 80 ;; to happen incorporated as part of the command? can the | |
| 81 ;; enable/disable just added to the commands? | |
| 82 ;; | |
| 83 ;; 5) Packages of type (b) just above will have a list of commands that can be | |
| 84 ;; run. They should be in standard menubar format -- i.e. just like a | |
| 85 ;; submenu, but without the initial string indidicating the name of the | |
| 86 ;; menu. | |
| 87 ;; 6) Short doc string, for use in a menu item. *NOT* necessarily the same | |
| 88 ;; as the documentation for the Custom group, which is often too long. | |
| 89 ;; 7) Long documentation. | |
| 90 ;; | |
| 91 ;; Good package etiquette: | |
| 92 ;; | |
| 93 ;; | |
| 94 ;; -- Never mess with the menu yourself, or try to "cheat" by putting yourself | |
| 95 ;; high up in the hierarchy, e.g. at the top-level or directly off a | |
| 96 ;; top-level group that expects to contain only groups of groups, not | |
| 97 ;; end-level groups. | |
| 98 ;; | |
| 99 ;; -- Never use the `override-behavior' commands or the like for specifying | |
| 100 ;; (in an overriding fashion) the exact appearance of the hierarchies. | |
| 101 ;; | |
| 102 ;; -- For type (a), with enable/disable methods: | |
| 103 ;; | |
| 104 ;; (a) Loading the file should NOT DO ANYTHING. Not enable, not add hooks, | |
| 105 ;; nothing. | |
| 106 ;; (b) Both enable and disable hooks must exist. The disable hook must | |
| 107 ;; completely reset the environment to how it was before the package | |
| 108 ;; was enabled. This includes restoring the prior bindings for | |
| 109 ;; modified key bindings. #### We need some helper function to assist | |
| 110 ;; with remembering the old key bindings and putting them back only | |
| 111 ;; when new key bindings haven't been made -- but recognize when those | |
| 112 ;; new key bondings were attached as a result of loading another | |
| 113 ;; package, so that after any order of loading and unloading a series | |
| 114 ;; of packages, the original bindings will eventually occur. (Something | |
| 115 ;; like `advice' for key definitions.) Replacement of functions should | |
| 116 ;; happen through `advice'. | |
| 117 ;; | |
| 118 ;; We recognize that many packages out there don't follow these precepts at | |
| 119 ;; all. Many or most of them are install-only, often happening | |
| 120 ;; automatically when the file is loaded. Converting these will be a step | |
| 121 ;; at a time: First, redo the latter type so that the initialization code | |
| 122 ;; is put into a function and not run automatically upon load. Next step, | |
| 123 ;; try to provide some sort of disable. Third step, work on making sure | |
| 124 ;; that disable removes *everything* and enable puts it all back. Fourth | |
| 125 ;; step, work on properly advising keys and functions. | |
| 126 ;; | |
| 127 | |
| 128 ;; Comparison/Integration with Custom: | |
| 129 | |
| 130 ;; Custom only handles variable settings, and has no concept of standard | |
| 131 ;; enable/disable methods for a package, a standard way of specifying | |
| 132 ;; package documentation, or a list of commands associated with a package. | |
| 133 ;; Also, its groups do not always map very well onto packages and the | |
| 134 ;; resulting hierarchy is too big, confusing, difficult-to-navigate, and | |
| 135 ;; incoherent. More generally it does not address at all the basic problem | |
| 136 ;; that a hierarchy created in a decentralized fashion -- and by a large | |
| 137 ;; number of authors, some more competent than others -- will inevitably be | |
| 138 ;; incoherent when put together. | |
| 139 ;; | |
| 140 | |
| 141 ;; In general, ease-of-use was not the overarching goal of Custom. The | |
| 142 ;; primary goal of Custom seems to have been to provide a consistent interface | |
| 143 ;; and get all the packages to use it. Ease-of-use -- or even following | |
| 144 ;; established user-interface standards -- has taken a far-distant second, and | |
| 145 ;; appears in many respects to be an afterthought that never had any serious | |
| 146 ;; effort investigated into it. | |
| 147 ;; | |
| 148 ;; The eventual intent of this project is to integrate with custom. The final | |
| 149 ;; intent of integration is that this project subsumes Custom completely, | |
| 150 ;; making Custom the unified, user-friendly means of controlling XEmacs that | |
| 151 ;; has never properly existed. However, that will take a lot of work. For | |
| 152 ;; the meantime, the plan is to develop the Behavior subsystem independent of | |
| 153 ;; Custom, with ease-of-use as the primary goal, and get it to the point where | |
| 154 ;; it encompasses most packages out there, has stabilized its interface, and | |
| 155 ;; works well. At that point, we will consider integration with Custom. (Note | |
| 156 ;; that the hard part of the Behavior work is not actually behaviorizing the | |
| 157 ;; packages, but developing the interface itself.) | |
| 158 ;; | |
| 159 ;; As for integrating with Custom -- ideally that would mean simply extending | |
| 160 ;; defgroup, but that is not really possible given that backward-compatibility | |
| 161 ;; would not work -- existing versions of `defgroup' give an error when | |
| 162 ;; presented with an unknown keyword. In practice, then, this might mean that | |
| 163 ;; a separate `define-behavior' command (or `defpackage', or the like) will | |
| 164 ;; still exist. | |
| 502 | 165 |
| 166 ;;; Code: | |
| 167 | |
| 800 | 168 ;; Hash table mapping behavior names to property lists, with entries for |
| 2546 | 169 ;; :group, :custom-group, :short-doc, :require, :enable, :disable, |
| 170 ;; and :commands. | |
| 800 | 171 (defconst behavior-hash-table (make-hash-table)) |
| 2546 | 172 ;; Hash table mapping groups to property lists (entries for :group, :children, |
| 173 ;; :short-doc). | |
| 174 (defconst behavior-group-hash-table (make-hash-table)) | |
| 175 ;; Hash table with override information for groups. | |
| 176 ;; :short-doc). | |
| 177 (defconst behavior-override-hash-table (make-hash-table)) | |
| 800 | 178 |
| 179 (defvar within-behavior-enabling-disabling nil) | |
| 180 | |
| 181 (defgroup behaviors nil | |
| 182 "Behaviors -- high-level functionality interface.") | |
| 183 | |
| 184 ;; List of enabled behaviors. | |
| 185 (defcustom enabled-behavior-list nil | |
| 186 "List of currently enabled behaviors. | |
| 187 Normally, don't set it directly; use `enable-behavior' or `disable-behavior'." | |
| 188 :initialize #'set-default | |
| 189 :set #'(lambda (sym val) | |
| 190 (if within-behavior-enabling-disabling | |
| 191 (set sym val) | |
| 192 (let* ((old-val enabled-behavior-list) | |
| 193 (disable-list (set-difference old-val val)) | |
| 194 (enable-list (set-difference val old-val))) | |
| 195 (dolist (b disable-list) | |
| 196 (disable-behavior b t)) | |
| 197 (dolist (b enable-list) | |
| 198 (enable-behavior b t)) | |
| 897 | 199 (assert (equal (sort (copy-sequence enabled-behavior-list) 'string-lessp) |
| 200 (sort (copy-sequence val) 'string-lessp)))))) | |
| 800 | 201 :type '(repeat (symbol :tag "Behavior")) |
| 202 :group 'behaviors) | |
| 203 | |
| 502 | 204 |
| 205 (defvar behavior-history nil | |
| 206 "History of entered behaviors.") | |
| 207 | |
| 2546 | 208 (defun behavior-group-p (group) |
| 209 "Non-nil if GROUP is the name of a valid behavior group." | |
| 210 (not (null (gethash group behavior-group-hash-table)))) | |
| 211 | |
| 212 (defun check-behavior-group (group) | |
| 213 "Verify that GROUP is a valid behavior group, or nil. | |
| 214 Return GROUP if so." | |
| 215 (or (behavior-group-p group) | |
| 216 (error 'invalid-argument "Invalid behavior group" group)) | |
| 217 group) | |
| 218 | |
| 219 (defun* define-behavior (name doc-string &key | |
| 220 group custom-group | |
| 221 (short-doc | |
| 222 (capitalize-string-as-title | |
| 223 (replace-in-string (symbol-name name) "-" " "))) | |
| 224 require enable disable commands | |
| 225 &allow-other-keys) | |
| 226 ;; We allow other keys to allow for the possibility of extensions by | |
| 227 ;; later versions of XEmacs. Packages should be able to support those | |
| 228 ;; extensions without worrying about causing problems with older versions | |
| 229 ;; of XEmacs. | |
| 502 | 230 "Define a behavior named NAME. |
| 231 DOC-STRING must be specified, a description of what the behavior does | |
| 232 when it's enabled and how to further control it (typically through | |
| 233 custom variables). Accepted keywords are | |
| 234 | |
| 2546 | 235 :group Symbol naming the behavior group this behavior is within. |
| 236 :custom-group Symbol naming the custom group containing the options that | |
| 237 can be set in association with this behavior. If not specified, | |
| 238 the custom group with the same name as the behavior will be | |
| 239 used, if it exists. | |
| 800 | 240 :short-doc A \"pretty\" version of the name, for use in menus. If omitted |
| 241 a prettified name will be generated. | |
| 242 :require A single symbol or a list of such symbols, which need to be | |
| 243 present at enable time, or will be loaded using `require'. | |
| 244 :enable A function of no variables, which turns the behavior on. | |
| 245 :disable A function of no variables, which turns the behavior off. | |
| 2546 | 246 :commands A list of interactive commands that can be invoked in |
| 247 conjunction with the behavior. These will appear in a submenu | |
| 248 along with the rest of the items for the behavior. | |
| 502 | 249 |
| 250 Behaviors are assumed to be global, and to take effect immediately; if | |
| 251 the underlying package is per-buffer, it may have to scan all existing | |
| 252 buffers and frob them. When a behavior is disabled, it should completely | |
| 253 go away *everywhere*, as if it were never invoked at all. | |
| 254 | |
| 2546 | 255 The :disable keyword can be missing, although this is considered bad |
| 502 | 256 practice. In such a case, attempting to disable the behavior will signal |
| 2546 | 257 an error unless you use the `force' option. |
| 258 | |
| 259 The :enable keyword can be missing. This is useful for behaviors that | |
| 260 are really a series of related commands without anything semantically | |
| 261 corresponding to \"turning on\" or \"turning off\" the behavior. | |
| 262 | |
| 263 A behavior with no :enable and no :command is possible. This might be | |
| 264 used, for example, by a behavior that encapsulates a series of related | |
| 265 Lisp functions. Such behaviors may be handled specially, e.g. not | |
| 266 displayed in the menus or displayed in a separate location, since they | |
| 267 have no user-invocable behavior." | |
| 268 (let ((entry (list :group (check-behavior-group group) | |
| 269 :custom-group custom-group | |
| 270 :short-doc short-doc :require require | |
| 271 :enable enable :disable disable | |
| 272 :commands commands))) | |
| 273 (puthash name entry behavior-hash-table)) | |
| 274 ;; update the children list of the group we're in (maybe nil). | |
| 275 (unless (member name (getf (gethash group behavior-group-hash-table) | |
| 276 :children)) | |
| 277 (push name (getf (gethash group behavior-group-hash-table) :children)))) | |
| 278 | |
| 279 (defun* override-behavior (name &key | |
| 280 short-doc | |
| 281 group | |
| 282 include | |
| 283 demote-others) | |
| 284 "Override the default properties of a behavior group NAME. | |
| 285 Normally, groups are created and assigned properties by individual packages. | |
| 286 The resulting hierarchy may not make much sense globally. This function | |
| 287 allows the hierarchy and appearance of a group to be specified globally, | |
| 288 and will take precendence over the properties assigned by `define-behavior-group'. This allows a global organization to be imposed on groups, while still allowing for graceful handling of new or unknown groups. | |
| 289 | |
| 290 NAME can be a symbol specifying a group name, or a list of | |
| 291 \(PARENT [...] NAME), where a path from a particular parent is explicitly | |
| 292 given. (This latter form allows the same name to be assigned to more than one | |
| 293 group.) | |
| 294 | |
| 295 Accepted keywords are | |
| 296 | |
| 297 :short-doc A \"pretty\" version of the name, for use in menus. | |
| 298 :group Parent group, if any. Should not be given if the parents are | |
| 299 explicitly specified in NAME. | |
| 300 :include A list of behaviors that are specifically included in this | |
| 301 group, in addition to those that are included by the behaviors | |
| 302 themselves. | |
| 303 :demote-others If non-nil, exclude all behaviors not specified in the :include | |
| 304 list and put them instead (i.e. \"demote\" them) to another group, | |
| 305 usually a subgroup." | |
| 306 (let ((entry (list :group (check-behavior-group group) | |
| 307 :short-doc short-doc | |
| 308 :include include | |
| 309 :demote-others demote-others))) | |
| 310 (puthash name entry behavior-override-hash-table))) | |
| 311 | |
| 312 (defun* define-behavior-group (name &key | |
| 313 (short-doc | |
| 314 (capitalize-string-as-title | |
| 315 (replace-in-string (symbol-name name) "-" | |
| 316 " "))) | |
| 317 group) | |
| 318 "Define a behavior group NAME. | |
| 319 | |
| 320 NAME can be a symbol specifying a group name, or a list of | |
| 321 \(PARENT [...] NAME), where a path from a particular parent is explicitly | |
| 322 given. (This latter form allows the same name to be assigned to more than one | |
| 323 group.) | |
| 324 | |
| 325 Accepted keywords are | |
| 326 | |
| 327 :short-doc A \"pretty\" version of the name, for use in menus. If omitted | |
| 328 a prettified name will be generated. | |
| 329 :group Parent group, if any. Should not be given if the parents are | |
| 330 explicitly specified in NAME." | |
| 331 (let ((entry (list :group (check-behavior-group group) | |
| 332 :short-doc short-doc))) | |
| 333 (puthash name entry behavior-group-hash-table)) | |
| 334 ;; update the children list of the parent (maybe nil). | |
| 335 (push name (getf (gethash group behavior-group-hash-table) :children))) | |
| 502 | 336 |
| 337 (defun read-behavior (prompt &optional must-match initial-contents history | |
| 2546 | 338 default-value) |
| 502 | 339 "Return a behavior symbol from the minibuffer, prompting with string PROMPT. |
| 340 If non-nil, optional second arg INITIAL-CONTENTS is a string to insert | |
| 341 in the minibuffer before reading. | |
| 342 Third arg HISTORY, if non-nil, specifies a history list. (It defaults to | |
| 343 `behavior-history'.) | |
| 344 Fourth arg DEFAULT-VALUE is the default value. If non-nil, it is used | |
| 345 for history command, and as the value to return if the user enters the | |
| 346 empty string." | |
| 347 (let ((result | |
| 348 (completing-read | |
| 349 prompt | |
|
5271
2def0d83a5e3
Don't uselessly call #'nreverse, #'hash-table-key-list and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4372
diff
changeset
|
350 (let (list) |
|
2def0d83a5e3
Don't uselessly call #'nreverse, #'hash-table-key-list and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4372
diff
changeset
|
351 (maphash #'(lambda (key value) |
|
2def0d83a5e3
Don't uselessly call #'nreverse, #'hash-table-key-list and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4372
diff
changeset
|
352 (push (cons (symbol-name key) value) list)) |
|
2def0d83a5e3
Don't uselessly call #'nreverse, #'hash-table-key-list and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4372
diff
changeset
|
353 behavior-hash-table) |
|
2def0d83a5e3
Don't uselessly call #'nreverse, #'hash-table-key-list and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4372
diff
changeset
|
354 list) |
| 2546 | 355 nil must-match initial-contents (or history 'behavior-history) |
| 502 | 356 default-value))) |
| 357 (if (and result (stringp result)) | |
| 358 (intern result) | |
| 359 result))) | |
| 360 | |
| 800 | 361 (defun behavior-enabled-p (behavior) |
| 362 "Non-nil if BEHAVIOR (a symbol) if currently enabled." | |
| 363 (memq behavior enabled-behavior-list)) | |
| 502 | 364 |
| 365 (defun enable-behavior (behavior &optional force) | |
| 366 "Enable the specified behavior." | |
| 367 (interactive (list (read-behavior "Enable Behavior: " t) current-prefix-arg)) | |
| 368 (let ((plist (gethash behavior behavior-hash-table))) | |
| 369 (or plist (error 'invalid-argument "Not a behavior" behavior)) | |
| 800 | 370 (or force (not (memq behavior enabled-behavior-list)) |
| 371 (error 'invalid-change "Behavior already enabled" behavior)) | |
| 502 | 372 (let ((require (getf plist :require)) |
| 373 (enable (getf plist :enable))) | |
| 374 (cond ((listp require) | |
|
5524
e05d98bf9644
Style and indentation corrections, behavior.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
375 (mapc 'require require)) |
| 502 | 376 ((symbolp require) |
| 377 (require require)) | |
| 378 (t (error 'invalid-argument "Invalid :require spec" require))) | |
| 800 | 379 (message "Enabling behavior %s..." behavior) |
| 380 (if enable (funcall enable)) | |
| 381 (message "Enabling behavior %s...done" behavior) | |
| 382 (let ((within-behavior-enabling-disabling t)) | |
| 383 (customize-set-variable 'enabled-behavior-list | |
| 384 (cons behavior enabled-behavior-list)))))) | |
| 502 | 385 |
| 386 (defun disable-behavior (behavior &optional force) | |
| 387 "Disable the specified behavior." | |
| 388 (interactive (list (read-behavior "Disable Behavior: " t) | |
| 389 current-prefix-arg)) | |
| 390 (let ((plist (gethash behavior behavior-hash-table))) | |
| 391 (or plist (error 'invalid-argument "Not a behavior" behavior)) | |
| 800 | 392 (or force (memq behavior enabled-behavior-list) |
| 393 (error 'invalid-change "Behavior not enabled" behavior)) | |
| 502 | 394 (let ((require (getf plist :require)) |
| 395 (disable (getf plist :disable))) | |
| 396 (cond ((listp require) | |
|
5524
e05d98bf9644
Style and indentation corrections, behavior.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
397 (mapc 'require require)) |
| 502 | 398 ((symbolp require) |
| 399 (require require)) | |
| 400 (t (error 'invalid-argument "Invalid :require spec" require))) | |
| 800 | 401 (message "Disabling behavior %s..." behavior) |
| 402 (if disable (funcall disable)) | |
| 403 (message "Disabling behavior %s...done" behavior) | |
| 404 (let ((within-behavior-enabling-disabling t)) | |
| 405 (customize-set-variable 'enabled-behavior-list | |
| 406 (delq behavior enabled-behavior-list)))))) | |
| 502 | 407 |
| 2546 | 408 (defun compute-behavior-group-children (group hash) |
| 409 "Compute the actual children for GROUP and its subgroups. | |
| 410 This takes into account the override information specified." | |
| 411 (let* ((group-plist (gethash group behavior-group-hash-table)) | |
| 412 (override (gethash group behavior-override-hash-table)) | |
| 413 (children (getf group-plist :children))) | |
| 414 ) | |
| 415 ) | |
| 416 | |
| 417 (defun behavior-menu-filter-1 (menu group) | |
| 418 (submenu-generate-accelerator-spec | |
| 419 (let* ( | |
| 420 ;;options | |
| 421 ;;help | |
| 422 (enable | |
| 423 (menu-split-long-menu | |
| 424 (menu-sort-menu | |
| 425 (let ((group-plist (gethash group behavior-group-hash-table))) | |
| 426 (loop for behavior in (getf group-plist :children) | |
| 427 nconc (if (behavior-group-p behavior) | |
| 428 (list | |
| 429 (cons (getf | |
| 430 (gethash behavior behavior-group-hash-table) | |
| 431 :short-doc) | |
| 432 (behavior-menu-filter-1 menu behavior))) | |
| 433 (let* ((plist (gethash behavior behavior-hash-table)) | |
| 434 (commands (getf plist :commands))) | |
| 435 (nconc | |
| 436 (if (getf plist :enable) | |
| 437 `([,(format "%s (%s) [toggle]" | |
| 438 (getf plist :short-doc) | |
| 439 behavior) | |
| 440 (if (memq ',behavior | |
| 441 enabled-behavior-list) | |
| 442 (disable-behavior ',behavior) | |
| 443 (enable-behavior ',behavior)) | |
| 444 :active ,(if (getf plist :disable) t | |
| 445 (not (memq | |
| 446 ',behavior | |
| 447 enabled-behavior-list))) | |
| 448 :style toggle | |
| 449 :selected (memq ',behavior | |
| 450 enabled-behavior-list)])) | |
| 451 (cond ((null commands) nil) | |
| 452 ((and (eq (length commands) 1) | |
| 453 (vectorp (elt commands 0))) | |
| 454 (let ((comm (copy-sequence | |
| 455 (elt commands 0)))) | |
| 456 (setf (elt comm 0) | |
| 457 (format "%s (%s)" | |
| 458 (elt comm 0) behavior)) | |
| 459 (list comm))) | |
| 460 (t (list | |
| 461 (cons (format "%s (%s) Commands" | |
| 462 (getf plist :short-doc) | |
| 463 behavior) | |
| 464 commands))))))))) | |
| 465 )) | |
| 466 ) | |
| 467 ) | |
| 468 enable) | |
| 469 '(?p))) | |
| 470 | |
| 471 (defun behavior-menu-filter (menu) | |
| 472 (append | |
|
4372
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
473 `(("%_Package Utilities" |
| 2546 | 474 ("%_Set Download Site" |
| 475 ("%_Official Releases" | |
|
4372
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
476 :filter ,#'(lambda (&rest junk) |
|
5524
e05d98bf9644
Style and indentation corrections, behavior.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
477 (menu-split-long-menu |
|
e05d98bf9644
Style and indentation corrections, behavior.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
478 (submenu-generate-accelerator-spec |
|
e05d98bf9644
Style and indentation corrections, behavior.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
479 (package-ui-download-menu))))) |
| 2546 | 480 ("%_Pre-Releases" |
|
4372
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
481 :filter ,#'(lambda (&rest junk) |
|
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
482 (menu-split-long-menu |
|
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
483 (submenu-generate-accelerator-spec |
|
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
484 (package-ui-pre-release-download-menu))))) |
| 2546 | 485 ("%_Site Releases" |
|
4372
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
486 :filter ,#'(lambda (&rest junk) |
|
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
487 (menu-split-long-menu |
|
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
488 (submenu-generate-accelerator-spec |
|
ebb35ddea76a
Byte-compile menu lambdas; make the menu of available tutorials more readable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2546
diff
changeset
|
489 (package-ui-site-release-download-menu)))))) |
| 2546 | 490 "--:shadowEtchedIn" |
| 491 ["%_Update Package Index" package-get-update-base] | |
| 492 ["%_List and Install" pui-list-packages] | |
| 493 ["U%_pdate Installed Packages" package-get-update-all] | |
| 494 ["%_Help" (Info-goto-node "(xemacs)Packages")]) | |
| 495 "----") | |
| 496 (behavior-menu-filter-1 menu nil))) | |
| 497 | |
| 498 ;; Initialize top-level group. | |
| 499 (puthash nil '(:children nil :short-doc "Root") behavior-group-hash-table) | |
| 500 | |
| 502 | 501 (provide 'behavior) |
| 502 | |
| 503 ;;; finder-inf.el ends here |