106 |
|
|
107 |
;;; Code: |
;;; Code: |
108 |
|
|
109 |
|
;; Note that this just gives a useful default. Icons are expected to |
110 |
|
;; be in subdirectory "images" or "toolbar" relative to the load-path. |
111 |
|
;; Packages loading toolbarx are advised to explicitly add their own |
112 |
|
;; searchpath with add-to-list here even when they fulfill that |
113 |
|
;; criterion: another package might have loaded toolbar-x previously |
114 |
|
;; when load-path was not yet correctly set. The default setting |
115 |
|
;; really caters only for toolbar-x' stock icons. |
116 |
|
|
117 |
|
(defvar toolbarx-image-path |
118 |
|
(nconc |
119 |
|
(delq nil (mapcar #'(lambda(x) |
120 |
|
(and (member |
121 |
|
(file-name-nondirectory |
122 |
|
(directory-file-name x)) |
123 |
|
'("toolbar" "images")) |
124 |
|
;;(file-directory-p x) |
125 |
|
x)) |
126 |
|
load-path)) |
127 |
|
(list data-directory)) |
128 |
|
"This is where toolbarx finds its images.") |
129 |
|
|
130 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
131 |
;;; First engine: Parsing buttons |
;;; First engine: Parsing buttons |
132 |
|
|
143 |
;; following elements are in the same format of the 2nd element of |
;; following elements are in the same format of the 2nd element of |
144 |
;; `toolbarx-internal-button-switches'. |
;; `toolbarx-internal-button-switches'. |
145 |
|
|
|
;;;###autoload |
|
146 |
(defun toolbarx-make-string-from-symbol (symbol) |
(defun toolbarx-make-string-from-symbol (symbol) |
147 |
"Return a string from the name of a SYMBOL. |
"Return a string from the name of a SYMBOL. |
148 |
Upcase initials and replace dashes by spaces." |
Upcase initials and replace dashes by spaces." |
154 |
(push i str2))) ; else push identical |
(push i str2))) ; else push identical |
155 |
(concat (nreverse str2)))) |
(concat (nreverse str2)))) |
156 |
|
|
|
;;;###autoload |
|
157 |
(defun toolbarx-make-symbol-from-string (string) |
(defun toolbarx-make-symbol-from-string (string) |
158 |
"Return a (intern) symbol from STRING. |
"Return a (intern) symbol from STRING. |
159 |
Downcase string and replace spaces by dashes." |
Downcase string and replace spaces by dashes." |
165 |
(push i str2))) |
(push i str2))) |
166 |
(intern (concat (nreverse str2))))) |
(intern (concat (nreverse str2))))) |
167 |
|
|
|
;;;###autoload |
|
168 |
(defun toolbarx-good-option-list-p (option-list valid-options) |
(defun toolbarx-good-option-list-p (option-list valid-options) |
169 |
"Non-nil means the OPTION-LIST is of form (OPT FORM ... OPT FORM). |
"Non-nil means the OPTION-LIST is of form (OPT FORM ... OPT FORM). |
170 |
Each OPT is member of VALID-OPTIONS and OPT are pairwise |
Each OPT is member of VALID-OPTIONS and OPT are pairwise |
187 |
;; OPTION-LIST has even number of elements |
;; OPTION-LIST has even number of elements |
188 |
(eq (% (length option-list) 2) 0)))) |
(eq (% (length option-list) 2) 0)))) |
189 |
|
|
|
;;;###autoload |
|
190 |
(defun toolbarx-separate-options (group-list valid-options &optional check) |
(defun toolbarx-separate-options (group-list valid-options &optional check) |
191 |
"Return a cons cell with non-options and options of GROUP-LIST. |
"Return a cons cell with non-options and options of GROUP-LIST. |
192 |
The options-part is the largest tail of the list GROUP-LIST that |
The options-part is the largest tail of the list GROUP-LIST that |
209 |
(cons (butlast group-list (length maximal)) maximal))) |
(cons (butlast group-list (length maximal)) maximal))) |
210 |
|
|
211 |
|
|
|
;;;###autoload |
|
212 |
(defun toolbarx-merge-props (inner-props outer-props override add) |
(defun toolbarx-merge-props (inner-props outer-props override add) |
213 |
"Merge property lists INNER-PROPS and OUTER-PROPS. |
"Merge property lists INNER-PROPS and OUTER-PROPS. |
214 |
INNER-PROPS and OUTER-PROPS are two lists in the format |
INNER-PROPS and OUTER-PROPS are two lists in the format |
250 |
(append inner-prop |
(append inner-prop |
251 |
outer-prop))))))))) |
outer-prop))))))))) |
252 |
|
|
|
;;;###autoload |
|
253 |
(defun toolbarx-make-command (comm prep app) |
(defun toolbarx-make-command (comm prep app) |
254 |
"Return a command made from COMM, PREP and APP. |
"Return a command made from COMM, PREP and APP. |
255 |
COMM is a command or a form. PREP and APP are forms. If PREP or |
COMM is a command or a form. PREP and APP are forms. If PREP or |
273 |
;; handle `menu titles' differently) meanwhile in XEmacs, menus are lists of |
;; handle `menu titles' differently) meanwhile in XEmacs, menus are lists of |
274 |
;; vectors |
;; vectors |
275 |
|
|
|
;;;###autoload |
|
276 |
(defun toolbarx-emacs-mount-popup-menu |
(defun toolbarx-emacs-mount-popup-menu |
277 |
(strings var type &optional title save) |
(strings var type &optional title save) |
278 |
"Return an interactive `lambda'-expression that shows a popup menu. |
"Return an interactive `lambda'-expression that shows a popup menu. |
343 |
;; returns a `lambda'-expression |
;; returns a `lambda'-expression |
344 |
`(lambda nil (interactive) (popup-menu (quote ,keymap))))) |
`(lambda nil (interactive) (popup-menu (quote ,keymap))))) |
345 |
|
|
|
;;;###autoload |
|
346 |
(defun toolbarx-xemacs-mount-popup-menu |
(defun toolbarx-xemacs-mount-popup-menu |
347 |
(strings var type &optional title save) |
(strings var type &optional title save) |
348 |
"Return an interactive `lambda'-expression that shows a popup menu. |
"Return an interactive `lambda'-expression that shows a popup menu. |
401 |
(let ((popup-menu-titles ,(if title t nil))) |
(let ((popup-menu-titles ,(if title t nil))) |
402 |
(popup-menu (quote ,menu)))))) |
(popup-menu (quote ,menu)))))) |
403 |
|
|
|
;;;###autoload |
|
404 |
(defun toolbarx-mount-popup-menu (strings var type &optional title save) |
(defun toolbarx-mount-popup-menu (strings var type &optional title save) |
405 |
"Return a command that show a popup menu. |
"Return a command that show a popup menu. |
406 |
The return is a `lambda'-expression with a interactive declaration. |
The return is a `lambda'-expression with a interactive declaration. |
426 |
(toolbarx-xemacs-mount-popup-menu strings var type title save) |
(toolbarx-xemacs-mount-popup-menu strings var type title save) |
427 |
(toolbarx-emacs-mount-popup-menu strings var type title save))) |
(toolbarx-emacs-mount-popup-menu strings var type title save))) |
428 |
|
|
|
;;;###autoload |
|
429 |
(defun toolbarx-option-value (opt) |
(defun toolbarx-option-value (opt) |
430 |
"Return option value according to Emacs flavour. |
"Return option value according to Emacs flavour. |
431 |
If OPT is a vector, return first element if in Emacs or |
If OPT is a vector, return first element if in Emacs or |
440 |
(aref opt 0))) |
(aref opt 0))) |
441 |
opt)) |
opt)) |
442 |
|
|
|
;;;###autoload |
|
443 |
(defun toolbarx-eval-function-or-symbol (object type-test-func) |
(defun toolbarx-eval-function-or-symbol (object type-test-func) |
444 |
"Return a cons cell (GOOD-OBJ . VAL). |
"Return a cons cell (GOOD-OBJ . VAL). |
445 |
GOOD-OBJ non-nil means that VAL is a valid value, according to |
GOOD-OBJ non-nil means that VAL is a valid value, according to |
465 |
(setq ret (funcall type-test-func (symbol-value object)))))) |
(setq ret (funcall type-test-func (symbol-value object)))))) |
466 |
ret)) |
ret)) |
467 |
|
|
|
;;;###autoload |
|
468 |
(defun toolbarx-test-image-type (obj) |
(defun toolbarx-test-image-type (obj) |
469 |
"Return a cons cell (GOOD-OBJ . VAL). |
"Return a cons cell (GOOD-OBJ . VAL). |
470 |
GOOD-OBJ is non-nil if OBJ yields a valid image object VAL (see |
GOOD-OBJ is non-nil if OBJ yields a valid image object VAL (see |
515 |
(cons good-obj val))))) |
(cons good-obj val))))) |
516 |
(toolbarx-eval-function-or-symbol obj toolbarx-test-image-type-simple))) |
(toolbarx-eval-function-or-symbol obj toolbarx-test-image-type-simple))) |
517 |
|
|
|
;;;###autoload |
|
518 |
(defun toolbarx-test-button-type (obj) |
(defun toolbarx-test-button-type (obj) |
519 |
"Return a cons cell (GOOD-OBJ . VAL). |
"Return a cons cell (GOOD-OBJ . VAL). |
520 |
GOOD-OBJ is non-nil if OBJ yields a valid button object VAL (see |
GOOD-OBJ is non-nil if OBJ yields a valid button object VAL (see |
531 |
(cons good-obj val))))) |
(cons good-obj val))))) |
532 |
(toolbarx-eval-function-or-symbol obj toolbarx-test-button-type-simple))) |
(toolbarx-eval-function-or-symbol obj toolbarx-test-button-type-simple))) |
533 |
|
|
|
;;;###autoload |
|
534 |
(defun toolbarx-test-any-type (obj) |
(defun toolbarx-test-any-type (obj) |
535 |
"Return a cons cell (t . VAL). |
"Return a cons cell (t . VAL). |
536 |
If OBJ is vector, return VAL according to editor. Else, return |
If OBJ is vector, return VAL according to editor. Else, return |
537 |
OBJ, because it is a form anyway." |
OBJ, because it is a form anyway." |
538 |
(cons t (toolbarx-option-value obj))) |
(cons t (toolbarx-option-value obj))) |
539 |
|
|
|
;;;###autoload |
|
540 |
(defun toolbarx-test-string-or-nil (obj) |
(defun toolbarx-test-string-or-nil (obj) |
541 |
"Return a cons cell (GOOD-OBJ . VAL). |
"Return a cons cell (GOOD-OBJ . VAL). |
542 |
GOOD-OBJ is non-nil if OBJ yields a valid help object VAL (see |
GOOD-OBJ is non-nil if OBJ yields a valid help object VAL (see |
549 |
(cons good-obj val))))) |
(cons good-obj val))))) |
550 |
(toolbarx-eval-function-or-symbol obj toolbarx-test-string-or-nil-simple))) |
(toolbarx-eval-function-or-symbol obj toolbarx-test-string-or-nil-simple))) |
551 |
|
|
|
;;;###autoload |
|
552 |
(defun toolbarx-test-toolbar-type (obj) |
(defun toolbarx-test-toolbar-type (obj) |
553 |
"Return a cons cell (GOOD-OBJ . VAL). |
"Return a cons cell (GOOD-OBJ . VAL). |
554 |
GOOD-OBJ is non-nil if OBJ yields a valid toolbar property object |
GOOD-OBJ is non-nil if OBJ yields a valid toolbar property object |
571 |
(cons good-obj val))))) |
(cons good-obj val))))) |
572 |
(toolbarx-eval-function-or-symbol obj toolbarx-test-toolbar-type-simple))) |
(toolbarx-eval-function-or-symbol obj toolbarx-test-toolbar-type-simple))) |
573 |
|
|
|
;;;###autoload |
|
574 |
(defun toolbarx-test-dropdown-type (obj) |
(defun toolbarx-test-dropdown-type (obj) |
575 |
"Return a cons cell (GOOD-OBJ . VAL). |
"Return a cons cell (GOOD-OBJ . VAL). |
576 |
GOOD-OBJ is non-nil if OBJ yields a valid `:type' property object |
GOOD-OBJ is non-nil if OBJ yields a valid `:type' property object |
583 |
(cons good-obj val))))) |
(cons good-obj val))))) |
584 |
(toolbarx-eval-function-or-symbol obj toolbarx-test-dropdown-type-simple))) |
(toolbarx-eval-function-or-symbol obj toolbarx-test-dropdown-type-simple))) |
585 |
|
|
|
;;;###autoload |
|
586 |
(defun toolbarx-test-symbol (obj) |
(defun toolbarx-test-symbol (obj) |
587 |
"Return a cons cell (GOOD-OBJ . VAL). |
"Return a cons cell (GOOD-OBJ . VAL). |
588 |
GOOD-OBJ is non-nil if OBJ yields a valid `:variable' property |
GOOD-OBJ is non-nil if OBJ yields a valid `:variable' property |
595 |
(cons good-obj val))))) |
(cons good-obj val))))) |
596 |
(toolbarx-eval-function-or-symbol obj toolbarx-test-symbol-simple))) |
(toolbarx-eval-function-or-symbol obj toolbarx-test-symbol-simple))) |
597 |
|
|
|
;;;###autoload |
|
598 |
(defun toolbarx-test-dropdown-default (obj) |
(defun toolbarx-test-dropdown-default (obj) |
599 |
"Return a cons cell (GOOD-OBJ . VAL). |
"Return a cons cell (GOOD-OBJ . VAL). |
600 |
GOOD-OBJ is non-nil if OBJ yields a valid `:default' property |
GOOD-OBJ is non-nil if OBJ yields a valid `:default' property |
612 |
(toolbarx-eval-function-or-symbol obj |
(toolbarx-eval-function-or-symbol obj |
613 |
toolbarx-test-dropdown-default-simple))) |
toolbarx-test-dropdown-default-simple))) |
614 |
|
|
|
;;;###autoload |
|
615 |
(defun toolbarx-test-dropdown-save (obj) |
(defun toolbarx-test-dropdown-save (obj) |
616 |
"Return a cons cell (GOOD-OBJ . VAL). |
"Return a cons cell (GOOD-OBJ . VAL). |
617 |
GOOD-OBJ is non-nil if OBJ yields a valid `:save' property |
GOOD-OBJ is non-nil if OBJ yields a valid `:save' property |
694 |
with the strings \":dropdown-\" with the button property name |
with the strings \":dropdown-\" with the button property name |
695 |
without `:'. This is used on the implementation.") |
without `:'. This is used on the implementation.") |
696 |
|
|
|
;;;###autoload |
|
697 |
(defun toolbarx-process-group-without-insert (group-without-props |
(defun toolbarx-process-group-without-insert (group-without-props |
698 |
merged-props-without-insert |
merged-props-without-insert |
699 |
meaning-alist switches) |
meaning-alist switches) |
714 |
merged-props-without-insert |
merged-props-without-insert |
715 |
current-switches))))))) |
current-switches))))))) |
716 |
|
|
|
;;;###autoload |
|
717 |
(defun toolbarx-process-group (group meaning-alist props switches) |
(defun toolbarx-process-group (group meaning-alist props switches) |
718 |
"Return an updated version of SWITCHES. |
"Return an updated version of SWITCHES. |
719 |
Append to already processed buttons (stored in SWITCHES) a |
Append to already processed buttons (stored in SWITCHES) a |
793 |
merged-props meaning-alist |
merged-props meaning-alist |
794 |
switches)))))) |
switches)))))) |
795 |
|
|
|
;;;###autoload |
|
796 |
(defun toolbarx-process-symbol (symbol meaning-alist props switches) |
(defun toolbarx-process-symbol (symbol meaning-alist props switches) |
797 |
"Process a button given by SYMBOL in MEANING-ALIST. |
"Process a button given by SYMBOL in MEANING-ALIST. |
798 |
The processed button is appended in SWITCHES, which is returned. |
The processed button is appended in SWITCHES, which is returned. |
847 |
;; return: |
;; return: |
848 |
(nreverse (cons (cons symbol merged-props) (nreverse switches)))))))) |
(nreverse (cons (cons symbol merged-props) (nreverse switches)))))))) |
849 |
|
|
|
;;;###autoload |
|
850 |
(defun toolbarx-process-dropdown-group (dropdown meaning-alist props switches) |
(defun toolbarx-process-dropdown-group (dropdown meaning-alist props switches) |
851 |
"Process buttons that appear according to dropdown menu. |
"Process buttons that appear according to dropdown menu. |
852 |
Process a dropdown group DROPDOWN with meaning alist |
Process a dropdown group DROPDOWN with meaning alist |
1098 |
;;; How a image is made, giving a string as (part of) file name. |
;;; How a image is made, giving a string as (part of) file name. |
1099 |
|
|
1100 |
;; look at function `image-type-available-p' for Emacs !!!! |
;; look at function `image-type-available-p' for Emacs !!!! |
1101 |
;;;###autoload; |
|
1102 |
(defun toolbarx-find-image (filename) |
(defun toolbarx-find-image (filename) |
1103 |
"Return a image object from image on FILENAME, a string. |
"Return a image object from image on FILENAME, a string. |
1104 |
In Emacs, return a image descriptor from FILENAME and in Xemacs, |
In Emacs, return a image descriptor from FILENAME and in Xemacs, |
1109 |
(let ((file)) |
(let ((file)) |
1110 |
(dolist (i '("" ".xpm" ".xbm" ".pbm")) |
(dolist (i '("" ".xpm" ".xbm" ".pbm")) |
1111 |
(unless file |
(unless file |
1112 |
(setq file (locate-library (concat filename i) t load-path))) |
(setq file (locate-library (concat filename i) t toolbarx-image-path)))) |
|
(unless file |
|
|
(setq file (locate-library (concat filename i) t `(,data-directory))))) |
|
1113 |
(when file |
(when file |
1114 |
(funcall (if (featurep 'xemacs) 'make-glyph 'create-image) |
(funcall (if (featurep 'xemacs) 'make-glyph 'create-image) |
1115 |
file)))) |
file)))) |
1124 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
1125 |
;;; Second engine: display parsed buttons in Emacs |
;;; Second engine: display parsed buttons in Emacs |
1126 |
|
|
|
;;;###autoload |
|
1127 |
(defun toolbarx-emacs-add-button (button &optional used-keys) |
(defun toolbarx-emacs-add-button (button &optional used-keys) |
1128 |
"Insert a button where BUTTON is its description. |
"Insert a button where BUTTON is its description. |
1129 |
In Emacs, insert a button to keymap `tool-bar-map' at the end. |
In Emacs, insert a button to keymap `tool-bar-map' at the end. |
1278 |
(when used-keys (setcdr used-keys used-keys-list)))) |
(when used-keys (setcdr used-keys used-keys-list)))) |
1279 |
|
|
1280 |
|
|
|
;;;###autoload |
|
1281 |
(defun toolbarx-emacs-refresh-process-button-or-insert-list (switches |
(defun toolbarx-emacs-refresh-process-button-or-insert-list (switches |
1282 |
&optional |
&optional |
1283 |
used-keys) |
used-keys) |
1296 |
|
|
1297 |
|
|
1298 |
|
|
|
|
|
|
;;;###autoload |
|
1299 |
(defun toolbarx-emacs-refresh (&optional global-flag) |
(defun toolbarx-emacs-refresh (&optional global-flag) |
1300 |
"Refresh and redraw the toolbar in Emacs. |
"Refresh and redraw the toolbar in Emacs. |
1301 |
If GLOBAL-FLAG is non-nil, the default value of toolbar switches |
If GLOBAL-FLAG is non-nil, the default value of toolbar switches |
1318 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
1319 |
;;; Third engine: display parsed buttons in XEmacs |
;;; Third engine: display parsed buttons in XEmacs |
1320 |
|
|
|
;;;###autoload |
|
1321 |
(defun toolbarx-xemacs-image-properties (image) |
(defun toolbarx-xemacs-image-properties (image) |
1322 |
"Return a list of properties of IMAGE. |
"Return a list of properties of IMAGE. |
1323 |
IMAGE should be a string or a list of one to six strings or |
IMAGE should be a string or a list of one to six strings or |
1403 |
|
|
1404 |
|
|
1405 |
|
|
|
;;;###autoload |
|
1406 |
(defun toolbarx-xemacs-button-properties (button) |
(defun toolbarx-xemacs-button-properties (button) |
1407 |
"Return a list of properties of BUTTON. |
"Return a list of properties of BUTTON. |
1408 |
The result is either nil (if not to be inserted) or a list in the format |
The result is either nil (if not to be inserted) or a list in the format |
1565 |
default-width top-height right-width bottom-height left-width))) |
default-width top-height right-width bottom-height left-width))) |
1566 |
|
|
1567 |
|
|
|
;;;###autoload |
|
1568 |
(defun toolbarx-xemacs-refresh (&optional global-flag) |
(defun toolbarx-xemacs-refresh (&optional global-flag) |
1569 |
"Refresh the toolbar in XEmacs." |
"Refresh the toolbar in XEmacs." |
1570 |
(let* ((switches (if global-flag |
(let* ((switches (if global-flag |