edit-utils / toolbar-utils.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
;;; toolbar-utils.el --- Toolbar utility functions for XEmacs

;; Copyright (C) 1997, 2002 by Free Software Foundation, Inc.

;; Author: Stephen J. Turnbull <stephen@xemacs.org>
;;         Jeff Miller <jmiller@smart.net>
;; Created: 1997
;; Last-Modified: 03 December 2002
;; Keywords: gui, services

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:

;; This file contains utilities for managing XEmacs toolbars.
;; It doesn't seem to make sense to provide GNU compatibility here.
;; Instead, it seems much more reliable to reimplement the XEmacs
;; APIs for GNU.

;; This code is inspired by that written by Jeff Miller, and retains
;; his APIs.  However, it is a thorough rewrite.
;; See also edit-toolbar.el by Peter D. Pezaris <pez@dwwc.com>

;;; Change Log: see package ChangeLog.

;; To do:

;; 1. Probably should convert all these to use &keywords?
;; 2. Behavior-like implementation of "mode locales".
;; 3. Implement toolbar-replace-button (by position or content).
;; 5. Make an xemacs-toolbar version to do something sane in GNU.

;;; Code:

;;;###autoload
(defun restore-initial-toolbar ()
  "Restores the default toolbar defined by initial-toolbar-spec.

There is also a cache of killed buttons in `button-palette'."
  (interactive)
  (set-specifier default-toolbar initial-toolbar-spec))

;;; Variables:

;; #### need parent group
(defgroup edit-toolbar nil
  "Tools for interactive editing and non-interactive management of toolbars.")

(defcustom toolbar-button-default-position 'right
  "Default position for adding toolbar buttons on the fly.

See `toolbar-add-button-on-the-fly' for possible values and meanings."
  :type 'sexp
  :group 'edit-toolbar)

;; This needs to be a toolbar descriptor.  We should make a function to
;; stick it in a non-default toolbar, with surgery done on the function
;; so that pressing the palette buttons moves them to another toolbar.
(defvar button-palette nil
  "List of buttons cut from toolbars.

Note this is actually a toolbar descriptor.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; User commands:

;; toolbar-add-button-on-the-fly

;; #### This really belongs in edit-toolbar.el, except that it requires
;; functions from this file and edit-toolbar.el otherwise would not.
;;;###autoload
(defun toolbar-add-button-on-the-fly (description command label
				      &optional position locale)
  "Add an button at POSITION to the default toolbar of the selected window.
Returns t.

#### The return value may change.  Tell stephen@xemacs.org what value
you think would be (most) useful.

DESCRIPTION is a string describing the action, and displayed as help.
COMMAND is an interactive command (ie, a symbol with an interactive function
definition) implementing the action.
LABEL is a string used to label the button.
POSITION is an optional position (a non-negative integer, or one of the
symbols 'left, 'right, or 'extreme-right, see `toolbar-add-item').
LOCALE is an optional locale, defaulting to the current buffer.  If current-
buffer-only is not what you want, and you don't understand specifier locales,
use 'global.  It's safe and probably does what you want.

#### No error checking, use at your own risk."

  (interactive (list (read-string "Description: ")
		     (read-command "Command: ")
		     (read-string "Button label: ")
		     (read (completing-read
			    "Position: "
			    (lambda (x junk morejunk)
			      (cond ((let ((y (read x)))
				       (and (integerp y)
					    (<= 0 y)))
				     x)
				    ((try-completion x '(("left")
							 ("extreme-right")
							 ("right"))))))
		       nil nil nil nil "right"))
		     current-prefix-arg))

  (let ((domain (selected-window))
	(button (toolbar-new-button label command description)))
    (set-specifier default-toolbar
		   (toolbar-add-item (specifier-instance default-toolbar
							 domain)
				     button
				     position)
		   (or locale (current-buffer))))
  t)

;; toolbar-add-kbd-macro

;;;###autoload
(defun toolbar-add-kbd-macro (mac icon is-file)
  "Add a button invoking a keyboard macro to the toolbar of the current buffer.
The button is added at the end of the left group.

MAC is a keyboard macro name, or the empty string or nil to use a copy of
the last keyboard macro defined.
ICON is a string specifying the icon to be used.  If IS-FILE is non-nil,
it is interpreted as the name of an image file, and searched for using
`locate-data-file'.  Otherwise it is used verbatim as a label.

Interactively, prompts for the macro name MAC and an ICON.  IS-FILE is
non-nil if a prefix argument was used.

Warning: the interpretation of the prefix argument is likely to change."
  (interactive
   (list (read-string "Macro name (RET to use last defined macro): ")
	 (read-string (format "Icon %s: "
			      (if current-prefix-arg "image" "label")))
	 current-prefix-arg))
  (let* ((locale (current-buffer))
	 (position nil)
	 (mac (if (or (null mac) (= 0 (length mac)))
		  ;; is there an argument pro or con to copy-sequence?
		  last-kbd-macro
		(intern mac)))
	 ;; #### this actually probably just works, and we don't even need
	 ;; the IS-FILE argument at all
	 (icon (if is-file
		   (error 'unimplemented "We don't do image icons yet")
		 icon))
	 ;; this is actually the help string
	 (label (cond ((and is-file mac))
		      ;;  #### should truncate image file extension if any
		      ((and (stringp icon) (< 0 (length icon))) icon)
		      (t "KbdMac")))
	 (button (toolbar-new-button icon
				     `(lambda ()
					(interactive)
					(execute-kbd-macro ,mac))
				     label)))
    ;; #### need to abstract this
    ;; something like (toolbar-update-toolbar TOOLBAR ITEM POS LOCALE)
    (set-specifier default-toolbar
		   (toolbar-add-item (cdadar
				      (specifier-spec-list default-toolbar
							   locale))
				     button
				     position)
		   locale))
  t)

