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

   1 ;;; w3-xemac.el --- XEmacs specific functions for emacs-w3
   2 ;; Author: $Author: legoscia $
   3 ;; Created: $Date: 2006/10/17 20:24:48 $
   4 ;; Version: $Revision: 1.3 $
   5 ;; Keywords: faces, help, mouse, hypermedia
   6
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
   9 ;;; Copyright (c) 1996 - 1999 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 (require 'w3-imap)
  30 (require 'images)
  31 (require 'w3-widget)
  32 (require 'w3-menu)
  33 (require 'w3-forms)
  34
  35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36 ;;; Enhancements For XEmacs
  37 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38 (defun w3-mouse-handler (e)
  39   "Function to message the url under the mouse cursor"
  40   (interactive "e")
  41   (if (equal (current-buffer) (event-buffer e))
  42       (let* ((pt (event-point e))
  43              (good (eq (event-window e) (selected-window)))
  44              (mouse-events))
  45         (if (not (and good pt (number-or-marker-p pt)))
  46             nil
  47           (if (and inhibit-help-echo w3-track-mouse)
  48               (widget-echo-help pt))))))
  49
  50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51 ;;; Functions to build menus of urls
  52 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  53 (defun w3-setup-version-specifics ()
  54   "Set up routine for XEmacs 19.12 or later"
  55   ;; Create the toolbar buttons
  56   (and (featurep 'toolbar)
  57        (w3-toolbar-make-buttons))
  58
  59   ;; Register the default set of image conversion utilities
  60   (image-register-netpbm-utilities)
  61
  62   ;; Add our menus, but make sure that we do it to the global menubar
  63   ;; not the current one, which could be anything, but usually GNUS or
  64   ;; VM if not the default.
  65   ;;
  66   ;; InfoDock handles all of this for us, so we don't need to worry about
  67   ;; it there.
  68   (if (and (featurep 'menubar) (not (featurep 'infodock)))
  69       (let ((current-menubar (default-value 'current-menubar)))
  70         (if current-menubar
  71             (add-submenu '("Help") (cons "WWW" (cdr w3-menu-help-menu))))))
  72
  73   ;; FIXME FIXME: Do sexy things to the default modeline for Emacs-W3
  74
  75   ;; The following is a workaround for XEmacs 19.14 and XEmacs 20.0
  76   ;; The text property implementation is badly broken - you could not have
  77   ;; a text property with a `nil' value.  Bad bad bad.
  78   (if (or (and (= emacs-major-version 20)
  79                (= emacs-minor-version 0))
  80           (and (= emacs-major-version 19)
  81                (= emacs-minor-version 14)))
  82       (defun text-prop-extent-paste-function (ext from to)
  83         (let ((prop (extent-property ext 'text-prop nil))
  84               (val nil))
  85           (if (null prop)
  86               (error "Internal error: no text-prop"))
  87           (setq val (extent-property ext prop nil))
  88           (put-text-property from to prop val nil)
  89           nil))
  90     )
  91   )
  92
  93 (defun w3-mode-motion-hook (e)
  94   (let* ((glyph  (event-glyph e))
  95          (x      (and glyph (event-glyph-x-pixel e)))
  96          (y      (and glyph (event-glyph-y-pixel e)))
  97          (widget (and glyph (glyph-property glyph 'widget)))
  98          (usemap (and widget (w3-image-widget-usemap widget)))
  99          (ismap  (and widget (widget-get widget 'ismap)))
 100          (echo   (and widget (widget-get widget 'href))))
 101     (cond
 102      (usemap
 103       (setq echo (w3-point-in-map (vector x y) usemap t)))
 104      (ismap
 105       (setq echo (format "%s?%d,%d" echo x y)))
 106      (t
 107       nil))
 108     (and echo (message "%s" echo))))
 109
 110 (defun w3-mode-version-specifics ()
 111   "XEmacs specific stuff for w3-mode"
 112   (if (featurep 'mouse)
 113       (progn
 114         (if (not w3-track-mouse)
 115             (setq inhibit-help-echo nil))
 116         (setq mode-motion-hook 'w3-mouse-handler)))
 117   (case (device-type)
 118     ((tty stream)                       ; TTY or batch
 119      nil)
 120     (otherwise
 121      (w3-add-toolbar-to-buffer)))
 122   (setq mode-popup-menu w3-popup-menu))
 123
 124 ;; Some old versions of XEmacs have a dumped version of the widget and
 125 ;; custom libraries that are too old for us to use, so we have to reload
 126 ;; the new ones.
 127 (if (or (string-match "19\\.1[3456]" emacs-version)
 128         (string-match "20\\.[0123]" emacs-version))
 129     (mapc 'load '("wid-edit" "widget" "custom" "cus-edit" "cus-face"
 130                   "cus-start" "cus-load")))
 131
 132 (if (string-match "19\\.13" emacs-version)
 133     ;; This is all from Vladimir Alexiev <vladimir@cs.ualberta.ca>
 134     (progn
 135       (require 'advice)
 136       (declare (special widget-use-overlay-change))
 137       (defadvice add-text-properties (before face-list activate)
 138         "Allow a list of faces (ignore all but first one)."
 139         (let ((faces (plist-get props 'face)))
 140           (if (listp faces)
 141               (plist-put props 'face (car faces)))))
 142
 143       (defadvice set-extent-property (before face-list activate)
 144         "Allow a list of faces (ignore all but first one)."
 145         (if (and (eq property 'face) (listp value))
 146             (setq value (car value))))
 147
 148       (defadvice insert-char (before inherit-ignore
 149                                      (char &optional count inherit buffer)
 150                                      activate)
 151         "Accept and ignore a third arg INHERIT."
 152         (or (bufferp inherit) (setq inherit buffer)))
 153
 154
 155       (defun font-height (font) 1)
 156       (defun font-width (font)  1)      ; works for tty
 157       (defalias 'get-char-property 'get-text-property)
 158       (defalias 'extent-object 'extent-buffer)
 159       (defvar shell-command-switch "-c") ; for mm
 160
 161       ;; for x-overlay
 162       (defun extent-list (&optional buffer from to)
 163         "Return a list of all extents in BUFFER between FROM and TO
 164 \(see mapcar-extents\)."
 165         (mapcar-extents 'identity nil buffer from to))
 166
 167       ;; for custom/widget
 168       (setq widget-use-overlay-change nil) ; slower, but works
 169
 170       (defadvice add-hook (before ignore
 171                                   (hook function &optional append ignore)
 172                                   activate)
 173         "Accept and ignore a fourth argument.")
 174
 175       (defadvice remove-hook (before ignore
 176                                      (hook function &optional ignore) activate)
 177         "Accept and ignore a third argument.")
 178
 179       (defun valid-image-instantiator-format-p (format)
 180         (valid-instantiator-p
 181          (vector format :file (concat "foo." (symbol-name format)))
 182          'image))
 183
 184       (defadvice make-sparse-keymap (before ignore (&optional name) activate)
 185         "Accept and ignore an optional arg NAME.")
 186       ))
 187
 188 (require 'w3-toolbar)
 189 (provide 'w3-xemacs)
 190 (provide 'w3-xemac)