Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-e19.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents e04119814345
children 1ce6082ce73f
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; w3-e19.el --- Emacs 19.xx specific functions for emacs-w3 1 ;;; w3-e19.el --- Emacs 19.xx specific functions for emacs-w3
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/03/12 20:07:18 3 ;; Created: 1996/07/11 04:49:02
4 ;; Version: 1.19 4 ;; Version: 1.3
5 ;; Keywords: faces, help, mouse, hypermedia 5 ;; Keywords: faces, help, mouse, hypermedia
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu) 8 ;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
10 ;;; 9 ;;;
11 ;;; This file is part of GNU Emacs. 10 ;;; This file is part of GNU Emacs.
12 ;;; 11 ;;;
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify 12 ;;; 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 13 ;;; it under the terms of the GNU General Public License as published by
19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;;; GNU General Public License for more details. 20 ;;; GNU General Public License for more details.
22 ;;; 21 ;;;
23 ;;; You should have received a copy of the GNU General Public License 22 ;;; 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 23 ;;; along with GNU Emacs; see the file COPYING. If not, write to
25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
26 ;;; Boston, MA 02111-1307, USA.
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 26
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;;; Enhancements For Emacs 19 28 ;;; Enhancements For Emacs 19
31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32 (require 'w3-forms) 30 (require 'w3-forms)
33 (require 'font) 31 (require 'font)
34 (require 'w3-script)
35
36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
37 ;;; Help menu 33 ;;; Help menu
38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
39 (defvar w3-e19-hotlist-menu nil "A menu for hotlists.") 35 (defvar w3-links-menu nil "Menu for w3-mode in emacs 19.")
40 (defvar w3-e19-links-menu nil "A buffer-local menu for hyperlinks.") 36 (make-variable-buffer-local 'w3-links-menu)
41 (defvar w3-e19-nav-menu nil "A buffer-local menu for html based <link> tags.") 37
42 (mapcar 'make-variable-buffer-local 38 (defun w3-add-hotlist-menu ()
43 '(w3-e19-hotlist-menu w3-e19-links-menu w3-e19-nav-menu)) 39 ;; Add the hotlist menu to this buffer - used when it changes.
40 (let ((hot-menu (make-sparse-keymap "w3-hotlist"))
41 (ctr 0)
42 (hot w3-hotlist))
43 (while hot
44 (define-key hot-menu (vector (intern (concat "w3-hotlist-"
45 (int-to-string ctr))))
46 (cons (car (car hot))
47 (list 'lambda () '(interactive)
48 (list 'w3-fetch (car (cdr (car hot)))))))
49 (setq ctr (1+ ctr)
50 hot (cdr hot)))
51 (setq w3-e19-hotlist-menu hot-menu)))
44 52
45 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
46 ;;; Functions to build menus of urls 54 ;;; Functions to build menus of urls
47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
48 (defun w3-e19-show-hotlist-menu () 56 (defun w3-e19-show-hotlist-menu (e)
49 (interactive) 57 (interactive "e")
50 (let ((keymap (easy-menu-create-keymaps "Hotlist" 58 (if w3-html-bookmarks
51 (w3-menu-hotlist-constructor nil))) 59 (popup-menu w3-html-bookmarks)
52 (x nil) 60 (let* ((x (condition-case ()
53 (y nil)) 61 (x-popup-menu e w3-e19-hotlist-menu)
54 (setq x (x-popup-menu t keymap) 62 (error nil))) ; to trap for empty menus
55 y (and x (lookup-key keymap (apply 'vector x)))) 63 (y (and x (lookup-key w3-e19-hotlist-menu (apply 'vector x)))))
64 (if (and x y)
65 (funcall y)))))
66
67 (defun w3-e19-show-links-menu (e)
68 (interactive "e")
69 (if (not w3-e19-links-menu)
70 (w3-build-FSF19-menu))
71 (let* ((x (condition-case ()
72 (x-popup-menu e w3-e19-links-menu)
73 (error nil))) ; to trap for empty menus
74 (y (and x (lookup-key w3-e19-links-menu (apply 'vector x)))))
56 (if (and x y) 75 (if (and x y)
57 (funcall y)))) 76 (funcall y))))
58 77
59 (defun w3-e19-show-links-menu ()
60 (interactive)
61 (if (not w3-e19-links-menu)
62 (w3-build-FSF19-menu))
63 (let (x y)
64 (setq x (x-popup-menu t w3-e19-links-menu)
65 y (and x (lookup-key w3-e19-links-menu (apply 'vector x))))
66 (if (and x y)
67 (funcall y))))
68
69 (defun w3-e19-show-navigate-menu ()
70 (interactive)
71 (if (not w3-e19-nav-menu)
72 (w3-build-FSF19-menu))
73 (let (x y)
74 (setq x (x-popup-menu t w3-e19-nav-menu)
75 y (and x (lookup-key w3-e19-nav-menu (apply 'vector x))))
76 (if (and x y)
77 (funcall y))))
78
79 (defun w3-build-FSF19-menu () 78 (defun w3-build-FSF19-menu ()
80 ;; Build emacs19 menus from w3-links-list 79 ;; Build emacs19 menus from w3-links-list
81 (let ((links (w3-menu-html-links-constructor nil)) 80 (let* ((ctr 0)
82 (hlink (w3-menu-links-constructor nil))) 81 (menu-ctr 0)
83 (setq w3-e19-nav-menu (easy-menu-create-keymaps "Navigate" links) 82 (tmp nil)
84 w3-e19-links-menu (easy-menu-create-keymaps "Links" hlink)))) 83 (widgets (w3-only-links))
84 (widget nil)
85 (href nil)
86 (menus nil))
87 (setq tmp (make-sparse-keymap "Links"))
88 (while widgets
89 (setq widget (car widgets)
90 widgets (cdr widgets)
91 href (widget-get widget 'href))
92 (if (> ctr w3-max-menu-length)
93 (setq menus (cons tmp menus)
94 ctr 0
95 tmp (make-sparse-keymap
96 (concat "Links" (int-to-string
97 (setq menu-ctr
98 (1+ menu-ctr)))))))
99 (let ((ttl (w3-fix-spaces
100 (buffer-substring
101 (widget-get widget :from)
102 (widget-get widget :to))))
103 (key (vector (intern (concat "link"
104 (int-to-string
105 (setq ctr (1+ ctr))))))))
106 (if (and (> (length ttl) 0) href)
107 (define-key tmp key
108 (cons ttl
109 (list 'lambda () '(interactive)
110 (list 'w3-fetch href)))))))
111 (if (not menus)
112 (setq w3-e19-links-menu tmp)
113 (setq w3-e19-links-menu (make-sparse-keymap "LinkMenu")
114 menus (nreverse (cons tmp menus))
115 ctr 0)
116 (while menus
117 (define-key w3-e19-links-menu
118 (vector (intern (concat "SubMenu" ctr)))
119 (cons "More..." (car menus)))
120 (setq menus (cdr menus)
121 ctr (1+ ctr))))))
85 122
86 (defun w3-setup-version-specifics () 123 (defun w3-setup-version-specifics ()
87 ;; Set up routine for emacs 19 124 ;; Set up routine for emacs 19
88 (require 'lmenu) ; for popup-menu 125 (require 'lmenu))
89 )
90 126
91 (defun w3-store-in-clipboard (str) 127 (defun w3-store-in-clipboard (str)
92 "Store string STR in the Xwindows clipboard" 128 "Store string STR in the Xwindows clipboard"
93 (cond 129 (cond
94 ((memq (device-type) '(x pm)) 130 ((memq (device-type) '(x pm))
95 (x-select-text str)) 131 (x-select-text str))
96 ((eq (device-type) 'ns) 132 ((eq (device-type) 'ns)
97 (ns-store-pasteboard-internal str)) 133 (ns-store-pasteboard-internal str))
98 (t nil))) 134 (t nil)))
99 135
100 (defun w3-e19-no-read-only (st nd)
101 ;; Make sure we don't yank any read-only data out of this buffer
102 (let ((inhibit-read-only t))
103 (put-text-property st nd 'read-only nil)))
104
105 (defun w3-mode-version-specifics () 136 (defun w3-mode-version-specifics ()
106 ;; Emacs 19 specific stuff for w3-mode 137 ;; Emacs 19 specific stuff for w3-mode
107 (make-local-variable 'track-mouse) 138 (make-local-variable 'track-mouse)
108 (set (make-local-variable 'buffer-access-fontify-functions) 'w3-e19-no-read-only) 139 (if w3-track-mouse (setq track-mouse t))
109 (if w3-track-mouse (setq track-mouse t))) 140 (if (or (memq (device-type) '(x pm ns)))
141 (w3-build-FSF19-menu)))
110 142
111 (defun w3-mouse-handler (e) 143 (defun w3-mouse-handler (e)
112 "Function to message the url under the mouse cursor" 144 "Function to message the url under the mouse cursor"
113 (interactive "e") 145 (interactive "e")
114 (let* ((pt (posn-point (event-start e))) 146 (let* ((pt (posn-point (event-start e)))
115 (good (eq (posn-window (event-start e)) (selected-window))) 147 (good (eq (posn-window (event-start e)) (selected-window)))
116 (mouse-events nil)) 148 (widget (and good pt (number-or-marker-p pt) (widget-at pt)))
117 (if (not (and good pt (number-or-marker-p pt))) 149 (link (and widget (widget-get widget 'href)))
118 nil 150 (form (and widget (widget-get widget 'w3-form-data)))
119 (widget-echo-help pt) 151 (imag nil) ; (nth 1 (memq 'w3graphic props))))
120 ;; Need to handle onmouseover, on mouseout 152 )
121 (setq mouse-events (w3-script-find-event-handlers pt 'mouse)) 153 (cond
122 (if (assq 'onmouseover mouse-events) 154 (link (message "%s" link))
123 (w3-script-evaluate-form (cdr (assq 'onmouseover mouse-events))))))) 155 (form
156 (cond
157 ((eq 'submit (w3-form-element-type form))
158 (message "Submit form to %s"
159 (cdr-safe (assq 'action (w3-form-element-action form)))))
160 ((eq 'reset (w3-form-element-type form))
161 (message "Reset form contents"))
162 (t
163 (message "Form entry (name=%s, type=%s)" (w3-form-element-name form)
164 (w3-form-element-type form)))))
165 (imag (message "Inlined image (%s)" (car imag)))
166 (t (message "")))))
124 167
125 (defun w3-color-values (color) 168 (defun w3-color-values (color)
126 (cond 169 (cond
127 ((eq window-system 'x) 170 ((eq window-system 'x)
128 (x-color-values color)) 171 (x-color-values color))