;; #### this should be a behavior
;;;###autoload
(defun toolbar-add-execute-macro-button ()
  "Add a button to the global toolbar to execute the last keyboard macro.

Unlike `toolbar-add-kbd-macro', this does not copy the macro.  The macro
executed will change with redefinitions.

Due to a simple implementation, this button will not appear in buffers with
local toolbars if invoked after the toolbar is installed.  If you like this
button, it's probably best to invoke this function in your init file."
  (interactive)
  (let* ((locale 'global)
	 (spec (cdadar (specifier-spec-list default-toolbar locale)))
	 (button (toolbar-new-button "LastMac"
				     #'toolbar-execute-last-kbd-macro
				     "Execute last defined keyboard macro")))
    (set-specifier default-toolbar (toolbar-add-item spec button) locale)))

;; if this is defsubst, XEmacs 21.4.10 crashes?
(defun toolbar-execute-last-kbd-macro ()
  (interactive)
  (execute-kbd-macro last-kbd-macro))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Lisp API functions:

;; adding items to a toolbar, with convenience functions for constructing
;; valid buttons, spacers, and toolbar descriptors

;;;###autoload
(defun toolbar-update-toolbar (item &optional toolbar position locale)
  "Use ITEM to update TOOLBAR at POSITION in LOCALE.

ITEM is a toolbar button or spacer specification (eg, from
`toolbar-new-button' or `toolbar-new-spacer').
Optional TOOLBAR is a toolbar specifier object.  It defaults to the value
of `default-toolbar'.
Optional POSITION is a non-negative integer or a symbol (for valid values,
see `toolbar-add-item').  The default is 'right.
Optional LOCALE is a specifier locale.  The default is 'global.  (This
default is not yet set in stone; it's best not to depend on it.)

