cgit.sxemacs.org Git - packages/blob - xemacs-packages/w3/lisp/w3-toolbar.el

   1 ;;; w3-toolbar.el --- Toolbar functions for emacs-w3
   2 ;; Author: William M. Perry <wmperry@gnu.org>
   3 ;; Created: $Date: 2001/07/19 14:15:52 $
   4 ;; Version: $Revision: 1.8 $
   5 ;; Keywords: mouse, toolbar
   6
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;; Copyright (c) 1995, 1996 by William M. Perry <wmperry@cs.indiana.edu>
   9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10 ;;;
  11 ;;; This file is part of GNU Emacs.
  12 ;;;
  13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;;; it under the terms of the GNU General Public License as published by
  15 ;;; the Free Software Foundation; either version 2, or (at your option)
  16 ;;; any later version.
  17 ;;;
  18 ;;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;;; GNU General Public License for more details.
  22 ;;;
  23 ;;; You should have received a copy of the GNU General Public License
  24 ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;;; Boston, MA 02111-1307, USA.
  27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28
  29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30 ;;; Toolbar specific function for XEmacs and Emacs 21
  31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32 (condition-case ()
  33     (progn
  34       (require 'xpm-button)
  35       (require 'xbm-button))
  36   (error nil))
  37
  38 (defvar w3-toolbar-icon-directory nil
  39   "Where the toolbar icons for W3 are.
  40 In Emacs, this is searched preferentially to the normal search path.")
  41 (defvar w3-toolbar-back-icon (if (featurep 'tool-bar)
  42                                  "left_arrow")
  43   "Toolbar icon for back")
  44 (defvar w3-toolbar-forw-icon (if (featurep 'tool-bar)
  45                                  "right_arrow")
  46   "Toolbar icon for forward")
  47 (defvar w3-toolbar-home-icon (if (featurep 'tool-bar)
  48                                  "home")
  49   "Toolbar icon for home")
  50 (defvar w3-toolbar-reld-icon (if (featurep 'tool-bar)
  51                                  "refresh")
  52   "Toolbar icon for reload")
  53 (defvar w3-toolbar-imag-icon (if (featurep 'tool-bar)
  54                                  "images")
  55   "Toolbar icon for images")
  56 (defvar w3-toolbar-open-icon (if (featurep 'tool-bar)
  57                                  "open")
  58   "Toolbar icon for open url")
  59 (defvar w3-toolbar-print-icon (if (featurep 'tool-bar)
  60                                   "print")
  61   "Toolbar icon for printing")
  62 (defvar w3-toolbar-find-icon (if (featurep 'tool-bar)
  63                                  "search")
  64   "Toolbar icon for find")
  65 (defvar w3-toolbar-stop-icon (if (featurep 'tool-bar)
  66                                  "cancel")
  67   "Toolbar icon for stop")
  68 (defvar w3-toolbar-help-icon (if (featurep 'tool-bar)
  69                                  "help")
  70   "Toolbar icon for help")
  71 (defvar w3-toolbar-hotl-icon (if (featurep 'tool-bar)
  72                                  "jump_to")
  73   "Toolbar icon for hotlist")
  74 (defvar w3-toolbar-file-icon (if (featurep 'tool-bar)
  75                                  "new")
  76   "Toolbar icon for open url")
  77 (defvar w3-toolbar-printer-icon (if (featurep 'tool-bar)
  78                                  "print")
  79   "Toolbar icon for open url")
  80
  81 (defvar w3-link-toolbar-orientation 'bottom
  82   "*Where to put the document specific toolbar.  Must be one of these symbols:
  83
  84 default -- place at location specified by `default-toolbar-position'
  85 top     -- place along the top of the frame
  86 bottom  -- place along the bottom of the frame
  87 right   -- place along the right edge of the frame
  88 left    -- place along the left edge of the frame
  89 none    -- no toolbar")
  90
  91 (defvar w3-toolbar-orientation 'default
  92   "*Where to put the w3 toolbar.  Must be one of these symbols:
  93
  94 default -- place at location specified by `default-toolbar-position'
  95 top     -- place along the top of the frame
  96 bottom  -- place along the bottom of the frame
  97 right   -- place along the right edge of the frame
  98 left    -- place along the left edge of the frame
  99 none    -- no toolbar")
 100
 101 (defvar w3-toolbar-type 'both
 102   "*What the toolbar looks like.  Must be one of these symbols:
 103
 104 pictures -- Show icons (without captions if in XEmacs 19.13)
 105 both     -- Show icons (with captions if in XEmacs 19.13)
 106 text     -- Show only text buttons
 107
 108 Only has any meaning in XEmacs 19.12 when w3-toolbar-orientation is
 109 not `none'.")
 110
 111 (defvar w3-toolbar
 112   '([w3-toolbar-back-icon w3-history-backward (car (w3-history-find-url-internal (url-view-url t))) "Back in history"]
 113     [w3-toolbar-forw-icon w3-history-forward (cdr (w3-history-find-url-internal (url-view-url t))) "Forward in history"]
 114     [w3-toolbar-home-icon w3 t "Go home"]
 115     [:style 2d :size 5]
 116     [w3-toolbar-reld-icon w3-reload-document t "Reload document"]
 117     [w3-toolbar-hotl-icon w3-hotlist-view t "View hotlist"]
 118     [w3-toolbar-imag-icon w3-load-delayed-images w3-delayed-images
 119                           "Load images"]
 120     [toolbar-file-icon w3-fetch t "Fetch a URL"]
 121     [toolbar-printer-icon w3-mouse-print-this-url t "Print document"]
 122     [w3-toolbar-find-icon w3-search-forward t "Search"]
 123     ;;[w3-toolbar-stop-icon keyboard-quit t "Stop transaction"]
 124     nil
 125     [w3-toolbar-help-icon w3-show-info-node t "Help"])
 126   "The toolbar for w3")
 127
 128 (defun w3-toolbar-make-captioned-buttons ()
 129   (mapcar
 130    (function
 131     (lambda (x)
 132       (let* ((ext (if (featurep 'xpm) ".xpm" ".xbm"))
 133              (base w3-toolbar-icon-directory)
 134              (up (expand-file-name (concat x "-up" ext) base))
 135              (dn (expand-file-name (concat x "-dn" ext) base))
 136              (no (expand-file-name (concat x "-no" ext) base))
 137              (cap-up (expand-file-name (concat x "-cap-up" ext) base))
 138              (cap-dn (expand-file-name (concat x "-cap-dn" ext) base))
 139              (cap-no (expand-file-name (concat x "-cap-no" ext) base))
 140              (var (intern (concat "w3-toolbar-" x "-icon"))))
 141         (set var
 142              (toolbar-make-button-list up dn no cap-up cap-dn cap-no)))))
 143
 144    '("back" "help" "find" "forw" "home"  "hotl" "stop" "imag" "reld")))
 145
 146 (defun w3-make-text-toolbar-button (text)
 147   (let ((bgcol (or
 148                 (cdr-safe (assq 'background-toolbar-color (frame-parameters)))
 149                 "#befbbefbbefb")))
 150     (if (featurep 'xpm)
 151         (mapcar 'make-glyph (xpm-button-create text 0 "black" bgcol))
 152       (xbm-button-create text 0))))
 153
 154 (defun w3-toolbar-make-text-buttons ()
 155   (let ((bgcol (or (cdr-safe (assq 'background-toolbar-color
 156                                    (frame-parameters)))
 157                    "#befbbefbbefb")))
 158     (setq w3-toolbar-back-icon (w3-make-text-toolbar-button "Back")
 159           w3-toolbar-forw-icon (w3-make-text-toolbar-button "Forward")
 160           w3-toolbar-home-icon (w3-make-text-toolbar-button "Home")
 161           w3-toolbar-reld-icon (w3-make-text-toolbar-button "Reload")
 162           w3-toolbar-hotl-icon (w3-make-text-toolbar-button "Hotlist")
 163           w3-toolbar-imag-icon (w3-make-text-toolbar-button "Images")
 164           w3-toolbar-open-icon (w3-make-text-toolbar-button "Open")
 165           w3-toolbar-print-icon (w3-make-text-toolbar-button "Print")
 166           w3-toolbar-find-icon (w3-make-text-toolbar-button "Find")
 167           w3-toolbar-help-icon (w3-make-text-toolbar-button "Help!"))))
 168
 169 (defun w3-toolbar-make-picture-buttons ()
 170   (mapcar
 171    (function
 172     (lambda (x)
 173       (let* ((ext (if (featurep 'xpm) ".xpm" ".xbm"))
 174              (base w3-toolbar-icon-directory)
 175              (up (expand-file-name (concat x "-cap-up" ext) base))
 176              (dn (expand-file-name (concat x "-cap-dn" ext) base))
 177              (no (expand-file-name (concat x "-cap-no" ext) base))
 178              (var (intern (concat "w3-toolbar-" x "-icon"))))
 179         (set var
 180              (cond
 181               ((and (file-exists-p up) (file-exists-p dn)
 182                     (file-exists-p no))
 183                (toolbar-make-button-list up dn no))
 184               ((file-exists-p up)
 185                (toolbar-make-button-list up))
 186               (t nil))))))
 187    '("back" "help" "find" "forw" "home" "hotl" "imag" "reld")))
 188
 189 (defun w3-toolbar-make-buttons ()
 190   (if (not w3-toolbar-icon-directory)
 191       (setq w3-toolbar-icon-directory
 192             (if (fboundp 'locate-data-directory)
 193                 (locate-data-directory "w3")
 194               (file-name-as-directory
 195                (expand-file-name "w3" data-directory)))))
 196   (condition-case nil
 197       (cond
 198        ((not (fboundp 'toolbar-make-button-list))
 199         nil)
 200        ((or (eq w3-toolbar-type 'text)
 201             (null w3-toolbar-icon-directory)
 202             (not (file-directory-p w3-toolbar-icon-directory)))
 203         (w3-toolbar-make-text-buttons))
 204        ((boundp 'toolbar-buttons-captioned-p)
 205         (w3-toolbar-make-captioned-buttons))
 206        ((featurep 'tool-bar)
 207         nil)
 208        ;; Fixme: Redundant?  XEmacs versions supported have captioned
 209        ;; buttons.
 210        (t
 211         (w3-toolbar-make-picture-buttons)))
 212     (error nil)))
 213
 214 (defun w3-link-is-defined (rel &optional rev)
 215   (or
 216    (cdr-safe (assoc rel (cdr-safe (assq 'rel w3-current-links))))
 217    (cdr-safe (assoc (or rev rel) (cdr-safe (assq 'rev w3-current-links))))))
 218
 219 ;; Need to create w3-toolbar-glos-icon
 220 ;;                w3-toolbar-toc-icon
 221 ;;                w3-toolbar-copy-icon
 222 (defvar w3-link-toolbar
 223   '([info::toolbar-prev-icon
 224      (w3-fetch (w3-link-is-defined "previous" "next"))
 225      (w3-link-is-defined "previous" "next")
 226      "Back"]
 227     [info::toolbar-next-icon
 228      (w3-fetch (w3-link-is-defined "next" "previous"))
 229      (w3-link-is-defined "next" "previous")
 230      "Next"]
 231     [info::toolbar-up-icon
 232      (w3-fetch (w3-link-is-defined "up" "down"))
 233      (w3-link-is-defined "up" "down")
 234      "Up"]
 235     [w3-toolbar-home-icon
 236      (w3-fetch (w3-link-is-defined "home"))
 237      (w3-link-is-defined "home")
 238      "Home"]
 239     [w3-toolbar-toc-icon
 240      (w3-fetch (w3-link-is-defined "toc"))
 241      (w3-link-is-defined "toc")
 242      "Contents"]
 243     [w3-toolbar-find-icon
 244      (w3-fetch (w3-link-is-defined "index"))
 245      (w3-link-is-defined "index")
 246      "Index"]
 247     [w3-toolbar-glos-icon
 248      (w3-fetch (w3-link-is-defined "glossary"))
 249      (w3-link-is-defined "glossary")
 250      "Glossary"]
 251     [w3-toolbar-copy-icon
 252      (w3-fetch (w3-link-is-defined "copyright"))
 253      (w3-link-is-defined "copyright")
 254      "Copyright"]
 255     [w3-toolbar-hotl-icon
 256      (w3-fetch (w3-link-is-defined "bookmark"))
 257      (w3-link-is-defined "bookmark")
 258      "Bookmarks"]
 259     nil
 260     [w3-toolbar-help-icon
 261      (w3-fetch (w3-link-is-defined "help"))
 262      (w3-link-is-defined "help")
 263      "Help"]
 264     ))
 265
 266 (defun w3-toolbar-from-orientation (orientation)
 267   (cond
 268    ((eq 'default w3-toolbar-orientation) default-toolbar)
 269    ((eq 'bottom w3-toolbar-orientation) bottom-toolbar)
 270    ((eq 'top w3-toolbar-orientation) top-toolbar)
 271    ((eq 'left w3-toolbar-orientation) left-toolbar)
 272    ((eq 'right w3-toolbar-orientation) right-toolbar)))
 273
 274 (defun w3-toolbar-dimension-from-orientation (orientation)
 275   (cond
 276    ((eq 'default w3-toolbar-orientation) nil)
 277    ((eq 'bottom w3-toolbar-orientation) bottom-toolbar-height)
 278    ((eq 'top w3-toolbar-orientation) top-toolbar-height)
 279    ((eq 'left w3-toolbar-orientation) left-toolbar-width)
 280    ((eq 'right w3-toolbar-orientation) right-toolbar-width)))
 281
 282 (defun w3-ensure-toolbar-visible (orientation)
 283   ;; Make sure a certain toolbar is visible if necessary
 284   ;; This can modify frame parameters, so watch out.
 285   (let ((dimension (w3-toolbar-dimension-from-orientation orientation))
 286         (toolbar   (w3-toolbar-from-orientation orientation))
 287         (dimensions nil)
 288         (widths nil)
 289         (heights nil)
 290         (needs nil)
 291         (has nil))
 292     (if (and dimension toolbar
 293              (setq toolbar (specifier-instance toolbar)))
 294         (progn
 295           (setq dimensions (mapcar
 296                             (function
 297                              (lambda (glyph)
 298                                (and (glyphp glyph)
 299                                     (cons (glyph-width glyph)
 300                                           (glyph-height glyph)))))
 301                             (mapcar 'car
 302                                     (delq nil
 303                                           (mapcar
 304                                            (function (lambda (x)
 305                                                        (and x
 306                                                             (symbol-value
 307                                                              (aref x 0)))))
 308                                            toolbar))))
 309                 widths (sort (mapcar 'car dimensions) '>=)
 310                 heights (sort (mapcar 'cdr dimensions) '>=)
 311                 needs (+ 7 (if (memq orientation '(top bottom))
 312                               (car heights)
 313                             (car widths)))
 314                 has (specifier-instance dimension))
 315           (if (<= has needs)
 316               (set-specifier dimension (cons (selected-frame) needs)))))))
 317
 318 (defun w3-toolbar-active ()
 319   (interactive)
 320   (let ((toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
 321     (if (and toolbar (specifier-instance toolbar))
 322         t
 323       nil)))
 324
 325 (defun w3-toggle-link-toolbar ()
 326   (interactive)
 327   (require 'info)                       ; For some toolbar buttons
 328   (let* ((w3-toolbar-orientation w3-link-toolbar-orientation)
 329          (toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
 330     (if toolbar
 331         (if (w3-toolbar-active)
 332             (set-specifier toolbar (cons (current-buffer) nil))
 333           (set-specifier toolbar w3-link-toolbar (current-buffer))))))
 334
 335 (defun w3-toggle-toolbar ()
 336   (interactive)
 337   (if (eq major-mode 'w3-mode)
 338       (let ((toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
 339         (cond
 340          ((w3-toolbar-active)
 341           (set-specifier toolbar (cons (current-buffer) nil)))
 342          (toolbar
 343           (set-specifier toolbar (cons (current-buffer) w3-toolbar)))
 344          (t
 345           (setq w3-toolbar-orientation 'default
 346                 toolbar (w3-toolbar-from-orientation w3-toolbar-orientation))
 347           (and toolbar
 348                (set-specifier toolbar (cons (current-buffer) w3-toolbar))))))
 349     (if (not (eq w3-toolbar-orientation 'none))
 350         (setq w3-toolbar-orientation 'none)
 351       (setq w3-toolbar-orientation 'default))))
 352
 353 (defun w3-show-info-node ()
 354   (interactive)
 355   (Info-goto-node "(w3.info)Top"))
 356
 357 (defun w3-mouse-print-this-url (&optional e)
 358   (interactive "e")
 359   (let ((descr '("Print document as"
 360                  ["PostScript" (w3-print-this-url nil "PostScript") t]
 361                  ["Formatted Text" (w3-print-this-url nil "Formatted Text") t]
 362                  ["HTML Source" (w3-print-this-url nil "HTML Source") t]
 363                  nil
 364                  ["Cancel" (beep) t])))
 365     (popup-dialog-box descr)))
 366
 367 (defvar w3-toolbar-map
 368   (if (and (featurep 'tool-bar)
 369            (display-graphic-p))         ; would lose on tty
 370       (progn
 371         (if (not w3-toolbar-icon-directory)
 372             (setq w3-toolbar-icon-directory
 373                   (file-name-as-directory
 374                    (expand-file-name "w3" data-directory))))
 375         (let ((tool-bar-map (make-sparse-keymap))
 376               ;; Add to normal image search path:
 377               (load-path (cons w3-toolbar-icon-directory load-path)))
 378           (dolist (desc w3-toolbar)
 379             (when desc
 380               (let ((sym (aref desc 0)))
 381                 ;; w3-toolbar contains `toolbar-' symbols as well as
 382                 ;; `w3-toolbar-'.
 383                 (unless (boundp sym)
 384                   (setq sym (intern (format "w3-%s" sym))))
 385                 (if (and desc (not (keywordp (aref desc 0))))
 386                     (tool-bar-add-item (symbol-value sym) ; image
 387                                        (aref desc 1) ; binding
 388                                        (intern (aref desc 3)) ; key
 389                                        :help (aref desc 3)
 390                                        :enable (aref desc 2))))))
 391           tool-bar-map))))
 392
 393 (defun w3-add-toolbar-to-buffer ()
 394   (cond
 395    ((featurep 'infodock)
 396     ;; Infodock handles toolbars differently
 397     nil)
 398    ((featurep 'toolbar)
 399     ;; XEmacs way of doing things
 400     (let ((toolbar (w3-toolbar-from-orientation w3-toolbar-orientation)))
 401       (if toolbar
 402           (set-specifier toolbar (cons (current-buffer) w3-toolbar))))
 403     (set-specifier toolbar-buttons-captioned-p
 404                    (cons (current-buffer) (eq w3-toolbar-type 'both))))
 405    ((and (featurep 'tool-bar)
 406          (display-graphic-p)
 407          (> (frame-parameter nil 'tool-bar-lines) 0))
 408     ;; Emacs 21.x way of doing things
 409     (set (make-local-variable 'tool-bar-map) w3-toolbar-map))
 410    (t
 411     nil)))
 412
 413 (provide 'w3-toolbar)