Mercurial > hg > xemacs-beta
annotate lisp/behavior.el @ 5635:2fc3f2f35523
Put back compatibility alias for #'cl-puthash, used by 21.4's setf expansion
2012-01-02 Aidan Kehoe <kehoea@parhasard.net>
* obsolete.el (cl-puthash): Put back a compatibility alias for
this, setf-expansion of #'gethash calls it on 21.4, so it will
occur in packages for a while to come.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 02 Jan 2012 13:35:31 +0000 |
| 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 |