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