This is a convenience function for helper applications or minor modes that
would like to add a small number of buttons to an existing toolbar.  For
constructing toolbars from scratch, use list and vector primitives, or
`toolbar-add-item'."
  (setq toolbar (or toolbar default-toolbar))
  (setq position (or position 'right))
  (setq locale (or locale 'global))
  (let ((spec (cdadar (specifier-spec-list toolbar locale))))
    (set-specifier toolbar (toolbar-add-item spec item position) locale)))


;;;###autoload
(defun toolbar-add-item (toolbar-spec item &optional position)
  "Add ITEM to TOOLBAR-SPEC at POSITION, and return TOOLBAR-SPEC.
Uses functions that alter list structure.

TOOLBAR-SPEC is a toolbar descriptor (eg, from `toolbar-new-toolbar').
ITEM is a toolbar button or spacer specification (eg, from
`toolbar-new-button' or `toolbar-new-spacer').
Optional POSITION is a non-negative integer, with 0 being the extreme left and
\(length TOOLBAR-SPEC) the extreme right.  The symbols 'left, 'right, and
'extreme-right are also accepted.  'left is synonymous with 0.  'right places
ITEM at the right end of the left group of buttons.  'extreme-right places
ITEM at the extreme right of the toolbar, creating a right group if one
does not exist.

#### This function does not yet support inserting the group delimiter nil
as an explicit item.

POSITION may be greater than (length TOOLBAR-SPEC), in which case it is
truncated to (length TOOLBAR-SPEC).  Note that (length TOOLBAR-SPEC) is not
synonymous with either 'right or 'extreme-right."
  (check-valid-instantiator toolbar-spec 'toolbar)
  (check-toolbar-button-syntax item)
  (unless position (setq position toolbar-button-default-position))
  (cond ((eq position 'right)
	 (let ((tail (memq nil toolbar-spec)))
	   (if (not tail)
	       (nconc toolbar-spec (list item))
	     ;; is this overly tricky?
	     (setcar tail item)
	     (setcdr tail (cons nil (cdr tail)))
	     toolbar-spec)))
	((or (eq position 'left) (eq position 0))
	 (cons item toolbar-spec))
	((eq position 'extreme-right)
	 (nconc toolbar-spec (if (memq nil toolbar-spec)
				 (list item)
			       (list nil item))))
	((and (integerp position) (< 0 position))
	 (let ((tail (nthcdr 1 toolbar-spec)))
	   (if (null tail)
	       (nconc toolbar-spec (list item))
	     ;; is this overly tricky?
	     (setcdr tail (cons (car tail) (cdr tail)))
	     (setcar tail item)
	     toolbar-spec)))
	(t (error 'wrong-type-argument
		  'integer-or-symbol
		  position))))

;;;###autoload
(defun toolbar-new-button (icon-spec command help-string
			   &optional initially-disabled)
  "Return a checked toolbar button specification.

ICON-SPEC should be a list of glyphs (from `make-glyph'), a glyph, or a
string to use as the button's icon.  If a string or single glyph, it will
be used for the button-up glyph.  If a list, it may contain 1 to 6 glyphs,
which XEmacs will use for button up, button down, button disabled, button
up with caption, button down with caption, and button disabled with caption,
in that order.  Missing or nil glyphs will be defaulted.  (#### Strings as
list elements are not supported but could be.)
COMMAND is the (interactive) command to invoke when the button is pressed.
HELP-STRING is a string briefly describing the command, displayed in the
echo area or as balloon help when the pointer enters the button.
Optional argument INITIALLY-DISABLED, if non-nil, specifies that the button
should initially be disabled.

See `default-toolbar' or the Lispref (node toolbars) for more information."
  (setq icon-spec (cond ((glyphp icon-spec) (list icon-spec))
			((stringp icon-spec) (list (make-glyph icon-spec)))
			((listp icon-spec) icon-spec)))
  (let ((button-spec
	 (vector icon-spec command (not initially-disabled) help-string)))
    (check-toolbar-button-syntax button-spec)
    button-spec))

;;;###autoload
(defun toolbar-new-spacer (style &optional size)
  "Returns a checked toolbar spacer \"button\".

STYLE is one of the symbols '2d or '3d, indicating whether the area is
displayed without shadows (giving it a flat appearance), or with shadows
\(giving it a raised, 3-d appearance).  There is no default.
#### We may set a default style.  Tell stephen@xemacs.org which you use.
SIZE specifies the length, in pixels, of the blank area.  If omitted,
it defaults to a device-specific value (8 pixels for X devices)."
  (let* ((style (or style '2d))
	 (button (if size
		     (vector :style style :size size)
		   (vector :style style))))
    (check-toolbar-button-syntax button)
    button))

;;;###autoload
(defun make-toolbar-instantiator (&optional toolbar-spec domain)
  "Return a checked toolbar instantiator, a list of vectors.

TOOLBAR-SPEC may be a list of buttons (ie, a toolbar descriptor, see
`default-toolbar'), a toolbar specifier object, or a symbol whose value is
a toolbar specifier object.  If a toolbar specifier object or variable
containing one, the specification for DOMAIN is used.  If non-nil, DOMAIN
must be a window, a frame, or a device, otherwise it defaults to the selected
window (see `specifier-instance').  The list thus generated is checked and
returned.

If TOOLBAR-SPEC is a list, it is copied; it is safe to pass other packages'
toolbar initializers to this function.  However, you probably do not want
to change any of the objects in the returned specification.  They are
returned as is, not copied.

See `default-toolbar' or the Lispref (node toolbars) for more information."
  (setq toolbar-spec
	(cond ((null toolbar-spec) nil)

	      ((symbolp toolbar-spec)
	       (specifier-instance (symbol-value toolbar-spec) domain))
	      ((specifierp toolbar-spec)
	       (specifier-instance toolbar-spec domain))
	      ((listp toolbar-spec) (copy-sequence toolbar-spec))
	      (t toolbar-spec)))	; errors by check-valid-instantiator
  (check-valid-instantiator toolbar-spec 'toolbar)
  toolbar-spec)

;; removing buttons from a toolbar

;;;###autoload
(defun toolbar-kill-item-pos (pos &optional toolbar locale)
  "Kill the item at position POS of TOOLBAR in LOCALE.
Killed buttons are prepended to `button-palette'.

LOCALE defaults to 'global.  If there are multiple specs for LOCALE, take
the first one.

This function currently does not accept symbolic positions a la
`toolbar-add-item'.  Use `toolbar-find-item' to locate whole buttons and
spacers, and `toolbar-find-button' to locate buttons by characteristics.
See also `toolbar-find-button-by-icon', `toolbar-find-button-by-command',
and `toolbar-find-button-by-help-string'."
  (setq locale (or locale 'global))
  (let ((spec (cdadar (specifier-spec-list (or toolbar default-toolbar)
					   locale))))
    (setq button-palette (cons (nth pos spec) button-palette))
    (set-specifier toolbar (if (eq pos 0)
			       (cdr spec)
			     (setcdr (nthcdr (1- pos) spec) 
				     (nthcdr (1+ pos) spec)))
		   locale)))

;; locating buttons by their content, returning a position

;;;###autoload
(defun toolbar-find-button (item &optional toolbar locale)
  "Return the position of a button containing ITEM in its specification.

ITEM may specify a button, spacer, icon, command, help string, or nil.
If ITEM is nil, find the separator between the group of buttons to be left
justified, and the group to be right justified.  (Distinctions among the
various \"search key types\" are somewhat heuristic but are probably
reliable enough to use in library code.)

If TOOLBAR is non-nil, search it; otherwise search the default toolbar.
If LOCALE is non-nil, get TOOLBAR's descriptor in that locale, otherwise
use the global locale."
  (setq toolbar (or toolbar default-toolbar))
  (setq locale (or locale 'global))
  (cond ((or (null item) (vectorp item)) (toolbar-find-item item))
	((commandp item) (toolbar-find-button-by-command item toolbar locale))
	((stringp item)
	 (toolbar-find-button-by-help-string item toolbar locale))
	(t (toolbar-find-button-by-icon item toolbar locale))))

;;;###autoload
(defun toolbar-find-item (item &optional toolbar locale)
  "Return the position of ITEM, a button, spacer, or nil.
TOOLBAR and LOCALE determine the descriptor to be searched.

If ITEM is nil, find the separator between the group of buttons to be left
justified, and the group to be right justified.
If there are several matching items, the first is returned.  If none is
found, return nil."
  (catch 'found
    (let ((pos 0))
      (while toolbar
	(if (equal (car toolbar) item) (throw 'found pos))
	(setq pos (1+ pos))
	(setq toolbar (cdr toolbar)))
      nil)))

;; internals -- if you think these should be autoloaded, let me know
(defun toolbar-find-button-by-icon (icon &optional toolbar locale)
  "Return the position of a button with icon ICON.
ICON must be a list of glyphs or a symbols whose value is a list of glyphs.
TOOLBAR and LOCALE determine the descriptor to be searched.

If there are several matching buttons, the first is returned."
  (flet ((thunk (x) (if (symbolp x) (symbol-value x) x)))
    (toolbar-find-button-by-element icon 0 toolbar locale #'thunk)))

(defun toolbar-find-button-by-command (cmd &optional toolbar locale)
  "Return the position of a button invoking command CMD.
TOOLBAR and LOCALE determine the descriptor to be searched.

If there are several matching buttons, the first is returned."
  (toolbar-find-button-by-element cmd 2 toolbar locale))

(defun toolbar-find-button-by-help-string (str &optional toolbar locale)
  "Return the position of a button with help-string STR.
TOOLBAR and LOCALE determine the descriptor to be searched.

If there are several matching buttons, the first is returned.
This function will not find spacers."
  (toolbar-find-button-by-element str 3 toolbar locale))

(defun toolbar-find-button-by-element (object index toolbar locale
				       &optional thunk)
  "Return the position of a button containing OBJECT in element INDEX.
TOOLBAR and LOCALE determine the descriptor to be searched.

Optional argument THUNK is a function of one argument which is used to
normalize OBJECT for comparison.

If there are several matching buttons, the first is returned.
This function will not find spacers."
  (setq toolbar (or toolbar default-toolbar))
  (setq locale (or locale 'global))
  (if thunk (setq object (funcall thunk object)))
  (let ((desc (cdadar (specifier-spec-list toolbar locale)))
	(pos 0))
    ;; #### rewrite this as a catch ... throw
    (while (not (equal object (let ((el (aref (car desc) index)))
				(if thunk (funcall thunk el) el))))
      (setq desc (cdr desc))
      (setq pos (1+ pos)))
    (if toolbar pos nil)))

(provide 'toolbar-utils)

;;; toolbar-utils.el ends here
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.