|
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
|
|
|
481 '(("%_Package Utilities"
|
|
|
482 ("%_Set Download Site"
|
|
|
483 ("%_Official Releases"
|
|
|
484 :filter (lambda (&rest junk)
|
|
|
485 (menu-split-long-menu
|
|
|
486 (submenu-generate-accelerator-spec
|
|
|
487 (package-ui-download-menu)))))
|
|
|
488 ("%_Pre-Releases"
|
|
|
489 :filter (lambda (&rest junk)
|
|
|
490 (menu-split-long-menu
|
|
|
491 (submenu-generate-accelerator-spec
|
|
|
492 (package-ui-pre-release-download-menu)))))
|
|
|
493 ("%_Site Releases"
|
|
|
494 :filter (lambda (&rest junk)
|
|
|
495 (menu-split-long-menu
|
|
|
496 (submenu-generate-accelerator-spec
|
|
|
497 (package-ui-site-release-download-menu))))))
|
|
|
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
|
