Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-draw.el @ 2:ac2d302a0011 r19-15b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b2
author cvs
date Mon, 13 Aug 2007 08:46:35 +0200
parents 376386a54a3c
children
comparison
equal deleted inserted replaced
1:c0c6a60d29db 2:ac2d302a0011
1 ;;; w3-draw.el,v --- Emacs-W3 drawing functions for new display engine 1 ;;; w3-draw.el --- Emacs-W3 drawing functions for new display engine
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1996/06/03 16:59:57 3 ;; Created: 1996/08/25 17:12:32
4 ;; Version: 1.365 4 ;; Version: 1.17
5 ;; Keywords: faces, help, hypermedia 5 ;; Keywords: faces, help, hypermedia
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com) 8 ;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; 9 ;;;
10 ;;; This file is not part of GNU Emacs, but the same permissions apply. 10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
11 ;;; 11 ;;;
12 ;;; 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
13 ;;; 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
23 ;;; along with GNU Emacs; see the file COPYING. If not, write to 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. 24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 26
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 ;;; This function will take a stream of HTML from w3-preparse-buffer 28 ;;; This function will take a stream of HTML from w3-parse-buffer
29 ;;; and draw it out 29 ;;; and draw it out
30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
31 31
32 (require 'w3-vars) 32 (require 'w3-vars)
33 (require 'w3-imap) 33 (require 'w3-imap)
74 (aset prefix-vector len (make-string len ? )) 74 (aset prefix-vector len (make-string len ? ))
75 (setq len (1+ len))) 75 (setq len (1+ len)))
76 prefix-vector)) 76 prefix-vector))
77 77
78 (defsubst w3-set-fill-prefix-length (len) 78 (defsubst w3-set-fill-prefix-length (len)
79 (let ((len len)) 79 (setq fill-prefix (if (< len (- (or w3-strict-width (window-width)) 4))
80 (setq fill-prefix (if (< len 80) 80 (if (< len 80)
81 (aref w3-fill-prefixes-vector len) 81 (aref w3-fill-prefixes-vector len)
82 (make-string len ? ))))) 82 (make-string len ? ))
83 (url-warn
84 'html
85 "Runaway indentation! Too deep for window width!")
86 fill-prefix)))
83 87
84 (defsubst w3-get-default-style-info (info) 88 (defsubst w3-get-default-style-info (info)
85 (and w3-current-stylesheet 89 (and w3-current-stylesheet
86 (or 90 (or
87 ;; Check for tag/class first! 91 ;; Check for tag/id|name first!
92 (cdr-safe (assq info
93 (cdr-safe
94 (assoc (or (cdr-safe (assq 'id args))
95 (cdr-safe (assq 'name args)))
96 (cdr-safe
97 (assq tag w3-current-stylesheet))))))
98
99 ;; Check for tag/class next
88 (cdr-safe (assq info 100 (cdr-safe (assq info
89 (cdr-safe 101 (cdr-safe
90 (assoc (cdr-safe (assq 'class args)) 102 (assoc (cdr-safe (assq 'class args))
91 (cdr-safe 103 (cdr-safe
92 (assq tag w3-current-stylesheet)))))) 104 (assq tag w3-current-stylesheet))))))
103 (cdr-safe 115 (cdr-safe
104 (assq 'internal 116 (assq 'internal
105 (cdr-safe 117 (cdr-safe
106 (assq tag w3-current-stylesheet))))))))) 118 (assq tag w3-current-stylesheet)))))))))
107 119
108 (defun w3-normalize-color (color) 120 (defsubst w3-normalize-color (color)
109 (cond 121 (cond
110 ((valid-color-name-p color) 122 ((valid-color-name-p color)
111 color) 123 color)
112 ((valid-color-name-p (concat "#" color)) 124 ((valid-color-name-p (concat "#" color))
113 (concat "#" color)) 125 (concat "#" color))
114 ((string-match "[ \t\r\n]" color) 126 ((string-match "[ \t\r\n]" color)
115 (w3-normalize-color 127 (w3-normalize-color
116 (mapconcat (function (lambda (x) (if (memq x '(?\t ?\r ?\n ? )) "" 128 (mapconcat (function (lambda (x) (if (memq x '(?\t ?\r ?\n ? )) ""
117 (char-to-string x)))) color ""))) 129 (char-to-string x)))) color "")))
118 (t 130 ((valid-color-name-p (font-normalize-color color))
131 (font-normalize-color color))
132 (t
119 (w3-warn 'html (format "Bad color specification: %s" color)) 133 (w3-warn 'html (format "Bad color specification: %s" color))
120 nil))) 134 nil)))
121 135
122 (defun w3-pause () 136 (defun w3-pause ()
123 (cond 137 (cond
154 (/a . a))) 168 (/a . a)))
155 169
156 (defvar w3-face-cache nil 170 (defvar w3-face-cache nil
157 "Cache for w3-face-for-element") 171 "Cache for w3-face-for-element")
158 172
159 ;; This is just for if we don't have Emacspeak loaded so we do not
160 ;; get compile/run-time errors.
161 (defvar dtk-voice-table nil
162 "Association between symbols and strings to set dtk voices.
163 The string can set any dtk parameter. ")
164
165 (defsubst w3-valid-voice-p (voice)
166 (cadr (assq voice dtk-voice-table)))
167
168 (defsubst w3-voice-for-element () 173 (defsubst w3-voice-for-element ()
169 (let ((temporary-voice (w3-get-default-style-info 'voice-spec))) 174 (let ((temporary-voice (w3-get-default-style-info 'voice-spec)))
170 (and temporary-voice (w3-valid-voice-p temporary-voice) 175 (and temporary-voice (cons tag temporary-voice))))
171 (cons tag temporary-voice))))
172 176
173 (defsubst w3-face-for-element () 177 (defsubst w3-face-for-element ()
174 (let* ((font-spec (w3-get-default-style-info 'font-spec)) 178 (let* ((font-spec (w3-get-default-style-info 'font-spec))
175 (foreground (w3-get-default-style-info 'color)) 179 (foreground (w3-get-default-style-info 'color))
176 (background (w3-get-default-style-info 'background)) 180 (background (w3-get-default-style-info 'background))
200 (and w3-draw-buffer (set-buffer w3-draw-buffer)) 204 (and w3-draw-buffer (set-buffer w3-draw-buffer))
201 (let ((opos (point)) 205 (let ((opos (point))
202 (id (and (listp args) 206 (id (and (listp args)
203 (or (cdr-safe (assq 'name args)) 207 (or (cdr-safe (assq 'name args))
204 (cdr-safe (assq 'id args)))))) 208 (cdr-safe (assq 'id args))))))
209
205 ;; This allows _ANY_ tag, whether it is known or not, to be 210 ;; This allows _ANY_ tag, whether it is known or not, to be
206 ;; the target of a # reference in a URL 211 ;; the target of a # reference in a URL
207 (if id 212 (if id
208 (progn 213 (progn
209 (setq w3-id-positions (cons 214 (setq w3-id-positions (cons
210 (cons (intern id) 215 (cons (intern id)
211 (set-marker (make-marker) 216 (set-marker (make-marker)
212 (point-max))) 217 (point-max)))
213 w3-id-positions)))) 218 w3-id-positions))))
219
220 (if (and (listp args) (cdr-safe (assq 'style args)))
221 (let ((unique-id (or id (url-create-unique-id)))
222 (sheet ""))
223 (setq sheet (format "%s.%s { %s }\n" tag unique-id
224 (cdr-safe (assq 'style args)))
225 args (cons (cons 'id unique-id) args))
226
227 (w3-handle-style (list (cons 'data sheet)
228 (cons 'notation "css")))))
214 (goto-char (point-max)) 229 (goto-char (point-max))
215 (if (and (w3-get-state :next-break) 230 (if (and (w3-get-state :next-break)
216 (not (memq tag 231 (not (memq tag
217 '(p h1 h2 h3 h4 h5 h6 ol ul dl menu dir pre)))) 232 '(p h1 h2 h3 h4 h5 h6 ol ul dl menu dir pre))))
218 (w3-handle-p)) 233 (w3-handle-p))
230 'insert.before)) 245 'insert.before))
231 (let ((tag (cdr-safe (assq tag w3-end-tags)))) 246 (let ((tag (cdr-safe (assq tag w3-end-tags))))
232 (setq data-after (and tag 247 (setq data-after (and tag
233 (w3-get-default-style-info 248 (w3-get-default-style-info
234 'insert.after)))))) 249 'insert.after))))))
235 (if data-before (w3-handle-single-tag 'text data-before)) 250 (if data-before (w3-handle-text data-before))
236 (setq w3-current-formatter (get tag 'w3-formatter)) 251 (setq w3-current-formatter (get tag 'w3-formatter))
237 (cond 252 (cond
238 ((eq w3-current-formatter 'ack) nil) 253 ((eq w3-current-formatter 'ack) nil)
239 ((null w3-current-formatter) (w3-handle-unknown-tag tag args)) 254 ((null w3-current-formatter) (w3-handle-unknown-tag tag args))
240 (t (funcall w3-current-formatter args))) 255 (t (funcall w3-current-formatter args)))
241 (if data-after (w3-handle-single-tag 'text data-after))))) 256 (if data-after (w3-handle-text data-after)))))
242 (if (not (eq tag 'text)) 257 (if (not (eq tag 'text))
243 (setq w3-last-tag tag)) 258 (setq w3-last-tag tag))
244 (goto-char opos)))) 259 (goto-char opos))))
245 260
246 261
253 (setq w3-state-vector (copy-sequence w3-state-vector)) 268 (setq w3-state-vector (copy-sequence w3-state-vector))
254 (setq w3-current-stylesheet (copy-tree w3-user-stylesheet)) 269 (setq w3-current-stylesheet (copy-tree w3-user-stylesheet))
255 (let* ((tag 'html) 270 (let* ((tag 'html)
256 (args nil) 271 (args nil)
257 (face (cdr (w3-face-for-element)))) 272 (face (cdr (w3-face-for-element))))
273 (if (not face)
274 (setq tag 'body
275 face (cdr (w3-face-for-element))))
258 (and face 276 (and face
259 (if (not (fboundp 'valid-specifier-locale-p)) 277 (if (not (fboundp 'valid-specifier-locale-p))
260 nil 278 nil
261 (w3-my-safe-copy-face face 'default (current-buffer))))) 279 (w3-my-safe-copy-face face 'default (current-buffer)))))
262 (setq w3-form-labels nil) 280 (setq w3-form-labels nil)
282 (w3-put-state :nofill nil) ; non-nil if in pre or xmp 300 (w3-put-state :nofill nil) ; non-nil if in pre or xmp
283 (w3-put-state :nowrap nil) ; non-nil if in <p nowrap> 301 (w3-put-state :nowrap nil) ; non-nil if in <p nowrap>
284 (w3-put-state :href nil) ; Current link destination 302 (w3-put-state :href nil) ; Current link destination
285 (w3-put-state :name nil) ; Current link ID tag 303 (w3-put-state :name nil) ; Current link ID tag
286 (w3-put-state :image nil) ; Current image destination 304 (w3-put-state :image nil) ; Current image destination
287 (w3-put-state :mpeg nil) ; Current mpeg destination
288 (w3-put-state :form nil) ; Current form information 305 (w3-put-state :form nil) ; Current form information
289 (w3-put-state :optarg nil) ; Option arguments 306 (w3-put-state :optarg nil) ; Option arguments
290 (w3-put-state :w3-graphic nil) ; Image stuff for non-xemacs 307 (w3-put-state :w3-graphic nil) ; Image stuff for non-xemacs
291 (w3-put-state :lists '()) ; Types of list currently in. 308 (w3-put-state :lists '()) ; Types of list currently in.
292 (w3-put-state :align nil) ; Current alignment of paragraphs 309 (w3-put-state :align nil) ; Current alignment of paragraphs
363 (cond 380 (cond
364 ((and handler (fboundp handler)) 381 ((and handler (fboundp handler))
365 (put tag 'w3-formatter handler) 382 (put tag 'w3-formatter handler)
366 (funcall handler args)) 383 (funcall handler args))
367 (end-tag-p 384 (end-tag-p
368 (put tag 'w3-formatter 'w3-handle-emphasis-end)) 385 (put tag 'w3-formatter 'w3-handle-emphasis-end)
386 (w3-handle-emphasis-end args))
369 (t 387 (t
370 (put tag 'w3-formatter 'w3-handle-emphasis))))) 388 (put tag 'w3-formatter 'w3-handle-emphasis)
389 (w3-handle-emphasis args)))))
371 390
372 (defun w3-handle-text (&optional args) 391 (defun w3-handle-text (&optional args)
373 ;; This is the main workhorse of the display engine. 392 ;; This is the main workhorse of the display engine.
374 ;; It will figure out how a chunk of text should be displayed and 393 ;; It will figure out how a chunk of text should be displayed and
375 ;; put all the necessary extents/overlays/regions around it." 394 ;; put all the necessary extents/overlays/regions around it."
421 ((and (consp cur) (not (memq (cdr cur) faces))) 440 ((and (consp cur) (not (memq (cdr cur) faces)))
422 (setq faces (cons (cdr cur) faces))) 441 (setq faces (cons (cdr cur) faces)))
423 (t nil))) 442 (t nil)))
424 (add-text-properties st (point) (list 'face faces)) 443 (add-text-properties st (point) (list 'face faces))
425 (if (car voices) 444 (if (car voices)
426 (add-text-properties st (point) (list 'personality (car voices)))) 445 (add-text-properties st (point) (list 'personality (cdar voices))))
427 ) 446 )
428 (if (not (memq (char-after (1- (point))) '(? ?.))) 447 (if (not (memq (char-after (1- (point))) '(? ?.)))
429 (w3-put-state :needspace t)) 448 (w3-put-state :needspace t))
430 ))) 449 )))
431 450
638 (let ((tag (cdr-safe (assoc tag w3-end-tags)))) 657 (let ((tag (cdr-safe (assoc tag w3-end-tags))))
639 (w3-handle-p) 658 (w3-handle-p)
640 (w3-pop-alignment))) 659 (w3-pop-alignment)))
641 660
642 (defun w3-handle-p (&optional args) 661 (defun w3-handle-p (&optional args)
643 (if (or (not (memq w3-last-tag '(li dt dd))) 662 (if (or (not (memq w3-last-tag '(li tr td th dt dd)))
644 (memq tag '(ol ul dl menu dir))) 663 (memq tag '(ol ul dl menu dir)))
645 (let ((name (or (cdr-safe (assq 'name args)) 664 (let ((name (or (cdr-safe (assq 'name args))
646 (cdr-safe (assq 'id args)))) 665 (cdr-safe (assq 'id args))))
647 (align (cdr-safe (assoc 'align args)))) 666 (align (cdr-safe (assoc 'align args))))
648 (w3-handle-emphasis-end) 667 (w3-handle-emphasis-end)
911 (defun w3-handle-/math (&optional args) 930 (defun w3-handle-/math (&optional args)
912 (w3-handle-br) 931 (w3-handle-br)
913 (w3-handle-text "[END MATH]") 932 (w3-handle-text "[END MATH]")
914 (w3-handle-br)) 933 (w3-handle-br))
915 934
935 (defun w3-handle-tr (&optional args)
936 (w3-handle-br))
937
938 (defun w3-handle-/tr (&optional args)
939 (w3-handle-br))
940
941 (defun w3-handle-td (&optional args)
942 (w3-handle-text " | "))
943
944 (defun w3-handle-/td (&optional args)
945 (w3-handle-text " | "))
946
947 (defun w3-handle-th (&optional args)
948 (w3-handle-text " | "))
949
950 (defun w3-handle-/th (&optional args)
951 (w3-handle-text " | "))
952
916 (defun w3-handle-table (&optional args) 953 (defun w3-handle-table (&optional args)
917 (w3-handle-br)
918 (w3-handle-text "[START TABLE - Not Implemented (Yet)]")
919 (w3-handle-br)) 954 (w3-handle-br))
920 955
921 (defun w3-handle-/table (&optional args) 956 (defun w3-handle-/table (&optional args)
922 (w3-handle-br)
923 (w3-handle-text "[END TABLE]")
924 (w3-handle-br)) 957 (w3-handle-br))
925 958
926 (defun w3-handle-div (&optional args) 959 (defun w3-handle-div (&optional args)
927 (let ((align (cdr-safe (assq 'align args)))) 960 (let ((align (cdr-safe (assq 'align args))))
928 (w3-handle-emphasis args) 961 (w3-handle-emphasis args)
983 ;;; Netscape Compatibility 1016 ;;; Netscape Compatibility
984 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1017 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
985 ; For some reason netscape treats </br> like <br> - ugh. 1018 ; For some reason netscape treats </br> like <br> - ugh.
986 (fset 'w3-handle-/br 'w3-handle-br) 1019 (fset 'w3-handle-/br 'w3-handle-br)
987 1020
1021 (defun w3-create-blank-pixmap (width height)
1022 (let ((retval
1023 (concat "/* XPM */\n"
1024 "static char *pixmap[] = {\n"
1025 ;;"/* width height num_colors chars_per_pixel */\n"
1026 (format "\" %d %d 2 1\",\n" width height)
1027 ;;"/* colors */\n"
1028 "\". c #000000 s background\",\n"
1029 "\"# c #FFFFFF s foreground\",\n"
1030 ;;"/* pixels /*\n"
1031 ))
1032 (line (concat "\"" (make-string width ?.) "\"")))
1033 (while (/= 1 height)
1034 (setq retval (concat retval line ",\n")
1035 height (1- height)))
1036 (concat retval line "\n};")))
1037
1038 (defun w3-handle-spacer (&optional args)
1039 (let ((type (cdr-safe (assq 'type args)))
1040 (size (cdr-safe (assq 'size args)))
1041 (w (or (cdr-safe (assq 'width args)) 1))
1042 (h (or (cdr-safe (assq 'height args)) 1))
1043 (align (cdr-safe (assq 'align args)))
1044 (glyph nil))
1045 (condition-case ()
1046 (setq glyph (make-glyph
1047 (vector 'xpm :data (w3-create-blank-pixmap w h))))
1048 (error nil))
1049 )
1050 )
1051
988 (defun w3-handle-font (&optional args) 1052 (defun w3-handle-font (&optional args)
989 (let* ((sizearg (cdr-safe (assq 'size args))) 1053 (let* ((sizearg (cdr-safe (assq 'size args)))
990 (sizenum (cond 1054 (sizenum (cond
991 ((null sizearg) nil) 1055 ((null sizearg) nil)
992 ((= ?+ (string-to-char sizearg)) 1056 ((= ?+ (string-to-char sizearg))
994 ((= ?- (string-to-char sizearg)) 1058 ((= ?- (string-to-char sizearg))
995 (max (- 3 (string-to-int (substring sizearg 1))) 0)) 1059 (max (- 3 (string-to-int (substring sizearg 1))) 0))
996 ((string= sizearg (int-to-string (string-to-int sizearg))) 1060 ((string= sizearg (int-to-string (string-to-int sizearg)))
997 (string-to-int sizearg)) 1061 (string-to-int sizearg))
998 (t nil))) 1062 (t nil)))
1063 (family (cdr-safe (assq 'face args)))
999 (color (cdr-safe (assq 'color args))) 1064 (color (cdr-safe (assq 'color args)))
1000 (normcolor (if color (w3-normalize-color color))) 1065 (normcolor (if color (w3-normalize-color color)))
1001 (w3-current-stylesheet (` ((font 1066 (w3-current-stylesheet (list
1002 (internal 1067 (list 'font
1003 (font-size-index . (, sizenum)) 1068 (list 'internal
1004 (foreground . (, normcolor)))))))) 1069 (cons 'font-family family)
1005 (w3-generate-stylesheet-faces w3-current-stylesheet) 1070 (cons 'font-size-index sizenum)
1071 (cons 'foreground normcolor))))))
1072 (w3-style-post-process-stylesheet w3-current-stylesheet)
1006 (w3-handle-emphasis args))) 1073 (w3-handle-emphasis args)))
1007 1074
1008 (defun w3-handle-/font (&optional args) 1075 (defun w3-handle-/font (&optional args)
1009 (w3-handle-emphasis-end)) 1076 (w3-handle-emphasis-end))
1010 1077
1019 1086
1020 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1087 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1021 ;;; Bonus HTML Tags just for fun :) 1088 ;;; Bonus HTML Tags just for fun :)
1022 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1089 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1023 (defun w3-handle-embed (&optional args) 1090 (defun w3-handle-embed (&optional args)
1024 (let* ((buf (url-generate-new-buffer-name " *embed*")) 1091 ;; This needs to be reimplemented!!!
1025 (w3-draw-buffer (current-buffer)) 1092 )
1026 (url-working-buffer buf)
1027 (data (cdr-safe (assq 'data args)))
1028 (href (and (not data)
1029 (url-expand-file-name
1030 (or (cdr-safe (assq 'src args))
1031 (cdr-safe (assq 'href args)))
1032 (cdr-safe (assoc (cdr-safe (assq 'base args))
1033 w3-base-alist)))))
1034 (type (or (cdr-safe (assq 'type args)) "text/plain"))
1035 (parse nil))
1036 (if (and href (not (string= type "video/mpeg")))
1037 ;; MPEG movies can be _HUGE_, delay loading them as
1038 ;; long as possible
1039 (save-excursion
1040 (set-buffer (get-buffer-create buf))
1041 (setq url-be-asynchronous nil)
1042 (url-retrieve href)
1043 (setq data (buffer-string))
1044 (kill-buffer (current-buffer))))
1045 (cond
1046 ((string= type "text/plain")
1047 (insert data))
1048 ((string-match "^text/html" type)
1049 (save-excursion
1050 (set-buffer (get-buffer-create
1051 (url-generate-new-buffer-name " *embed*")))
1052 (erase-buffer)
1053 (insert data)
1054 (setq parse (w3-preparse-buffer (current-buffer) t))
1055 (kill-buffer (current-buffer)))
1056 (while parse
1057 (w3-handle-single-tag (car (car parse)) (cdr (car parse)))
1058 (setq parse (cdr parse))))
1059 ((string= type "video/mpeg")
1060 (let ((width (cdr-safe (assq 'width args)))
1061 (height (cdr-safe (assq 'height args))))
1062 (setq width (if width (string-to-int width))
1063 height (if height (string-to-int height)))
1064 (w3-add-delayed-mpeg href (point) width height))))))
1065 1093
1066 (defun w3-handle-blink (&optional args) 1094 (defun w3-handle-blink (&optional args)
1067 ;; Keep track of all the buffers with blinking in them, and do GC 1095 ;; Keep track of all the buffers with blinking in them, and do GC
1068 ;; of this list whenever a new <blink> tag is encountered. The 1096 ;; of this list whenever a new <blink> tag is encountered. The
1069 ;; timer checks this list to see if any of the buffers are visible, 1097 ;; timer checks this list to see if any of the buffers are visible,
1271 (setcdr map (cons (vector type coords href alt) (cdr map))))) 1299 (setcdr map (cons (vector type coords href alt) (cdr map)))))
1272 1300
1273 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1301 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1274 ;;; Tags that don't really get drawn, etc. 1302 ;;; Tags that don't really get drawn, etc.
1275 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1303 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1304 (defun w3-handle-/html (&optional args)
1305 ;; Technically, we are not supposed to have any text outside the
1306 ;; html element, so start ignoring everything.
1307 (put 'text 'w3-formatter 'ack))
1308
1276 (defun w3-handle-body (&optional args) 1309 (defun w3-handle-body (&optional args)
1277 (if (not w3-user-colors-take-precedence) 1310 (if (not w3-user-colors-take-precedence)
1278 (let* ((vlink (cdr-safe (assq 'vlink args))) 1311 (let* ((vlink (cdr-safe (assq 'vlink args)))
1279 (alink (cdr-safe (assq 'alink args))) 1312 (alink (cdr-safe (assq 'alink args)))
1280 (link (cdr-safe (assq 'link args))) 1313 (link (cdr-safe (assq 'link args)))
1397 1430
1398 (defun w3-maybe-start-image-download (widget) 1431 (defun w3-maybe-start-image-download (widget)
1399 (let* ((src (widget-get widget 'src)) 1432 (let* ((src (widget-get widget 'src))
1400 (cached-glyph (w3-image-cached-p src))) 1433 (cached-glyph (w3-image-cached-p src)))
1401 (if (and cached-glyph (w3-glyphp cached-glyph)) 1434 (if (and cached-glyph (w3-glyphp cached-glyph))
1402 (setq w3-image-widgets-waiting (cons widget 1435 (setq w3-image-widgets-waiting (cons widget w3-image-widgets-waiting))
1403 w3-image-widgets-waiting))
1404 (cond 1436 (cond
1405 ((or w3-delay-image-loads (not (fboundp 'valid-specifier-domain-p))) 1437 ((or w3-delay-image-loads (not (fboundp 'valid-specifier-domain-p)))
1406 nil) ; Do nothing, cannot do images 1438 (w3-add-delayed-graphic widget))
1407 ((not (w3-image-loadable-p src nil)) ; Hey, we can't load it! 1439 ((not (w3-image-loadable-p src nil)) ; Hey, we can't load it!
1408 (w3-warn 'images (format "Skipping image %s" (url-basepath src t)))) 1440 (w3-warn 'images (format "Skipping image %s" (url-basepath src t)))
1441 (w3-add-delayed-graphic widget))
1409 (t ; Grab the images 1442 (t ; Grab the images
1410 (let ( 1443 (let (
1411 (url-request-method "GET") 1444 (url-request-method "GET")
1412 (old-asynch url-be-asynchronous) 1445 (old-asynch url-be-asynchronous)
1413 (url-request-data nil) 1446 (url-request-data nil)
1526 (concat (w3-get-state :title) args))) 1559 (concat (w3-get-state :title) args)))
1527 1560
1528 (defun w3-handle-/title (&optional args) 1561 (defun w3-handle-/title (&optional args)
1529 (put 'text 'w3-formatter nil) 1562 (put 'text 'w3-formatter nil)
1530 (let ((ttl (w3-get-state :title))) 1563 (let ((ttl (w3-get-state :title)))
1531 (cond 1564 (if (not (stringp ttl))
1532 ((and (symbolp ttl) (eq ttl t)) 1565 nil
1533 nil)
1534 ((stringp ttl)
1535 (setq ttl (w3-fix-spaces ttl)) 1566 (setq ttl (w3-fix-spaces ttl))
1536 (if (and ttl (string= ttl "")) 1567 (if (and ttl (string= ttl ""))
1537 (setq ttl (w3-fix-spaces (url-view-url t)))) 1568 (setq ttl (w3-fix-spaces (url-view-url t))))
1538 (rename-buffer (url-generate-new-buffer-name ttl)) 1569 (rename-buffer (url-generate-new-buffer-name ttl))
1539 ;; Make the URL show in list-buffers output 1570 ;; Make the URL show in list-buffers output
1540 (make-local-variable 'list-buffers-directory) 1571 (make-local-variable 'list-buffers-directory)
1541 (setq list-buffers-directory (url-view-url t)) 1572 (setq list-buffers-directory (url-view-url t))
1542 (w3-put-state :title t)) 1573 (w3-put-state :title t))))
1543 (t nil))))
1544 1574
1545 (fset 'w3-handle-/head 'w3-handle-/title) 1575 (fset 'w3-handle-/head 'w3-handle-/title)
1546 1576
1547 (defun w3-handle-hyperlink (&optional args) 1577 (defun w3-handle-hyperlink (&optional args)
1548 (let* ((href-node (assq 'href args)) 1578 (let* ((href-node (assq 'href args))
1555 (progn 1585 (progn
1556 (setq href (url-expand-file-name href (cdr-safe 1586 (setq href (url-expand-file-name href (cdr-safe
1557 (assoc base w3-base-alist)))) 1587 (assoc base w3-base-alist))))
1558 (setcdr href-node href))) 1588 (setcdr href-node href)))
1559 (w3-put-state :seen-this-url (url-have-visited-url href)) 1589 (w3-put-state :seen-this-url (url-have-visited-url href))
1560 (if (and w3-delimit-links (not (eq w3-delimit-links 'linkname)) href)
1561 (progn
1562 (if (w3-get-state :seen-this-url)
1563 (w3-handle-text (cdr w3-link-start-delimiter))
1564 (w3-handle-text (car w3-link-start-delimiter)))
1565 (w3-put-state :needspace 'never)))
1566 (w3-put-state :zone (point)) 1590 (w3-put-state :zone (point))
1567 (w3-put-state :link-args args) 1591 (w3-put-state :link-args args)
1568 (if title (w3-put-state :link-title title)) 1592 (if title (w3-put-state :link-title title))
1569 (if href (w3-put-state :href href)) 1593 (if href (w3-put-state :href href))
1570 (if name (w3-put-state :name name)))) 1594 (if name (w3-put-state :name name))))
1571 1595
1572 (defun w3-follow-hyperlink (widget &rest ignore) 1596 (defun w3-follow-hyperlink (widget &rest ignore)
1573 (let ((target (widget-get widget 'target)) 1597 (let* ((target (widget-get widget 'target))
1574 (href (widget-get widget 'href))) 1598 (href (widget-get widget 'href))
1599 (tag 'a)
1600 (args '((class . "visited")))
1601 (face (cdr (w3-face-for-element)))
1602 (old-face (and (widget-get widget :from)
1603 (get-text-property (widget-get widget :from) 'face)))
1604 (faces (cond
1605 ((and old-face (consp old-face)) (cons face old-face))
1606 (old-face (cons face (list old-face)))
1607 (t (list face)))))
1575 (if target (setq target (intern (downcase target)))) 1608 (if target (setq target (intern (downcase target))))
1609 (put-text-property (widget-get widget :from) (widget-get widget :to)
1610 'face faces)
1576 (case target 1611 (case target
1577 ((_blank external) 1612 ((_blank external)
1578 (w3-fetch-other-frame href)) 1613 (w3-fetch-other-frame href))
1579 (_top 1614 (_top
1580 (delete-other-windows) 1615 (delete-other-windows)
1581 (w3-fetch href)) 1616 (w3-fetch href))
1582 (otherwise 1617 (otherwise
1583 (w3-fetch href))))) 1618 (w3-fetch href)))))
1619
1620 (defun w3-balloon-help-callback (object &optional event)
1621 (let* ((widget (widget-at (extent-start-position object)))
1622 (href (and widget (widget-get widget 'href))))
1623 (if href
1624 (url-truncate-url-for-viewing href)
1625 nil)))
1584 1626
1585 (defun w3-handle-hyperlink-end (&optional args) 1627 (defun w3-handle-hyperlink-end (&optional args)
1586 (let* ((href (w3-get-state :href)) 1628 (let* ((href (w3-get-state :href))
1587 (old-args (w3-get-state :link-args)) 1629 (old-args (w3-get-state :link-args))
1588 (name (w3-get-state :name)) 1630 (name (w3-get-state :name))
1604 (append 1646 (append
1605 (list 'push :args nil :value "" :tag "" 1647 (list 'push :args nil :value "" :tag ""
1606 :notify 'w3-follow-hyperlink 1648 :notify 'w3-follow-hyperlink
1607 :from (set-marker (make-marker) zone) 1649 :from (set-marker (make-marker) zone)
1608 :to (set-marker (make-marker) (point)) 1650 :to (set-marker (make-marker) (point))
1609 :help-echo (case w3-echo-link 1651 )
1610 (text
1611 (buffer-substring
1612 zone (point)))
1613 (url href)
1614 (otherwise nil)))
1615 (alist-to-plist old-args)) 1652 (alist-to-plist old-args))
1616 'face faces 1653 'face faces
1654 'balloon-help 'w3-balloon-help-callback
1617 'title (cons 1655 'title (cons
1618 (set-marker (make-marker) zone) 1656 (set-marker (make-marker) zone)
1619 (set-marker (make-marker) (point))) 1657 (set-marker (make-marker) (point)))
1620 'help-echo href)) 1658 'help-echo href))
1621 (w3-put-state :zone nil) 1659 (w3-put-state :zone nil)
1622 (w3-put-state :href nil) 1660 (w3-put-state :href nil)
1623 (w3-put-state :name nil) 1661 (w3-put-state :name nil)
1624
1625 (if (and w3-delimit-links href)
1626 (progn
1627 (delete-region (point) (progn (skip-chars-backward " ")
1628 (point)))
1629 (if (eq w3-delimit-links 'linkname)
1630 (w3-handle-text (concat (if btdt (cdr w3-link-start-delimiter)
1631 (car w3-link-start-delimiter))
1632 (or name "noname")
1633 (if btdt (cdr w3-link-end-delimiter)
1634 (car w3-link-end-delimiter))))
1635 (if btdt
1636 (w3-handle-text (cdr w3-link-end-delimiter))
1637 (w3-handle-text (car w3-link-end-delimiter)))))
1638 (goto-char (point-max)))
1639 (if (and w3-link-info-display-function 1662 (if (and w3-link-info-display-function
1640 (fboundp w3-link-info-display-function)) 1663 (fboundp w3-link-info-display-function))
1641 (let ((info (condition-case () 1664 (let ((info (condition-case ()
1642 (funcall w3-link-info-display-function href) 1665 (funcall w3-link-info-display-function href)
1643 (error nil)))) 1666 (error nil))))
1938 (if url-find-this-link 1961 (if url-find-this-link
1939 (w3-find-specific-link url-find-this-link)) 1962 (w3-find-specific-link url-find-this-link))
1940 (let* ((tag 'html) 1963 (let* ((tag 'html)
1941 (args nil) 1964 (args nil)
1942 (face (cdr (w3-face-for-element)))) 1965 (face (cdr (w3-face-for-element))))
1966 (if (not face)
1967 (setq tag 'body
1968 face (cdr (w3-face-for-element))))
1943 (and face 1969 (and face
1944 (if (not (fboundp 'valid-specifier-locale-p)) 1970 (if (not (fboundp 'valid-specifier-locale-p))
1945 nil 1971 nil
1946 (w3-my-safe-copy-face face 'default (current-buffer)))))) 1972 (w3-my-safe-copy-face face 'default (current-buffer))))))
1947 1973