Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-toolbar.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; w3-toolbar.el,v --- Toolbar functions for emacs-w3
2 ;; Author: wmperry
3 ;; Created: 1996/05/01 16:00:48
4 ;; Version: 1.10
5 ;; Keywords: mouse, toolbar
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1995 by William M. Perry (wmperry@spry.com)
9 ;;;
10 ;;; This file is part of GNU Emacs.
11 ;;;
12 ;;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2, or (at your option)
15 ;;; any later version.
16 ;;;
17 ;;; GNU Emacs is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with GNU Emacs; see the file COPYING. If not, write to
24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 ;;; Toolbar specific function for XEmacs 19.12+
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 (require 'xpm-button)
31 (require 'xbm-button)
32
33 (defvar w3-toolbar-icon-directory nil "Where the toolbar icons for w3 are.")
34 (defvar w3-toolbar-back-icon nil "Toolbar icon for back")
35 (defvar w3-toolbar-forw-icon nil "Toolbar icon for forward")
36 (defvar w3-toolbar-home-icon nil "Toolbar icon for home")
37 (defvar w3-toolbar-reld-icon nil "Toolbar icon for reload")
38 (defvar w3-toolbar-imag-icon nil "Toolbar icon for images")
39 (defvar w3-toolbar-open-icon nil "Toolbar icon for open url")
40 (defvar w3-toolbar-print-icon nil "Toolbar icon for printing")
41 (defvar w3-toolbar-find-icon nil "Toolbar icon for find")
42 (defvar w3-toolbar-stop-icon nil "Toolbar icon for stop")
43 (defvar w3-toolbar-help-icon nil "Toolbar icon for help")
44 (defvar w3-toolbar-hotl-icon nil "Toolbar icon for hotlist")
45
46 (defvar w3-link-toolbar-orientation 'bottom
47 "*Where to put the document specific toolbar. Must be one of these symbols:
48
49 default -- place at location specified by `default-toolbar-position'
50 top -- place along the top of the frame
51 bottom -- place along the bottom of the frame
52 right -- place along the right edge of the frame
53 left -- place along the left edge of the frame
54 none -- no toolbar")
55
56 (defvar w3-toolbar-orientation 'default
57 "*Where to put the w3 toolbar. Must be one of these symbols:
58
59 default -- place at location specified by `default-toolbar-position'
60 top -- place along the top of the frame
61 bottom -- place along the bottom of the frame
62 right -- place along the right edge of the frame
63 left -- place along the left edge of the frame
64 none -- no toolbar")
65
66 (defvar w3-toolbar-type 'both
67 "*What the toolbar looks like. Must be one of these symbols:
68
69 pictures -- Show icons (without captions if in XEmacs 19.13)
70 both -- Show icons (with captions if in XEmacs 19.13)
71 text -- Show only text buttons
72
73 Only has any meaning in XEmacs 19.12 when w3-toolbar-orientation is
74 not `none'.")
75
76 (defvar w3-toolbar
77 '([w3-toolbar-back-icon w3-backward-in-history t "Back in history"]
78 [w3-toolbar-forw-icon w3-forward-in-history t "Forward in history"]
79 [w3-toolbar-home-icon w3 t "Go home"]
80 [:style 2d :size 5]
81 [w3-toolbar-reld-icon w3-reload-document t "Reload document"]
82 [w3-toolbar-hotl-icon w3-show-hotlist t "View hotlist"]
83 [w3-toolbar-imag-icon w3-load-delayed-images w3-delayed-images
84 "Load images"]
85 [toolbar-file-icon w3-fetch t "Fetch a URL"]
86 [toolbar-printer-icon w3-mouse-print-this-url t "Print document"]
87 [w3-toolbar-find-icon w3-search-forward t "Search"]
88 ;;[w3-toolbar-stop-icon keyboard-quit t "Stop transaction"]
89 nil
90 [w3-toolbar-help-icon w3-show-info-node t "Help"])
91 "The toolbar for w3")
92
93 (defun w3-toolbar-make-captioned-buttons ()
94 (mapcar
95 (function
96 (lambda (x)
97 (let* ((ext (if (featurep 'xpm) ".xpm" ".xbm"))
98 (base w3-toolbar-icon-directory)
99 (up (expand-file-name (concat x "-up" ext) base))
100 (dn (expand-file-name (concat x "-dn" ext) base))
101 (no (expand-file-name (concat x "-no" ext) base))
102 (cap-up (expand-file-name (concat x "-cap-up" ext) base))
103 (cap-dn (expand-file-name (concat x "-cap-dn" ext) base))
104 (cap-no (expand-file-name (concat x "-cap-no" ext) base))
105 (var (intern (concat "w3-toolbar-" x "-icon"))))
106 (set var
107 (toolbar-make-button-list up dn no cap-up cap-dn cap-no)))))
108
109 '("back" "help" "find" "forw" "home" "hotl" "stop" "imag" "reld")))
110
111 (defun w3-make-text-toolbar-button (text)
112 (let ((bgcol (or
113 (cdr-safe (assq 'background-toolbar-color (frame-parameters)))
114 "#befbbefbbefb")))
115 (if (featurep 'xpm)
116 (mapcar 'make-glyph (xpm-button-create text 0 "black" bgcol))
117 (xbm-button-create text 0))))
118
119 (defun w3-toolbar-make-text-buttons ()
120 (let ((bgcol (or (cdr-safe (assq 'background-toolbar-color
121 (frame-parameters)))
122 "#befbbefbbefb")))
123 (setq w3-toolbar-back-icon (w3-make-text-toolbar-button "Back")
124 w3-toolbar-forw-icon (w3-make-text-toolbar-button "Forward")
125 w3-toolbar-home-icon (w3-make-text-toolbar-button "Home")
126 w3-toolbar-reld-icon (w3-make-text-toolbar-button "Reload")
127 w3-toolbar-hotl-icon (w3-make-text-toolbar-button "Hotlist")
128 w3-toolbar-imag-icon (w3-make-text-toolbar-button "Images")
129 w3-toolbar-open-icon (w3-make-text-toolbar-button "Open")
130 w3-toolbar-print-icon (w3-make-text-toolbar-button "Print")
131 w3-toolbar-find-icon (w3-make-text-toolbar-button "Find")
132 w3-toolbar-help-icon (w3-make-text-toolbar-button "Help!"))))
133
134 (defun w3-toolbar-make-picture-buttons ()
135 (mapcar
136 (function
137 (lambda (x)
138 (let* ((ext (if (featurep 'xpm) ".xpm" ".xbm"))
139 (base w3-toolbar-icon-directory)
140 (up (expand-file-name (concat x "-cap-up" ext) base))
141 (dn (expand-file-name (concat x "-cap-dn" ext) base))
142 (no (expand-file-name (concat x "-cap-no" ext) base))
143 (var (intern (concat "w3-toolbar-" x "-icon"))))
144 (set var
145 (cond
146 ((and (file-exists-p up) (file-exists-p dn)
147 (file-exists-p no))
148 (toolbar-make-button-list up dn no))
149 ((file-exists-p up)
150 (toolbar-make-button-list up))
151 (t nil))))))
152 '("back" "help" "find" "forw" "home" "hotl" "imag" "reld")))
153
154 (defun w3-toolbar-make-buttons ()
155 (if (not w3-toolbar-icon-directory)
156 (setq w3-toolbar-icon-directory
157 (file-name-as-directory
158 (expand-file-name "w3" data-directory))))
159 (cond
160 ((not (file-exists-p w3-toolbar-icon-directory))
161 (w3-warn 'files "Toolbar directory does not exist."))
162 ((not (fboundp 'toolbar-make-button-list))
163 nil)
164 ((eq w3-toolbar-type 'text)
165 (w3-toolbar-make-text-buttons))
166 ((boundp 'toolbar-buttons-captioned-p)
167 (w3-toolbar-make-captioned-buttons))
168 (t
169 (w3-toolbar-make-picture-buttons))))
170
171 (defun w3-link-is-defined (rel &optional rev)
172 (or
173 (cdr-safe (assoc rel (cdr-safe (assoc "Parent of" w3-current-links))))
174 (cdr-safe (assoc (or rev rel) (cdr-safe (assoc "Child of"
175 w3-current-links))))))
176
177 ;; Need to create w3-toolbar-glos-icon
178 ;; w3-toolbar-toc-icon
179 ;; w3-toolbar-copy-icon
180 (defvar w3-link-toolbar
181 '([info::toolbar-prev-icon
182 (w3-fetch (w3-link-is-defined "previous" "next"))
183 (w3-link-is-defined "previous" "next")
184 "Back"]
185 [info::toolbar-next-icon
186 (w3-fetch (w3-link-is-defined "next" "previous"))
187 (w3-link-is-defined "next" "previous")
188 "Next"]
189 [info::toolbar-up-icon
190 (w3-fetch (w3-link-is-defined "up" "down"))
191 (w3-link-is-defined "up" "down")
192 "Up"]
193 [w3-toolbar-home-icon
194 (w3-fetch (w3-link-is-defined "home"))
195 (w3-link-is-defined "home")
196 "Home"]
197 [w3-toolbar-toc-icon
198 (w3-fetch (w3-link-is-defined "toc"))
199 (w3-link-is-defined "toc")
200 "Contents"]
201 [w3-toolbar-find-icon
202 (w3-fetch (w3-link-is-defined "index"))
203 (w3-link-is-defined "index")
204 "Index"]
205 [w3-toolbar-glos-icon
206 (w3-fetch (w3-link-is-defined "glossary"))
207 (w3-link-is-defined "glossary")
208 "Glossary"]
209 [w3-toolbar-copy-icon
210 (w3-fetch (w3-link-is-defined "copyright"))
211 (w3-link-is-defined "copyright")
212 "Copyright"]
213 [w3-toolbar-hotl-icon
214 (w3-fetch (w3-link-is-defined "bookmark"))
215 (w3-link-is-defined "bookmark")
216 "Bookmarks"]
217 nil
218 [w3-toolbar-help-icon
219 (w3-fetch (w3-link-is-defined "help"))
220 (w3-link-is-defined "help")
221 "Help"]
222 ))
223
224 (defun w3-toolbar-from-orientation (orientation)
225 (cond
226 ((eq 'default w3-toolbar-orientation) default-toolbar)
227 ((eq 'bottom w3-toolbar-orientation) bottom-toolbar)
228 ((eq 'top w3-toolbar-orientation) top-toolbar)
229 ((eq 'left w3-toolbar-orientation) left-toolbar)
230 ((eq 'right w3-toolbar-orientation) right-toolbar)))
231
232 (defun w3-toolbar-dimension-from-orientation (orientation)
233 (cond
234 ((eq 'default w3-toolbar-orientation) nil)
235 ((eq 'bottom w3-toolbar-orientation) bottom-toolbar-height)
236 ((eq 'top w3-toolbar-orientation) top-toolbar-height)
237 ((eq 'left w3-toolbar-orientation) left-toolbar-width)
238 ((eq 'right w3-toolbar-orientation) right-toolbar-width)))
239
240 (defun w3-ensure-toolbar-visible (orientation)
241 ;; Make sure a certain toolbar is visible if necessary
242 ;; This can modify frame parameters, so watch out.
243 (let ((dimension (w3-toolbar-dimension-from-orientation orientation))
244 (toolbar (w3-toolbar-from-orientation orientation))
245 (dimensions nil)
246 (widths nil)
247 (heights nil)
248 (needs nil)
249 (has nil))
250 (if (and dimension toolbar
251 (setq toolbar (specifier-instance toolbar)))
252 (progn
253 (setq dimensions (mapcar
254 (function
255 (lambda (glyph)
256 (and (glyphp glyph)
257 (cons (glyph-width glyph)
258 (glyph-height glyph)))))
259 (mapcar 'car
260 (delq nil
261 (mapcar
262 (function (lambda (x)
263 (and x
264 (symbol-value
265 (aref x 0)))))
266 toolbar))))
267 widths (sort (mapcar 'car dimensions) '>=)
268 heights (sort (mapcar 'cdr dimensions) '>=)
269 needs (+ 7 (if (memq orientation '(top bottom))
270 (car heights)
271 (car widths)))
272 has (specifier-instance dimension))
273 (if (<= has needs)
274 (set-specifier dimension (cons (selected-frame) needs)))))))
275
276 (defun w3-toolbar-active ()
277 (interactive)
278 (let ((toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
279 (if (and toolbar (specifier-instance toolbar))
280 t
281 nil)))
282
283 (defun w3-toggle-link-toolbar ()
284 (interactive)
285 (require 'info) ; For some toolbar buttons
286 (let* ((w3-toolbar-orientation w3-link-toolbar-orientation)
287 (toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
288 (if toolbar
289 (if (w3-toolbar-active)
290 (set-specifier toolbar (cons (current-buffer) nil))
291 (set-specifier toolbar (cons (current-buffer) w3-link-toolbar))))))
292
293 (defun w3-toggle-toolbar ()
294 (interactive)
295 (if (eq major-mode 'w3-mode)
296 (let ((toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
297 (cond
298 ((w3-toolbar-active)
299 (set-specifier toolbar (cons (current-buffer) nil)))
300 (toolbar
301 (set-specifier toolbar (cons (current-buffer) w3-toolbar)))
302 (t
303 (setq w3-toolbar-orientation 'default
304 toolbar (w3-toolbar-from-orientation w3-toolbar-orientation))
305 (and toolbar
306 (set-specifier toolbar (cons (current-buffer) w3-toolbar))))))
307 (if (not (eq w3-toolbar-orientation 'none))
308 (setq w3-toolbar-orientation 'none)
309 (setq w3-toolbar-orientation 'default))))
310
311 (defun w3-show-info-node ()
312 (interactive)
313 (Info-goto-node "(w3.info)Top"))
314
315 (defun w3-mouse-print-this-url (&optional e)
316 (interactive "e")
317 (let ((descr '("Print document as"
318 ["PostScript" (w3-print-this-url nil "PostScript") t]
319 ["Formatted Text" (w3-print-this-url nil "Formatted Text") t]
320 ["HTML Source" (w3-print-this-url nil "HTML Source") t]
321 ["LaTeX'd" (w3-print-this-url nil "LaTeX'd") t]
322 nil
323 ["Cancel" (beep) t])))
324 (popup-dialog-box descr)))
325
326 (defun w3-add-toolbar-to-buffer ()
327 (if (not (featurep 'toolbar))
328 nil
329 (let ((toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
330 (if toolbar
331 (set-specifier toolbar (cons (current-buffer) w3-toolbar))))
332 (set-specifier toolbar-buttons-captioned-p
333 (cons (current-buffer) (eq w3-toolbar-type 'both)))))
334
335 (provide 'w3-toolbar)