Mercurial > hg > xemacs-beta
annotate lisp/toolbar.el @ 5634:2014ff433daf
Support hash COLLECTIONs, #'{all,try}-completion{s,}; add #'test-completion
src/ChangeLog addition:
2012-01-01 Aidan Kehoe <kehoea@parhasard.net>
Add #'test-completion, API from GNU.
Accept hash table COLLECTIONs in it and in the other
completion-oriented functions, #'try-completion,
#'all-completions, and those Lisp functions implemented in terms
of them.
* lisp.h: Update the prototype of map_obarray(), making FN
compatible with the FUNCTION argument of elisp_maphash();
* abbrev.c (abbrev_match_mapper):
* abbrev.c (record_symbol):
* doc.c (verify_doc_mapper):
* symbols.c (mapatoms_1):
* symbols.c (apropos_mapper):
Update these mapper functions to reflect the new argument to
map_obarray().
* symbols.c (map_obarray):
Call FN with two arguments, the string name of the symbol, and the
symbol itself, for API (mapper) compatibility with
elisp_maphash().
* minibuf.c (map_completion): New. Map a maphash_function_t across
a non function COLLECTION, as appropriate for #'try-completion and
friends.
* minibuf.c (map_completion_list): New. Map a maphash_function_t
across a pseudo-alist, as appropriate for the completion
functions.
* minibuf.c (ignore_completion_p): PRED needs to be called with
two args if and only if the collection is a hash table. Implement
this.
* minibuf.c (try_completion_mapper): New. The loop body of
#'try-completion, refactored out.
* minibuf.c (Ftry_completion): Use try_completion_mapper(),
map_completion().
* minibuf.c (all_completions_mapper): New. The loop body of
#'all-completions, refactored out.
* minibuf.c (Fall_completions): Use all_completions_mapper(),
map_completion().
* minibuf.c (test_completion_mapper): New. The loop body of
#'test-completion.
* minibuf.c (Ftest_completion): New, API from GNU.
* minibuf.c (syms_of_minibuf): Make Ftest_completion available.
tests/ChangeLog addition:
2012-01-01 Aidan Kehoe <kehoea@parhasard.net>
* automated/completion-tests.el: New.
Test #'try-completion, #'all-completion and #'test-completion with
list, vector and hash-table COLLECTION arguments.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Sun, 01 Jan 2012 15:18:52 +0000 |
parents | 308d34e9f07d |
children |
rev | line source |
---|---|
428 | 1 ;;; toolbar.el --- Toolbar support for XEmacs |
2 | |
3 ;; Copyright (C) 1995, 1997 Free Software Foundation, Inc. | |
771 | 4 ;; Copyright (C) 2002 Ben Wing. |
428 | 5 |
6 ;; Maintainer: XEmacs Development Team | |
7 ;; Keywords: extensions, 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:
5228
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:
5228
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:
5228
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:
5228
diff
changeset
|
14 ;; option) any later version. |
428 | 15 |
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5228
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:
5228
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:
5228
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:
5228
diff
changeset
|
19 ;; for more details. |
428 | 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:
5228
diff
changeset
|
22 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
428 | 23 |
24 ;;; Synched up with: Not in FSF. | |
25 | |
26 ;;; Commentary: | |
27 | |
28 ;; This file is dumped with XEmacs (when toolbar support is compiled in). | |
29 | |
30 ;;; Code: | |
31 | |
32 (defcustom toolbar-visible-p ;; added for the options menu - dverna apr. 98 | |
33 (specifier-instance default-toolbar-visible-p) | |
763 | 34 "*Whether the default toolbar is globally visible. |
771 | 35 This option only has an effect when set using `customize-set-variable', |
36 or through the Options menu." | |
428 | 37 :group 'display |
38 :type 'boolean | |
39 :set #'(lambda (var val) | |
40 (set-specifier default-toolbar-visible-p val) | |
41 (setq toolbar-visible-p val)) | |
42 ) | |
43 | |
44 (defcustom toolbar-captioned-p ;; added for the options menu - dverna apr. 98 | |
45 (specifier-instance toolbar-buttons-captioned-p) | |
763 | 46 "*Whether the toolbars buttons are globally captioned. |
771 | 47 This option only has an effect when set using `customize-set-variable', |
48 or through the Options menu." | |
428 | 49 :group 'display |
50 :type 'boolean | |
51 :set #'(lambda (var val) | |
52 (set-specifier toolbar-buttons-captioned-p val) | |
53 (setq toolbar-captioned-p val)) | |
54 ) | |
55 | |
56 (defcustom default-toolbar-position ;; added for the options menu - dverna | |
57 (default-toolbar-position) | |
771 | 58 "*The location of the default toolbar: 'top, 'bottom, 'left or 'right. |
59 This option only has an effect when set using `customize-set-variable', | |
60 or through the Options menu." | |
428 | 61 :group 'display |
442 | 62 :type '(choice (const :tag "top" top) |
63 (const :tag "bottom" bottom) | |
64 (const :tag "left" left) | |
65 (const :tag "right" right)) | |
428 | 66 :set #'(lambda (var val) |
763 | 67 (let* ((height (window-height)) |
68 (hdiff (- (frame-height) height)) | |
69 (width (window-width))) | |
70 (set-default-toolbar-position val) | |
71 (setq default-toolbar-position val) | |
72 ;; needed or dimensions don't update? | |
73 (redisplay-frame) | |
74 ;; This probably only works correctly if there is only one | |
75 ;; Emacs window. If windows are split, it probably results in | |
76 ;; small adjustments in their sizes. | |
77 (set-frame-size (selected-frame) width (+ height hdiff)) | |
767 | 78 ))) |
428 | 79 |
80 (defvar toolbar-help-enabled t | |
81 "If non-nil help is echoed for toolbar buttons.") | |
82 | |
83 (defvar toolbar-icon-directory nil | |
84 "Location of standard toolbar icon bitmaps.") | |
85 | |
86 (defun toolbar-make-button-list (up &optional down disabled cap-up cap-down cap-disabled) | |
87 "Call make-glyph on each arg and return a list of the results." | |
88 (let ((up-glyph (make-glyph up)) | |
89 (down-glyph (and down (make-glyph down))) | |
90 (disabled-glyph (and disabled (make-glyph disabled))) | |
91 (cap-up-glyph (and cap-up (make-glyph cap-up))) | |
92 (cap-down-glyph (and cap-down (make-glyph cap-down))) | |
93 (cap-disabled-glyph (and cap-disabled (make-glyph cap-disabled)))) | |
94 (if cap-disabled | |
95 (list up-glyph down-glyph disabled-glyph | |
96 cap-up-glyph cap-down-glyph cap-disabled-glyph) | |
97 (if cap-down | |
98 (list up-glyph down-glyph disabled-glyph | |
99 cap-up-glyph cap-down-glyph) | |
100 (if cap-up | |
101 (list up-glyph down-glyph disabled-glyph cap-up-glyph) | |
102 (if disabled-glyph | |
103 (list up-glyph down-glyph disabled-glyph) | |
104 (if down-glyph | |
105 (list up-glyph down-glyph) | |
106 (list up-glyph)))))))) | |
107 | |
108 (defun init-toolbar-location () | |
109 (if (not toolbar-icon-directory) | |
110 (let ((name (locate-data-directory "toolbar"))) | |
111 (if name | |
112 (setq toolbar-icon-directory | |
113 (file-name-as-directory name)))))) | |
114 | |
487 | 115 ;; called from toolbar.c during device and frame initialization |
428 | 116 (defun init-toolbar-from-resources (locale) |
117 (if (and (featurep 'x) | |
118 (or (eq locale 'global) | |
119 (eq 'x (device-or-frame-type locale)))) | |
502 | 120 (declare-fboundp (x-init-toolbar-from-resources locale)))) |
428 | 121 |
122 | |
123 ;; #### Is this actually needed or will the code in | |
124 ;; default-mouse-motion-handler suffice? | |
125 (define-key global-map 'button1up 'release-toolbar-button) | |
126 | |
127 (defvar toolbar-map (let ((m (make-sparse-keymap))) | |
128 (set-keymap-name m 'toolbar-map) | |
129 m) | |
130 "Keymap consulted for mouse-clicks over a toolbar.") | |
131 | |
132 (define-key toolbar-map 'button1 'press-toolbar-button) | |
133 (define-key toolbar-map 'button1up 'release-and-activate-toolbar-button) | |
134 (defvar last-pressed-toolbar-button nil) | |
135 (defvar toolbar-active nil) | |
136 | |
442 | 137 (defvar toolbar-blank-press-function nil |
138 "Function to call if a blank area of the toolbar is pressed.") | |
139 | |
428 | 140 ;; |
141 ;; It really sucks that we also have to tie onto | |
142 ;; default-mouse-motion-handler to make sliding buttons work right. | |
143 ;; | |
144 (defun press-toolbar-button (event) | |
145 "Press a toolbar button. This only changes its appearance. | |
3061 | 146 Call function stored in `toolbar-blank-press-function', if any, with EVENT as |
428 | 147 an argument if press is over a blank area of the toolbar." |
148 (interactive "_e") | |
149 (setq this-command last-command) | |
150 (let ((button (event-toolbar-button event))) | |
151 ;; We silently ignore non-buttons. This most likely means we are | |
152 ;; over a blank part of the toolbar. | |
153 (setq toolbar-active t) | |
154 (if (toolbar-button-p button) | |
155 (progn | |
156 (set-toolbar-button-down-flag button t) | |
157 (setq last-pressed-toolbar-button button)) | |
158 ;; Added by Bob Weiner, Motorola Inc., 10/6/95, to handle | |
159 ;; presses on blank portions of toolbars. | |
442 | 160 (when (functionp toolbar-blank-press-function) |
161 (funcall toolbar-blank-press-function event))))) | |
428 | 162 |
163 (defun release-and-activate-toolbar-button (event) | |
164 "Release a toolbar button and activate its callback. | |
3061 | 165 Call function stored in `toolbar-blank-release-function', if any, with EVENT |
428 | 166 as an argument if release is over a blank area of the toolbar." |
167 (interactive "_e") | |
168 (or (button-release-event-p event) | |
169 (error "%s must be invoked by a mouse-release" this-command)) | |
170 (release-toolbar-button event) | |
171 (let ((button (event-toolbar-button event))) | |
172 (if (and (toolbar-button-p button) | |
173 (toolbar-button-enabled-p button) | |
174 (toolbar-button-callback button)) | |
175 (let ((callback (toolbar-button-callback button))) | |
176 (setq this-command callback) | |
177 ;; Handle arbitrary functions. | |
178 (if (functionp callback) | |
179 (if (commandp callback) | |
180 (call-interactively callback) | |
181 (funcall callback)) | |
182 (eval callback)))))) | |
183 | |
184 ;; If current is not t, then only release the toolbar button stored in | |
185 ;; last-pressed-toolbar-button | |
186 (defun release-toolbar-button-internal (event current) | |
187 (let ((button (event-toolbar-button event))) | |
188 (setq zmacs-region-stays t) | |
189 (if (and last-pressed-toolbar-button | |
190 (not (eq last-pressed-toolbar-button button)) | |
191 (toolbar-button-p last-pressed-toolbar-button)) | |
192 (progn | |
193 (set-toolbar-button-down-flag last-pressed-toolbar-button nil) | |
194 (setq last-pressed-toolbar-button nil))) | |
195 (if (and current (toolbar-button-p button)) | |
196 (set-toolbar-button-down-flag button nil)))) | |
197 | |
198 (defun release-toolbar-button (event) | |
199 "Release all pressed toolbar buttons." | |
200 (interactive "_e") | |
201 (or (button-release-event-p event) | |
202 (error "%s must be invoked by a mouse-release" this-command)) | |
203 (release-toolbar-button-internal event t) | |
204 ;; Don't set this-command if we're being called | |
205 ;; from release-and-activate-toolbar-button. | |
206 (if (interactive-p) | |
207 (setq this-command last-command)) | |
208 (setq toolbar-active nil)) | |
209 | |
210 (defun release-previous-toolbar-button (event) | |
211 (setq zmacs-region-stays t) | |
212 (release-toolbar-button-internal event nil)) | |
213 | |
442 | 214 (defun make-toolbar-specifier (spec-list) |
215 "Return a new `toolbar' specifier object with the given specification list. | |
216 SPEC-LIST can be a list of specifications (each of which is a cons of a | |
217 locale and a list of instantiators), a single instantiator, or a list | |
218 of instantiators. See `make-specifier' for more information about | |
219 specifiers. | |
220 | |
221 Toolbar specifiers are used to specify the format of a toolbar. | |
222 The values of the variables `default-toolbar', `top-toolbar', | |
223 `left-toolbar', `right-toolbar', and `bottom-toolbar' are always | |
224 toolbar specifiers. | |
225 | |
226 Valid toolbar instantiators are called \"toolbar descriptors\" | |
227 and are lists of vectors. See `default-toolbar' for a description | |
228 of the exact format." | |
229 (make-specifier-and-init 'toolbar spec-list)) | |
230 | |
428 | 231 ;;; toolbar.el ends here |