|
14
|
1 ;;; w3-display.el --- display engine v99999
|
|
|
2 ;; Author: wmperry
|
|
185
|
3 ;; Created: 1997/08/12 22:51:19
|
|
|
4 ;; Version: 1.200
|
|
14
|
5 ;; Keywords: faces, help, hypermedia
|
|
|
6
|
|
|
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
8 ;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu)
|
|
82
|
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
|
|
14
|
10 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
11 ;;;
|
|
|
12 ;;; This file is part of GNU Emacs.
|
|
|
13 ;;;
|
|
|
14 ;;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
15 ;;; it under the terms of the GNU General Public License as published by
|
|
|
16 ;;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
17 ;;; any later version.
|
|
|
18 ;;;
|
|
|
19 ;;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
20 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
21 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
22 ;;; GNU General Public License for more details.
|
|
|
23 ;;;
|
|
|
24 ;;; You should have received a copy of the GNU General Public License
|
|
|
25 ;;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
|
26 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
27 ;;; Boston, MA 02111-1307, USA.
|
|
|
28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
29 (require 'cl)
|
|
136
|
30 (eval-when-compile
|
|
|
31 (require 'w3-props))
|
|
14
|
32 (require 'css)
|
|
|
33 (require 'font)
|
|
|
34 (require 'w3-widget)
|
|
|
35 (require 'w3-imap)
|
|
|
36
|
|
165
|
37 (define-widget-keywords :active-face :emacspeak-help :href
|
|
|
38 :name :target :title :src)
|
|
88
|
39 (autoload 'sentence-ify "flame")
|
|
|
40 (autoload 'string-ify "flame")
|
|
|
41 (autoload '*flame "flame")
|
|
|
42 (if (not (fboundp 'flatten)) (autoload 'flatten "flame"))
|
|
|
43 (defvar w3-cookie-cache nil)
|
|
|
44
|
|
14
|
45 (defmacro w3-d-s-var-def (var)
|
|
|
46 (` (make-variable-buffer-local (defvar (, var) nil))))
|
|
|
47
|
|
108
|
48 (w3-d-s-var-def w3-display-label-marker)
|
|
14
|
49 (w3-d-s-var-def w3-display-open-element-stack)
|
|
|
50 (w3-d-s-var-def w3-display-alignment-stack)
|
|
|
51 (w3-d-s-var-def w3-display-list-stack)
|
|
82
|
52 (w3-d-s-var-def w3-display-form-id)
|
|
14
|
53 (w3-d-s-var-def w3-display-whitespace-stack)
|
|
173
|
54 (w3-d-s-var-def w3-display-liststyle-stack)
|
|
14
|
55 (w3-d-s-var-def w3-display-font-family-stack)
|
|
|
56 (w3-d-s-var-def w3-display-font-weight-stack)
|
|
|
57 (w3-d-s-var-def w3-display-font-variant-stack)
|
|
|
58 (w3-d-s-var-def w3-display-font-size-stack)
|
|
|
59 (w3-d-s-var-def w3-face-color)
|
|
82
|
60 (w3-d-s-var-def w3-face-background-color)
|
|
14
|
61 (w3-d-s-var-def w3-active-faces)
|
|
|
62 (w3-d-s-var-def w3-active-voices)
|
|
|
63 (w3-d-s-var-def w3-current-form-number)
|
|
|
64 (w3-d-s-var-def w3-face-font-family)
|
|
|
65 (w3-d-s-var-def w3-face-font-weight)
|
|
|
66 (w3-d-s-var-def w3-face-font-variant)
|
|
|
67 (w3-d-s-var-def w3-face-font-size)
|
|
|
68 (w3-d-s-var-def w3-face-font-family)
|
|
|
69 (w3-d-s-var-def w3-face-font-size)
|
|
88
|
70 (w3-d-s-var-def w3-face-font-style)
|
|
14
|
71 (w3-d-s-var-def w3-face-font-spec)
|
|
|
72 (w3-d-s-var-def w3-face-text-decoration)
|
|
|
73 (w3-d-s-var-def w3-face-face)
|
|
|
74 (w3-d-s-var-def w3-face-descr)
|
|
165
|
75 (w3-d-s-var-def w3-face-background-image)
|
|
14
|
76 (w3-d-s-var-def w3-display-css-properties)
|
|
118
|
77 (w3-d-s-var-def w3-display-background-properties)
|
|
14
|
78
|
|
|
79 (eval-when-compile
|
|
|
80 (defmacro w3-get-attribute (attr)
|
|
|
81 (` (cdr-safe (assq (, attr) args))))
|
|
|
82
|
|
116
|
83 (defmacro w3-get-face-info (info &optional other)
|
|
14
|
84 (let ((var (intern (format "w3-face-%s" info))))
|
|
116
|
85 (` (push (w3-get-style-info (quote (, info)) node
|
|
124
|
86 (or (and (not w3-user-colors-take-precedence)
|
|
|
87 (cdr-safe (assq (quote (, other))
|
|
|
88 (nth 1 node))))
|
|
116
|
89 (car (, var))))
|
|
14
|
90 (, var)))))
|
|
|
91
|
|
|
92 (defmacro w3-pop-face-info (info)
|
|
|
93 (let ((var (intern (format "w3-face-%s" info))))
|
|
|
94 (` (pop (, var)))))
|
|
|
95
|
|
|
96 (defmacro w3-get-all-face-info ()
|
|
|
97 (`
|
|
|
98 (progn
|
|
|
99 (w3-get-face-info font-family)
|
|
118
|
100 ;; This is to handle the 'face' attribute on arbitrary elements
|
|
|
101 (if (cdr-safe (assq 'face (nth 1 node)))
|
|
|
102 (setf (car w3-face-font-family)
|
|
|
103 (append (car w3-face-font-family)
|
|
|
104 (split-string (cdr-safe
|
|
|
105 (assq 'face (nth 1 node)))
|
|
|
106 " *, *"))))
|
|
88
|
107 (w3-get-face-info font-style)
|
|
14
|
108 (w3-get-face-info font-weight)
|
|
|
109 (w3-get-face-info font-variant)
|
|
|
110 (w3-get-face-info font-size)
|
|
|
111 (w3-get-face-info text-decoration)
|
|
165
|
112 (w3-get-face-info background-image)
|
|
116
|
113 (w3-get-face-info color color)
|
|
|
114 (w3-get-face-info background-color bgcolor)
|
|
14
|
115 (setq w3-face-font-spec (make-font
|
|
|
116 :weight (car w3-face-font-weight)
|
|
|
117 :family (car w3-face-font-family)
|
|
|
118 :size (car w3-face-font-size))))))
|
|
|
119
|
|
|
120 (defmacro w3-pop-all-face-info ()
|
|
|
121 (`
|
|
|
122 (progn
|
|
|
123 (w3-pop-face-info font-family)
|
|
|
124 (w3-pop-face-info font-weight)
|
|
|
125 (w3-pop-face-info font-variant)
|
|
|
126 (w3-pop-face-info font-size)
|
|
88
|
127 (w3-pop-face-info font-style)
|
|
14
|
128 (w3-pop-face-info text-decoration)
|
|
165
|
129 (w3-pop-face-info background-image)
|
|
14
|
130 (w3-pop-face-info color)
|
|
82
|
131 (w3-pop-face-info background-color))))
|
|
14
|
132
|
|
|
133 )
|
|
|
134
|
|
82
|
135 (defvar w3-display-same-buffer nil)
|
|
14
|
136 (defvar w3-face-cache nil "Cache for w3-face-for-element")
|
|
|
137 (defvar w3-face-index 0)
|
|
|
138 (defvar w3-image-widgets-waiting nil)
|
|
|
139
|
|
|
140 (make-variable-buffer-local 'w3-last-fill-pos)
|
|
|
141
|
|
|
142 (defconst w3-fill-prefixes-vector
|
|
|
143 (let ((len 0)
|
|
|
144 (prefix-vector (make-vector 80 nil)))
|
|
|
145 (while (< len 80)
|
|
|
146 (aset prefix-vector len (make-string len ? ))
|
|
|
147 (setq len (1+ len)))
|
|
|
148 prefix-vector))
|
|
|
149
|
|
|
150 (defconst w3-line-breaks-vector
|
|
|
151 (let ((len 0)
|
|
|
152 (breaks-vector (make-vector 10 nil)))
|
|
|
153 (while (< len 10)
|
|
|
154 (aset breaks-vector len (make-string len ?\n))
|
|
|
155 (setq len (1+ len)))
|
|
|
156 breaks-vector))
|
|
|
157
|
|
165
|
158 (defsubst w3-pause ()
|
|
|
159 (save-excursion
|
|
|
160 (goto-char (or (symbol-value 'cur-viewing-pos) (point-min)))
|
|
|
161 (cond
|
|
169
|
162 (w3-running-xemacs
|
|
|
163 (if (and (not (sit-for 0)) (input-pending-p))
|
|
|
164 (condition-case ()
|
|
|
165 (dispatch-event (next-command-event))
|
|
|
166 (error nil))))
|
|
|
167 (t
|
|
165
|
168 (if (and (not (sit-for 0)) (input-pending-p))
|
|
|
169 (condition-case ()
|
|
|
170 (progn
|
|
|
171 (set 'cur-viewing-pos
|
|
|
172 (lookup-key w3-mode-map (vector (read-event))))
|
|
|
173 (case (symbol-value 'cur-viewing-pos)
|
|
|
174 ((w3-quit w3-leave-buffer) nil)
|
|
|
175 (otherwise (call-interactively (symbol-value 'cur-viewing-pos)))))
|
|
169
|
176 (error nil)))))
|
|
165
|
177 (set 'cur-viewing-pos (point))))
|
|
14
|
178
|
|
|
179 (defmacro w3-get-pad-string (len)
|
|
|
180 (` (cond
|
|
|
181 ((< (, len) 0)
|
|
|
182 "")
|
|
|
183 ((< (, len) 80)
|
|
|
184 (aref w3-fill-prefixes-vector (, len)))
|
|
|
185 (t (make-string (, len) ? )))))
|
|
|
186
|
|
|
187 (defsubst w3-set-fill-prefix-length (len)
|
|
|
188 (setq fill-prefix (if (< len (- (or w3-strict-width (window-width)) 4))
|
|
|
189 (w3-get-pad-string len)
|
|
|
190 (url-warn
|
|
|
191 'html
|
|
|
192 "Runaway indentation! Too deep for window width!")
|
|
|
193 fill-prefix)))
|
|
|
194
|
|
|
195 (defsubst w3-get-style-info (info node &optional default)
|
|
|
196 (or (cdr-safe (assq info w3-display-css-properties)) default))
|
|
|
197
|
|
|
198 (defun w3-decode-area-coords (str)
|
|
|
199 (let (retval)
|
|
|
200 (while (string-match "\\([ \t0-9]+\\),\\([ \t0-9]+\\)" str)
|
|
|
201 (setq retval (cons (vector (string-to-int (match-string 1 str))
|
|
|
202 (string-to-int (match-string 2 str))) retval)
|
|
|
203 str (substring str (match-end 0) nil)))
|
|
|
204 (if (string-match "\\([0-9]+\\)" str)
|
|
|
205 (setq retval (cons (vector (+ (aref (car retval) 0)
|
|
|
206 (string-to-int (match-string 1 str)))
|
|
|
207 (aref (car retval) 1)) retval)))
|
|
|
208 (nreverse retval)))
|
|
|
209
|
|
|
210 (defun w3-normalize-color (color)
|
|
|
211 (cond
|
|
|
212 ((valid-color-name-p color)
|
|
|
213 color)
|
|
|
214 ((valid-color-name-p (concat "#" color))
|
|
|
215 (concat "#" color))
|
|
|
216 ((string-match "[ \t\r\n]" color)
|
|
|
217 (w3-normalize-color
|
|
|
218 (mapconcat (function (lambda (x) (if (memq x '(?\t ?\r ?\n ? )) ""
|
|
|
219 (char-to-string x)))) color "")))
|
|
|
220 ((valid-color-name-p (font-normalize-color color))
|
|
|
221 (font-normalize-color color))
|
|
|
222 (t
|
|
|
223 (w3-warn 'html (format "Bad color specification: %s" color))
|
|
|
224 nil)))
|
|
|
225
|
|
|
226 (defsubst w3-voice-for-element (node)
|
|
|
227 (if (featurep 'emacspeak)
|
|
|
228 (let (family gain left right pitch pitch-range stress richness voice)
|
|
|
229 (setq family (w3-get-style-info 'voice-family node)
|
|
|
230 gain (w3-get-style-info 'gain node)
|
|
|
231 left (w3-get-style-info 'left-volume node)
|
|
|
232 right (w3-get-style-info 'right-volume node)
|
|
|
233 pitch (w3-get-style-info 'pitch node)
|
|
|
234 pitch-range (w3-get-style-info 'pitch-range node)
|
|
|
235 stress (w3-get-style-info 'stress node)
|
|
|
236 richness (w3-get-style-info 'richness node))
|
|
|
237 (if (or family gain left right pitch pitch-range stress richness)
|
|
|
238 (setq voice (dtk-personality-from-speech-style
|
|
|
239 (make-dtk-speech-style :family (or family 'paul)
|
|
|
240 :gain (or gain 5)
|
|
|
241 :left-volume (or left 5)
|
|
|
242 :right-volume (or right 5)
|
|
|
243 :average-pitch (or pitch 5)
|
|
|
244 :pitch-range (or pitch-range 5)
|
|
|
245 :stress (or stress 5)
|
|
|
246 :richness (or richness 5))))
|
|
|
247 (setq voice nil))
|
|
|
248 (or voice (car w3-active-voices)))))
|
|
|
249
|
|
|
250 (defun w3-make-face-emacs19 (name &optional doc-string temporary)
|
|
|
251 "Defines and returns a new FACE described by DOC-STRING.
|
|
185
|
252 If the face already exists, it is unmodified."
|
|
14
|
253 (make-face name))
|
|
|
254
|
|
|
255 (cond
|
|
|
256 ((not (fboundp 'make-face))
|
|
|
257 (fset 'w3-make-face 'ignore))
|
|
|
258 (w3-running-xemacs
|
|
|
259 (fset 'w3-make-face 'make-face))
|
|
|
260 (t
|
|
|
261 (fset 'w3-make-face 'w3-make-face-emacs19)))
|
|
|
262
|
|
|
263 (defsubst w3-face-for-element (node)
|
|
|
264 (w3-get-all-face-info)
|
|
|
265 (if (car w3-face-text-decoration)
|
|
|
266 (set-font-style-by-keywords w3-face-font-spec
|
|
|
267 (car w3-face-text-decoration)))
|
|
|
268 (if w3-face-font-variant
|
|
|
269 (set-font-style-by-keywords w3-face-font-spec
|
|
|
270 (car w3-face-font-variant)))
|
|
88
|
271 (if w3-face-font-style
|
|
|
272 (set-font-style-by-keywords w3-face-font-spec
|
|
|
273 (car w3-face-font-style)))
|
|
14
|
274 (setq w3-face-descr (list w3-face-font-spec
|
|
165
|
275 (car w3-face-background-image)
|
|
14
|
276 (car w3-face-color)
|
|
82
|
277 (car w3-face-background-color))
|
|
14
|
278 w3-face-face (cdr-safe (assoc w3-face-descr w3-face-cache)))
|
|
|
279 (if (or w3-face-face (not (or (car w3-face-color)
|
|
165
|
280 (car w3-face-background-image)
|
|
82
|
281 (car w3-face-background-color)
|
|
14
|
282 w3-face-font-spec)))
|
|
|
283 nil ; Do nothing, we got it already
|
|
|
284 (setq w3-face-face
|
|
|
285 (w3-make-face (intern (format "w3-style-face-%05d" w3-face-index))
|
|
|
286 "An Emacs-W3 face... don't edit by hand." t)
|
|
|
287 w3-face-index (1+ w3-face-index))
|
|
165
|
288 (if (car w3-face-background-image)
|
|
|
289 (w3-maybe-start-background-image-download
|
|
|
290 (car w3-face-background-image) w3-face-face))
|
|
14
|
291 (if w3-face-font-spec
|
|
108
|
292 (font-set-face-font w3-face-face w3-face-font-spec))
|
|
14
|
293 (if (car w3-face-color)
|
|
108
|
294 (font-set-face-foreground w3-face-face (car w3-face-color)))
|
|
82
|
295 (if (car w3-face-background-color)
|
|
108
|
296 (font-set-face-background w3-face-face (car w3-face-background-color)))
|
|
14
|
297 (setq w3-face-cache (cons
|
|
|
298 (cons w3-face-descr w3-face-face)
|
|
|
299 w3-face-cache)))
|
|
|
300 w3-face-face)
|
|
|
301
|
|
|
302 (defun w3-normalize-spaces (string)
|
|
|
303 ;; nuke spaces in the middle
|
|
|
304 (while (string-match "[ \t\r\n][ \r\t\n]+" string)
|
|
|
305 (setq string (concat (substring string 0 (1+ (match-beginning 0)))
|
|
|
306 (substring string (match-end 0)))))
|
|
|
307
|
|
|
308 ;; nuke spaces at the beginning
|
|
|
309 (if (string-match "^[ \t\r\n]+" string)
|
|
|
310 (setq string (substring string (match-end 0))))
|
|
|
311
|
|
|
312 ;; nuke spaces at the end
|
|
|
313 (if (string-match "[ \t\n\r]+$" string)
|
|
|
314 (setq string (substring string 0 (match-beginning 0))))
|
|
|
315 string)
|
|
|
316
|
|
|
317
|
|
165
|
318 (if (not (fboundp 'char-before))
|
|
173
|
319 (defun char-before (&optional pos)
|
|
|
320 (char-after (1- (or pos (point))))))
|
|
165
|
321
|
|
14
|
322 (defsubst w3-display-line-break (n)
|
|
|
323 (if (or
|
|
|
324 (memq (car w3-display-whitespace-stack) '(pre nowrap)) ; Been told
|
|
|
325 (= w3-last-fill-pos (point))
|
|
|
326 (> w3-last-fill-pos (point-max)))
|
|
165
|
327 (if (not (eq (char-before) ?\n))
|
|
|
328 (setq n (1+ n))) ; at least put one line in
|
|
14
|
329 (let ((fill-column (max (1+ (length fill-prefix)) fill-column))
|
|
|
330 width)
|
|
|
331 (case (car w3-display-alignment-stack)
|
|
|
332 (center
|
|
|
333 (fill-region-as-paragraph w3-last-fill-pos (point))
|
|
|
334 (center-region w3-last-fill-pos (point-max)))
|
|
|
335 ((justify full)
|
|
|
336 (fill-region-as-paragraph w3-last-fill-pos (point) t))
|
|
|
337 (right
|
|
|
338 (fill-region-as-paragraph w3-last-fill-pos (point))
|
|
|
339 (goto-char w3-last-fill-pos)
|
|
|
340 (catch 'fill-exit
|
|
|
341 (while (re-search-forward ".$" nil t)
|
|
|
342 (if (>= (setq width (current-column)) fill-column)
|
|
|
343 nil ; already justified, or error
|
|
|
344 (beginning-of-line)
|
|
118
|
345 (insert-char ? (- fill-column width) t)
|
|
14
|
346 (end-of-line)
|
|
|
347 (if (eobp)
|
|
|
348 (throw 'fill-exit t))
|
|
|
349 (condition-case ()
|
|
|
350 (forward-char 1)
|
|
|
351 (error (throw 'fill-exit t))))))
|
|
|
352 )
|
|
|
353 (otherwise ; Default is left justification
|
|
|
354 (fill-region-as-paragraph w3-last-fill-pos (point)))
|
|
|
355 ))
|
|
|
356 (setq n (1- n)))
|
|
|
357 (setq w3-last-fill-pos (point-max))
|
|
|
358 (insert (cond
|
|
|
359 ((<= n 0) "")
|
|
|
360 ((< n 10)
|
|
|
361 (aref w3-line-breaks-vector n))
|
|
|
362 (t
|
|
|
363 (make-string n ?\n)))))
|
|
|
364
|
|
|
365 (defsubst w3-munge-line-breaks-p ()
|
|
|
366 (eq (car w3-display-whitespace-stack) 'pre))
|
|
|
367
|
|
185
|
368 (defvar w3-display-nil-face (if w3-running-xemacs
|
|
|
369 (w3-make-face nil "Stub face... don't ask." t)
|
|
|
370 nil))
|
|
14
|
371
|
|
|
372 (defvar w3-scratch-start-point nil)
|
|
|
373
|
|
|
374 (defsubst w3-handle-string-content (string)
|
|
|
375 (setq w3-scratch-start-point (point))
|
|
|
376 (insert string)
|
|
|
377 (if (w3-munge-line-breaks-p)
|
|
|
378 (progn
|
|
|
379 (goto-char w3-scratch-start-point)
|
|
|
380 (if (not (search-forward "\n" nil t))
|
|
|
381 (subst-char-in-region w3-scratch-start-point (point-max) ?\r ?\n)
|
|
|
382 (subst-char-in-region w3-scratch-start-point (point-max) ?\r ? )))
|
|
|
383 (goto-char w3-scratch-start-point)
|
|
|
384 (while (re-search-forward
|
|
|
385 " [ \t\n\r]+\\|[\t\n\r][ \t\n\r]*"
|
|
|
386 nil 'move)
|
|
|
387 (replace-match " "))
|
|
|
388 (goto-char w3-scratch-start-point)
|
|
169
|
389 (if (and (memq (char-before) '(? ?\t ?\r ?\n))
|
|
14
|
390 (looking-at "[ \t\r\n]"))
|
|
|
391 (delete-region (point)
|
|
|
392 (progn
|
|
|
393 (skip-chars-forward " \t\r\n")
|
|
|
394 (point)))))
|
|
|
395 (goto-char (point-max))
|
|
|
396 (add-text-properties w3-scratch-start-point
|
|
98
|
397 (point) (list 'face w3-active-faces
|
|
102
|
398 'html-stack w3-display-open-element-stack
|
|
118
|
399 'start-open nil
|
|
|
400 'end-open nil
|
|
|
401 'front-sticky t
|
|
|
402 'rear-nonsticky nil
|
|
98
|
403 'duplicable t))
|
|
14
|
404 (if (car w3-active-voices)
|
|
|
405 (add-text-properties w3-scratch-start-point (point)
|
|
|
406 (list 'personality (car w3-active-voices))))
|
|
|
407 )
|
|
|
408
|
|
88
|
409 (defun w3-display-get-cookie (args)
|
|
|
410 (if (not (fboundp 'cookie))
|
|
|
411 "Sorry, no cookies today."
|
|
|
412 (let* ((href (or (w3-get-attribute 'href) (w3-get-attribute 'src)))
|
|
|
413 (fname (or (cdr-safe (assoc href w3-cookie-cache))
|
|
|
414 (url-generate-unique-filename "%s.cki")))
|
|
|
415 (st (or (cdr-safe (assq 'start args)) "Loading cookies..."))
|
|
|
416 (nd (or (cdr-safe (assq 'end args)) "Loading cookies... done.")))
|
|
|
417 (if (not (file-exists-p fname))
|
|
|
418 (save-excursion
|
|
|
419 (set-buffer (generate-new-buffer " *cookie*"))
|
|
|
420 (url-insert-file-contents href)
|
|
|
421 (write-region (point-min) (point-max) fname 5)
|
|
|
422 (setq w3-cookie-cache (cons (cons href fname) w3-cookie-cache))))
|
|
|
423 (cookie fname st nd))))
|
|
|
424
|
|
14
|
425 (defun w3-widget-echo (widget &rest ignore)
|
|
165
|
426 (let* ((url (widget-get widget :href))
|
|
|
427 (name (widget-get widget :name))
|
|
185
|
428 (text (buffer-substring-no-properties (widget-get widget :from)
|
|
|
429 (widget-get widget :to)))
|
|
165
|
430 (title (widget-get widget :title))
|
|
|
431 (check w3-echo-link)
|
|
|
432 (msg nil))
|
|
82
|
433 (if url
|
|
|
434 (setq url (url-truncate-url-for-viewing url)))
|
|
14
|
435 (if name
|
|
|
436 (setq name (concat "anchor:" name)))
|
|
82
|
437 (if (not (listp check))
|
|
|
438 (setq check (cons check '(title url text name))))
|
|
|
439 (catch 'exit
|
|
|
440 (while check
|
|
|
441 (and (boundp (car check))
|
|
|
442 (stringp (symbol-value (car check)))
|
|
108
|
443 (> (length (symbol-value (car check))) 0)
|
|
82
|
444 (throw 'exit (symbol-value (car check))))
|
|
|
445 (pop check)))))
|
|
14
|
446
|
|
|
447 (defun w3-follow-hyperlink (widget &rest ignore)
|
|
165
|
448 (let* ((target (or (widget-get widget :target) w3-base-target))
|
|
|
449 (href (widget-get widget :href)))
|
|
14
|
450 (if target (setq target (intern (downcase target))))
|
|
|
451 (case target
|
|
|
452 ((_blank external)
|
|
|
453 (w3-fetch-other-frame href))
|
|
|
454 (_top
|
|
|
455 (delete-other-windows)
|
|
|
456 (w3-fetch href))
|
|
|
457 (otherwise
|
|
108
|
458 (w3-fetch href target)))))
|
|
14
|
459
|
|
|
460 (defun w3-balloon-help-callback (object &optional event)
|
|
|
461 (let* ((widget (widget-at (extent-start-position object)))
|
|
165
|
462 (href (widget-get widget :href)))
|
|
14
|
463 (if href
|
|
|
464 (url-truncate-url-for-viewing href)
|
|
|
465 nil)))
|
|
|
466
|
|
|
467
|
|
|
468 ;; Various macros
|
|
|
469 (eval-when-compile
|
|
122
|
470 (defmacro w3-node-visible-p ()
|
|
|
471 (` (not (eq (car break-style) 'none))))
|
|
|
472
|
|
14
|
473 (defmacro w3-handle-empty-tag ()
|
|
|
474 (`
|
|
|
475 (progn
|
|
|
476 (push (cons tag args) w3-display-open-element-stack)
|
|
|
477 (push content content-stack)
|
|
|
478 (setq content nil))))
|
|
|
479
|
|
|
480 (defmacro w3-handle-content (node)
|
|
|
481 (`
|
|
|
482 (progn
|
|
|
483 (push (cons tag args) w3-display-open-element-stack)
|
|
|
484 (push content content-stack)
|
|
100
|
485 (setq content (nth 2 (, node))))))
|
|
14
|
486
|
|
|
487 (defmacro w3-display-handle-list-type ()
|
|
|
488 (`
|
|
118
|
489 (add-text-properties
|
|
|
490 (point)
|
|
|
491 (progn
|
|
|
492 (case (car break-style)
|
|
|
493 (list-item
|
|
173
|
494 (let ((list-style (or (car w3-display-liststyle-stack) 'disc))
|
|
118
|
495 (list-num (if (car w3-display-list-stack)
|
|
|
496 (incf (car w3-display-list-stack))
|
|
|
497 1))
|
|
|
498 (margin (1- (car left-margin-stack)))
|
|
|
499 (indent (w3-get-style-info 'text-indent node 0)))
|
|
|
500 (if (> indent 0)
|
|
|
501 (setq margin (+ margin indent))
|
|
|
502 (setq margin (max 0 (- margin indent))))
|
|
|
503 (beginning-of-line)
|
|
|
504 (case list-style
|
|
|
505 ((disc circle square)
|
|
|
506 (insert (format (format "%%%dc" margin)
|
|
|
507 (or (cdr-safe (assq list-style w3-bullets))
|
|
|
508 ?o))))
|
|
|
509 ((decimal lower-roman upper-roman lower-alpha upper-alpha)
|
|
|
510 (let ((x (case list-style
|
|
|
511 (lower-roman
|
|
|
512 (w3-decimal-to-roman list-num))
|
|
|
513 (upper-roman
|
|
|
514 (upcase
|
|
|
515 (w3-decimal-to-roman list-num)))
|
|
|
516 (lower-alpha
|
|
|
517 (w3-decimal-to-alpha list-num))
|
|
|
518 (upper-alpha
|
|
|
519 (upcase
|
|
|
520 (w3-decimal-to-alpha list-num)))
|
|
|
521 (otherwise
|
|
|
522 (int-to-string list-num)))))
|
|
|
523 (insert (format (format "%%%ds." margin) x))
|
|
|
524 )
|
|
|
525 )
|
|
|
526 (otherwise
|
|
|
527 (insert (w3-get-pad-string margin)))
|
|
14
|
528 )
|
|
|
529 )
|
|
118
|
530 )
|
|
|
531 (otherwise
|
|
|
532 (insert (w3-get-pad-string (+ (car left-margin-stack)
|
|
|
533 (w3-get-style-info 'text-indent node 0)))))
|
|
14
|
534 )
|
|
118
|
535 (point))
|
|
|
536 (list 'start-open t
|
|
|
537 'end-open t
|
|
|
538 'rear-nonsticky nil
|
|
|
539 'face 'nil))))
|
|
14
|
540
|
|
|
541 (defmacro w3-display-set-margins ()
|
|
|
542 (`
|
|
|
543 (progn
|
|
|
544 (push (+ (w3-get-style-info 'margin-left node 0)
|
|
|
545 (car left-margin-stack)) left-margin-stack)
|
|
|
546 (push (-
|
|
|
547 (car right-margin-stack)
|
|
|
548 (w3-get-style-info 'margin-right node 0)) right-margin-stack)
|
|
|
549 (setq fill-column (car right-margin-stack))
|
|
|
550 (w3-set-fill-prefix-length (car left-margin-stack))
|
|
|
551 (w3-display-handle-list-type))))
|
|
|
552
|
|
|
553 (defmacro w3-display-restore-margins ()
|
|
|
554 (`
|
|
|
555 (progn
|
|
|
556 (pop right-margin-stack)
|
|
|
557 (pop left-margin-stack))))
|
|
|
558
|
|
|
559 (defmacro w3-display-handle-break ()
|
|
|
560 (`
|
|
|
561 (case (car break-style)
|
|
|
562 (block ; Full paragraph break
|
|
|
563 (if (eq (cadr break-style) 'list-item)
|
|
|
564 (setf (cadr break-style) 'line)
|
|
|
565 (w3-display-line-break 1))
|
|
|
566 (w3-display-set-margins)
|
|
|
567 (push
|
|
|
568 (w3-get-style-info 'white-space node
|
|
|
569 (car w3-display-whitespace-stack))
|
|
|
570 w3-display-whitespace-stack)
|
|
|
571 (push
|
|
173
|
572 (or (w3-get-attribute 'foobarblatz)
|
|
|
573 (w3-get-style-info 'list-style-type node
|
|
|
574 (car w3-display-liststyle-stack)))
|
|
|
575 w3-display-liststyle-stack)
|
|
|
576 (push
|
|
14
|
577 (or (w3-get-attribute 'align)
|
|
|
578 (w3-get-style-info 'text-align node
|
|
|
579 (car w3-display-alignment-stack)))
|
|
|
580 w3-display-alignment-stack)
|
|
|
581 (and w3-do-incremental-display (w3-pause)))
|
|
|
582 ((line list-item) ; Single line break
|
|
|
583 (w3-display-line-break 0)
|
|
|
584 (w3-display-set-margins)
|
|
|
585 (push
|
|
173
|
586 (or (w3-get-attribute 'foobarblatz)
|
|
|
587 (w3-get-style-info 'list-style-type node
|
|
|
588 (car w3-display-liststyle-stack)))
|
|
|
589 w3-display-liststyle-stack)
|
|
|
590 (push
|
|
14
|
591 (w3-get-style-info 'white-space node
|
|
|
592 (car w3-display-whitespace-stack))
|
|
|
593 w3-display-whitespace-stack)
|
|
|
594 (push
|
|
|
595 (w3-get-style-info 'text-align node
|
|
|
596 (or (w3-get-attribute 'align)
|
|
|
597 (car w3-display-alignment-stack)))
|
|
|
598 w3-display-alignment-stack))
|
|
|
599 (otherwise ; Assume 'inline' rendering as default
|
|
|
600 nil))
|
|
|
601 )
|
|
|
602 )
|
|
|
603
|
|
100
|
604 (defmacro w3-display-progress-meter ()
|
|
|
605 (`
|
|
|
606 (url-lazy-message "Drawing... %c" (aref "/|\\-" (random 4)))))
|
|
|
607
|
|
14
|
608 (defmacro w3-display-handle-end-break ()
|
|
|
609 (`
|
|
|
610 (case (pop break-style)
|
|
|
611 (block ; Full paragraph break
|
|
|
612 (w3-display-line-break 1)
|
|
|
613 (w3-display-restore-margins)
|
|
|
614 (pop w3-display-whitespace-stack)
|
|
173
|
615 (pop w3-display-liststyle-stack)
|
|
14
|
616 (pop w3-display-alignment-stack)
|
|
|
617 (and w3-do-incremental-display (w3-pause)))
|
|
|
618 ((line list-item) ; Single line break
|
|
|
619 (w3-display-restore-margins)
|
|
|
620 (w3-display-line-break 0)
|
|
|
621 (pop w3-display-whitespace-stack)
|
|
173
|
622 (pop w3-display-liststyle-stack)
|
|
14
|
623 (pop w3-display-alignment-stack))
|
|
|
624 (otherwise ; Assume 'inline' rendering as default
|
|
|
625 nil))
|
|
|
626 )
|
|
|
627 )
|
|
|
628 )
|
|
|
629
|
|
|
630 ;; <link> handling
|
|
|
631 (defun w3-parse-link (args)
|
|
|
632 (let* ((type (if (w3-get-attribute 'rel) 'rel 'rev))
|
|
|
633 (desc (w3-get-attribute type))
|
|
|
634 (dc-desc (and desc (downcase desc))) ; canonical case
|
|
|
635 (dest (w3-get-attribute 'href))
|
|
|
636 (plist (alist-to-plist args))
|
|
|
637 (node-1 (assq type w3-current-links))
|
|
|
638 (node-2 (and node-1 desc (or (assoc desc
|
|
|
639 (cdr node-1))
|
|
|
640 (assoc dc-desc
|
|
|
641 (cdr node-1)))))
|
|
|
642 )
|
|
|
643 ;; Canonicalize the case of link types we may look for
|
|
|
644 ;; specifically (toolbar etc.) since that's done with
|
|
|
645 ;; assoc. See `w3-mail-document-author' and
|
|
|
646 ;; `w3-link-toolbar', at least.
|
|
|
647 (if (member dc-desc w3-defined-link-types)
|
|
|
648 (setq desc dc-desc))
|
|
|
649 (if dest ; ignore if HREF missing
|
|
|
650 (cond
|
|
|
651 (node-2 ; Add to old value
|
|
|
652 (setcdr node-2 (cons plist (cdr node-2))))
|
|
|
653 (node-1 ; first rel/rev
|
|
|
654 (setcdr node-1 (cons (cons desc (list plist))
|
|
|
655 (cdr node-1))))
|
|
|
656 (t (setq w3-current-links
|
|
|
657 (cons (cons type (list (cons desc (list plist))))
|
|
|
658 w3-current-links)))))
|
|
|
659 (setq desc (and desc (intern dc-desc)))
|
|
|
660 (case desc
|
|
|
661 ((style stylesheet)
|
|
108
|
662 (if w3-honor-stylesheets
|
|
|
663 (w3-handle-style plist)))
|
|
14
|
664 (otherwise
|
|
|
665 )
|
|
|
666 )
|
|
|
667 )
|
|
|
668 )
|
|
|
669
|
|
|
670
|
|
|
671 ;; Image handling
|
|
|
672 (defun w3-maybe-start-image-download (widget)
|
|
165
|
673 (let* ((src (widget-get widget :src))
|
|
14
|
674 (cached-glyph (w3-image-cached-p src)))
|
|
98
|
675 (cond
|
|
|
676 ((and cached-glyph
|
|
|
677 (widget-glyphp cached-glyph)
|
|
|
678 (not (eq 'nothing
|
|
|
679 (image-instance-type
|
|
|
680 (glyph-image-instance cached-glyph)))))
|
|
|
681 (setq w3-image-widgets-waiting (cons widget w3-image-widgets-waiting)))
|
|
|
682 ((or w3-delay-image-loads ; Delaying images
|
|
|
683 (not (fboundp 'valid-specifier-domain-p)) ; Can't do images
|
|
|
684 (eq (device-type) 'tty)) ; Why bother?
|
|
|
685 (w3-add-delayed-graphic widget))
|
|
|
686 ((not (w3-image-loadable-p src nil)) ; Hey, we can't load it!
|
|
165
|
687 (mesage "Skipping image %s" (url-basepath src t))
|
|
98
|
688 (w3-add-delayed-graphic widget))
|
|
|
689 (t ; Grab the images
|
|
|
690 (let (
|
|
|
691 (url-request-method "GET")
|
|
|
692 (old-asynch url-be-asynchronous)
|
|
|
693 (url-request-data nil)
|
|
|
694 (url-request-extra-headers nil)
|
|
|
695 (url-source t)
|
|
|
696 (url-mime-accept-string (substring
|
|
|
697 (mapconcat
|
|
|
698 (function
|
|
|
699 (lambda (x)
|
|
|
700 (if x
|
|
|
701 (concat (car x) ",")
|
|
|
702 "")))
|
|
|
703 w3-allowed-image-types "")
|
|
|
704 0 -1))
|
|
|
705 (url-working-buffer (generate-new-buffer-name " *W3GRAPH*")))
|
|
|
706 (setq-default url-be-asynchronous t)
|
|
|
707 (setq w3-graphics-list (cons (cons src (make-glyph))
|
|
|
708 w3-graphics-list))
|
|
|
709 (save-excursion
|
|
|
710 (set-buffer (get-buffer-create url-working-buffer))
|
|
165
|
711 (setq url-current-callback-data (list src (widget-get widget 'buffer)
|
|
|
712 widget)
|
|
98
|
713 url-be-asynchronous t
|
|
|
714 url-current-callback-func 'w3-finalize-image-download)
|
|
|
715 (url-retrieve src))
|
|
|
716 (setq-default url-be-asynchronous old-asynch))))))
|
|
14
|
717
|
|
165
|
718 (defun w3-maybe-start-background-image-download (src face)
|
|
|
719 (let* ((cached-glyph (w3-image-cached-p src))
|
|
|
720 (buf (current-buffer)))
|
|
|
721 (cond
|
|
|
722 ((and cached-glyph
|
|
|
723 (widget-glyphp cached-glyph)
|
|
|
724 (not (eq 'nothing
|
|
|
725 (image-instance-type
|
|
|
726 (glyph-image-instance cached-glyph)))))
|
|
|
727 (set-face-background-pixmap face
|
|
|
728 (glyph-image-instance cached-glyph) buf))
|
|
|
729 ((or (not (fboundp 'valid-specifier-domain-p)) ; Can't do images
|
|
|
730 (eq (device-type) 'tty)) ; Why bother?
|
|
|
731 nil)
|
|
|
732 ((not (w3-image-loadable-p src nil)) ; Hey, we can't load it!
|
|
|
733 (mesage "Skipping image %s" (url-basepath src t))
|
|
|
734 nil)
|
|
|
735 (t ; Grab the images
|
|
|
736 (let (
|
|
|
737 (url-request-method "GET")
|
|
|
738 (old-asynch url-be-asynchronous)
|
|
|
739 (url-request-data nil)
|
|
|
740 (url-request-extra-headers nil)
|
|
|
741 (url-source t)
|
|
|
742 (url-mime-accept-string (substring
|
|
|
743 (mapconcat
|
|
|
744 (function
|
|
|
745 (lambda (x)
|
|
|
746 (if x
|
|
|
747 (concat (car x) ",")
|
|
|
748 "")))
|
|
|
749 w3-allowed-image-types "")
|
|
|
750 0 -1))
|
|
|
751 (url-working-buffer (generate-new-buffer-name " *W3GRAPH*")))
|
|
|
752 (setq-default url-be-asynchronous t)
|
|
|
753 (setq w3-graphics-list (cons (cons src (make-glyph))
|
|
|
754 w3-graphics-list))
|
|
|
755 (save-excursion
|
|
|
756 (set-buffer (get-buffer-create url-working-buffer))
|
|
|
757 (setq url-current-callback-data (list src buf 'background face)
|
|
|
758 url-be-asynchronous t
|
|
|
759 url-current-callback-func 'w3-finalize-image-download)
|
|
|
760 (url-retrieve src))
|
|
|
761 (setq-default url-be-asynchronous old-asynch))))))
|
|
|
762
|
|
|
763 (defun w3-finalize-image-download (url buffer &optional widget face)
|
|
14
|
764 (let ((glyph nil)
|
|
165
|
765 (node nil))
|
|
14
|
766 (message "Enhancing image...")
|
|
|
767 (setq glyph (image-normalize (cdr-safe (assoc url-current-mime-type
|
|
|
768 w3-image-mappings))
|
|
|
769 (buffer-string)))
|
|
|
770 (message "Enhancing image... done")
|
|
|
771 (kill-buffer (current-buffer))
|
|
|
772 (cond
|
|
|
773 ((w3-image-invalid-glyph-p glyph)
|
|
|
774 (setq glyph nil)
|
|
98
|
775 (message "Reading of %s failed." url))
|
|
14
|
776 ((eq (aref glyph 0) 'xbm)
|
|
|
777 (let ((temp-fname (url-generate-unique-filename "%s.xbm")))
|
|
|
778 (save-excursion
|
|
|
779 (set-buffer (generate-new-buffer " *xbm-garbage*"))
|
|
|
780 (erase-buffer)
|
|
|
781 (insert (aref glyph 2))
|
|
|
782 (setq glyph temp-fname)
|
|
|
783 (write-region (point-min) (point-max) temp-fname)
|
|
|
784 (kill-buffer (current-buffer)))
|
|
|
785 (setq glyph (make-glyph (list (cons 'x glyph))))
|
|
|
786 (condition-case ()
|
|
|
787 (delete-file temp-fname)
|
|
|
788 (error nil))))
|
|
|
789 (t
|
|
|
790 (setq glyph (make-glyph glyph))))
|
|
|
791 (setq node (assoc url w3-graphics-list))
|
|
|
792 (cond
|
|
|
793 ((and node glyph)
|
|
|
794 (set-glyph-image (cdr node) (glyph-image glyph)))
|
|
|
795 (glyph
|
|
|
796 (setq w3-graphics-list (cons (cons url glyph) w3-graphics-list)))
|
|
|
797 (t nil))
|
|
|
798
|
|
165
|
799 (cond
|
|
|
800 ((or (not buffer)
|
|
|
801 (not (widget-glyphp glyph))
|
|
|
802 (not (buffer-name buffer)))
|
|
|
803 nil)
|
|
|
804 ((and (eq widget 'background)
|
|
|
805 w3-running-xemacs)
|
|
|
806 (set-face-background-pixmap face
|
|
|
807 (glyph-image-instance glyph)
|
|
|
808 buffer))
|
|
|
809 ((not (eq widget 'background))
|
|
|
810 (save-excursion
|
|
|
811 (set-buffer buffer)
|
|
|
812 (if (eq major-mode 'w3-mode)
|
|
|
813 (widget-value-set widget glyph)
|
|
|
814 (setq w3-image-widgets-waiting
|
|
|
815 (cons widget w3-image-widgets-waiting))))))))
|
|
14
|
816
|
|
|
817 (defmacro w3-handle-image ()
|
|
|
818 (`
|
|
|
819 (let* ((height (w3-get-attribute 'height))
|
|
|
820 (width (w3-get-attribute 'width))
|
|
|
821 (src (or (w3-get-attribute 'src) "Error Image"))
|
|
|
822 (our-alt (cond
|
|
|
823 ((null w3-auto-image-alt) "")
|
|
|
824 ((eq t w3-auto-image-alt)
|
|
|
825 (concat "[IMAGE(" (url-basepath src t) ")] "))
|
|
|
826 ((stringp w3-auto-image-alt)
|
|
|
827 (format w3-auto-image-alt (url-basepath src t)))))
|
|
|
828 (alt (or (w3-get-attribute 'alt) our-alt))
|
|
116
|
829 (c nil)
|
|
14
|
830 (ismap (and (assq 'ismap args) 'ismap))
|
|
|
831 (usemap (w3-get-attribute 'usemap))
|
|
|
832 (base (w3-get-attribute 'base))
|
|
165
|
833 (href (and hyperlink-info (widget-get (cadr hyperlink-info) :href)))
|
|
|
834 (target (and hyperlink-info (widget-get (cadr hyperlink-info) :target)))
|
|
14
|
835 (widget nil)
|
|
|
836 (align (or (w3-get-attribute 'align)
|
|
|
837 (w3-get-style-info 'vertical-align node))))
|
|
116
|
838 (while (setq c (string-match "[\C-i\C-j\C-l\C-m]" alt))
|
|
|
839 (aset alt c ? ))
|
|
88
|
840 (if (assq '*table-autolayout w3-display-open-element-stack)
|
|
|
841 (insert alt)
|
|
|
842 (setq widget (widget-create 'image
|
|
|
843 :value-face w3-active-faces
|
|
165
|
844 :src src ; Where to load the image from
|
|
88
|
845 'alt alt ; Textual replacement
|
|
|
846 'ismap ismap ; Is it a server-side map?
|
|
|
847 'usemap usemap ; Is it a client-side map?
|
|
165
|
848 :href href ; Hyperlink destination
|
|
|
849 :target target
|
|
88
|
850 ))
|
|
|
851 (widget-put widget 'buffer (current-buffer))
|
|
|
852 (w3-maybe-start-image-download widget)
|
|
108
|
853 (if (widget-get widget :from)
|
|
|
854 (add-text-properties (widget-get widget :from)
|
|
|
855 (widget-get widget :to)
|
|
|
856 (list 'html-stack w3-display-open-element-stack)))
|
|
88
|
857 (goto-char (point-max))))))
|
|
14
|
858
|
|
|
859 ;; The table handling
|
|
185
|
860 (eval-and-compile
|
|
|
861 (cond
|
|
|
862 ((and w3-running-xemacs (featurep 'mule) (not (find-charset 'w3-dingbats)))
|
|
136
|
863 (make-charset 'w3-dingbats "Dingbats character set for Emacs/W3"
|
|
|
864 '(registry "" dimension 1 chars 96 final ?:)))
|
|
185
|
865 ((and (featurep 'mule) (not (charsetp 'w3-dingbats)))
|
|
|
866 (define-charset nil 'w3-dingbats
|
|
|
867 (vector
|
|
|
868 1 ; dimension
|
|
|
869 96 ; chars
|
|
|
870 1 ; width
|
|
|
871 0 ; direction
|
|
|
872 ?: ; iso-final-char
|
|
|
873 1 ; iso-graphic-plane (whats this?)
|
|
|
874 "dingbats" "emacs/w3-dingbats"
|
|
|
875 "Dingbats character set for Emacs/W3")))
|
|
|
876 (t
|
|
|
877 nil)))
|
|
136
|
878
|
|
|
879 (defun w3-make-char (oct)
|
|
|
880 (if (and w3-running-xemacs (featurep 'mule))
|
|
|
881 (make-char 'w3-dingbats (if (characterp oct) (char-int oct) oct))
|
|
|
882 oct))
|
|
|
883
|
|
116
|
884 (defvar w3-table-ascii-border-chars
|
|
185
|
885 [nil nil nil ?+ nil ?- ?+ ?- nil ?+ ?| ?| ?+ ?- ?| ?+]
|
|
116
|
886 "*Vector of ascii characters to use to draw table borders.
|
|
|
887 This vector is used when terminal characters are unavailable")
|
|
|
888
|
|
|
889 (defvar w3-table-glyph-border-chars
|
|
|
890 [nil nil nil 11 nil 2 7 14 nil 3 8 6 1 15 4 5]
|
|
|
891 "Vector of characters to use to draw table borders.
|
|
|
892 This vector is used when terminal characters are used via glyphs")
|
|
|
893
|
|
|
894 (defvar w3-table-graphic-border-chars
|
|
136
|
895 (vector
|
|
|
896 nil
|
|
|
897 nil
|
|
|
898 nil
|
|
|
899 (w3-make-char ?j)
|
|
|
900 nil
|
|
|
901 (w3-make-char ?q)
|
|
|
902 (w3-make-char ?m)
|
|
|
903 (w3-make-char ?v)
|
|
|
904 nil
|
|
|
905 (w3-make-char ?k)
|
|
|
906 (w3-make-char ?x)
|
|
|
907 (w3-make-char ?u)
|
|
|
908 (w3-make-char ?l)
|
|
|
909 (w3-make-char ?w)
|
|
|
910 (w3-make-char ?t)
|
|
|
911 (w3-make-char ?n))
|
|
116
|
912 "Vector of characters to use to draw table borders.
|
|
|
913 This vector is used when terminal characters are used directly")
|
|
|
914
|
|
|
915 (defvar w3-table-border-chars w3-table-ascii-border-chars
|
|
|
916 "Vector of characters to use to draw table borders.
|
|
|
917 w3-setup-terminal-chars sets this to one of
|
|
|
918 w3-table-ascii-border-chars,
|
|
|
919 w3-table-glyph-border-chars, or
|
|
|
920 w3-table-graphic-border-chars.")
|
|
|
921
|
|
165
|
922 (defsubst w3-table-lookup-char (l u r b &optional char)
|
|
116
|
923 (aref w3-table-border-chars (logior (if l 1 0)
|
|
|
924 (if u 2 0)
|
|
|
925 (if r 4 0)
|
|
|
926 (if b 8 0))))
|
|
|
927
|
|
|
928 (defvar w3-terminal-properties nil)
|
|
|
929
|
|
|
930 (defsubst w3-insert-terminal-char (character &optional count inherit)
|
|
|
931 (if w3-terminal-properties
|
|
|
932 (set-text-properties (point)
|
|
|
933 (progn
|
|
|
934 (insert-char (or character ? )
|
|
|
935 (or count 1) inherit)
|
|
|
936 (point))
|
|
|
937 w3-terminal-properties)
|
|
|
938 (insert-char (or character ? ) (or count 1) inherit)))
|
|
|
939
|
|
|
940 (defsubst w3-horizontal-rule-char nil
|
|
|
941 (or w3-horizontal-rule-char (w3-table-lookup-char t nil t nil)))
|
|
|
942
|
|
165
|
943 (defun w3-setup-terminal-chars ()
|
|
116
|
944 "Try to find the best set of characters to draw table borders with.
|
|
|
945 On a console, this can trigger some Emacs display bugs.
|
|
|
946
|
|
|
947 Initializes a number of variables:
|
|
|
948 w3-terminal-properties to either nil or a list of properties including 'face
|
|
|
949 w3-table-border-chars to one of the the three other vectors"
|
|
|
950 (interactive)
|
|
|
951 (setq w3-table-border-chars w3-table-ascii-border-chars
|
|
|
952 w3-terminal-properties nil)
|
|
|
953 (cond
|
|
|
954 ((and w3-use-terminal-characters
|
|
|
955 (eq (device-type) 'x))
|
|
118
|
956 (if (and (find-face 'w3-table-hack-x-face)
|
|
|
957 (face-differs-from-default-p 'w3-table-hack-x-face))
|
|
|
958 nil
|
|
116
|
959 (make-face 'w3-table-hack-x-face)
|
|
118
|
960 (if (not (face-differs-from-default-p 'w3-table-hack-x-face))
|
|
|
961 (font-set-face-font 'w3-table-hack-x-face
|
|
|
962 (make-font :family "terminal"
|
|
|
963 :registry "*"
|
|
|
964 :encoding "*"
|
|
|
965 ))))
|
|
116
|
966 (cond
|
|
|
967 ((not (face-differs-from-default-p 'w3-table-hack-x-face))
|
|
|
968 nil)
|
|
|
969 ((and w3-use-terminal-glyphs (fboundp 'face-id))
|
|
|
970 (let ((id (face-id 'w3-table-hack-x-face))
|
|
|
971 (c (length w3-table-border-chars)))
|
|
|
972 (while (> (decf c) 0)
|
|
|
973 (if (aref w3-table-glyph-border-chars c)
|
|
|
974 (aset standard-display-table (aref w3-table-glyph-border-chars c)
|
|
|
975 (vector (+ (* 256 id)
|
|
|
976 (aref w3-table-graphic-border-chars c))))))
|
|
|
977 (setq w3-table-border-chars w3-table-glyph-border-chars
|
|
|
978 w3-terminal-properties nil)))
|
|
|
979 (t
|
|
|
980 (setq w3-table-border-chars w3-table-graphic-border-chars
|
|
|
981 w3-terminal-properties (list 'start-open t
|
|
|
982 'end-open t
|
|
|
983 'rear-nonsticky t
|
|
|
984 'w3-table-border t
|
|
|
985 'face 'w3-table-hack-x-face)))))
|
|
|
986 ((and w3-use-terminal-characters-on-tty
|
|
|
987 (eq (device-type) 'tty))
|
|
|
988 (let ((c (length w3-table-border-chars)))
|
|
|
989 (while (> (decf c) 0)
|
|
|
990 (and (aref w3-table-glyph-border-chars c)
|
|
|
991 (aref w3-table-graphic-border-chars c)
|
|
|
992 (standard-display-g1 (aref w3-table-glyph-border-chars c)
|
|
|
993 (aref w3-table-graphic-border-chars c)))))
|
|
|
994 (setq w3-table-border-chars w3-table-glyph-border-chars
|
|
|
995 w3-terminal-properties (list 'w3-table-border t)))
|
|
|
996 (t
|
|
|
997 nil))
|
|
|
998 w3-table-border-chars)
|
|
|
999
|
|
|
1000 (defun w3-unsetup-terminal-characters nil
|
|
|
1001 (interactive)
|
|
|
1002 (w3-excise-terminal-characters (buffer-list))
|
|
|
1003 (standard-display-default 1 15)
|
|
|
1004 (setq w3-table-border-chars w3-table-ascii-border-chars))
|
|
|
1005
|
|
|
1006 (defun w3-excise-terminal-characters (buffs)
|
|
|
1007 "Replace hacked characters with ascii characters in buffers BUFFS.
|
|
|
1008 Should be run before restoring w3-table-border-chars to ascii characters.
|
|
|
1009 This will only work if we used glyphs rather than text properties"
|
|
|
1010 (interactive (list (list (current-buffer))))
|
|
|
1011 (let ((inhibit-read-only t)
|
|
|
1012 (tr (make-string 16 ? ))
|
|
|
1013 (i 0))
|
|
|
1014 (while (< i (length tr))
|
|
|
1015 (aset tr i i)
|
|
|
1016 (setq i (1+ i)))
|
|
|
1017 (setq i 0)
|
|
|
1018 (while (< i (length w3-table-border-chars))
|
|
|
1019 (and (aref w3-table-border-chars i)
|
|
|
1020 (< (aref w3-table-border-chars i) 16)
|
|
|
1021 (aset tr
|
|
|
1022 (aref w3-table-glyph-border-chars i)
|
|
|
1023 (aref w3-table-ascii-border-chars i)))
|
|
|
1024 (setq i (1+ i)))
|
|
|
1025 (mapcar (function (lambda (buf)
|
|
|
1026 (save-excursion
|
|
|
1027 (set-buffer buf)
|
|
|
1028 (if (eq major-mode 'w3-mode)
|
|
|
1029 (translate-region (point-min)
|
|
|
1030 (point-max)
|
|
|
1031 tr)))))
|
|
|
1032 buffs)))
|
|
|
1033
|
|
|
1034
|
|
14
|
1035 (defvar w3-display-table-cut-words-p nil
|
|
|
1036 "*Whether to cut words that are oversized in table cells")
|
|
|
1037
|
|
|
1038 (defvar w3-display-table-force-borders nil
|
|
116
|
1039 "*Whether to always draw table borders
|
|
|
1040 Can sometimes make the structure of a document clearer")
|
|
14
|
1041
|
|
|
1042 (defun w3-display-table-cut ()
|
|
|
1043 (save-excursion
|
|
|
1044 (goto-char (point-min))
|
|
|
1045 (let ((offset -1))
|
|
|
1046 (while (< offset 0)
|
|
|
1047 (end-of-line)
|
|
|
1048 (setq offset (- fill-column (current-column)))
|
|
|
1049 (cond ((< offset 0)
|
|
|
1050 (condition-case nil
|
|
|
1051 (progn (forward-char offset)
|
|
|
1052 (insert ?\n))
|
|
|
1053 (error (setq offset 0))))
|
|
|
1054 ((not (eobp))
|
|
|
1055 (forward-line 1)
|
|
|
1056 (setq offset -1)))))))
|
|
|
1057
|
|
|
1058
|
|
|
1059 (defun w3-display-fix-widgets ()
|
|
|
1060 ;; Make markers belong to the right buffer
|
|
|
1061 (save-excursion
|
|
|
1062 (let ((st (point-min))
|
|
|
1063 (nd nil)
|
|
|
1064 (widget nil) parent
|
|
|
1065 (to-marker nil)
|
|
|
1066 (from-marker nil))
|
|
|
1067 (while (setq st (next-single-property-change st 'button))
|
|
|
1068 (setq nd (or (next-single-property-change st 'button) (point-max))
|
|
|
1069 widget (widget-at st)
|
|
|
1070 to-marker (and widget (widget-get widget :to))
|
|
|
1071 from-marker (and widget (widget-get widget :from))
|
|
|
1072 parent (and widget (widget-get widget :parent))
|
|
|
1073 )
|
|
|
1074 (if (not widget)
|
|
|
1075 nil
|
|
|
1076 (widget-put widget :from (set-marker (make-marker) st))
|
|
|
1077 (widget-put widget :to (set-marker (make-marker) nd))
|
|
|
1078 (if (not parent)
|
|
|
1079 nil
|
|
|
1080 (widget-put parent :from (set-marker (make-marker) st))
|
|
|
1081 (widget-put parent :to (set-marker (make-marker) nd))))
|
|
|
1082 (if (condition-case ()
|
|
|
1083 (get-text-property (1+ nd) 'button)
|
|
|
1084 (error nil))
|
|
|
1085 (setq st nd)
|
|
|
1086 (setq st (min (point-max) (1+ nd))))))))
|
|
|
1087
|
|
|
1088 (defun w3-size-of-tree (tree minmax)
|
|
98
|
1089 (declare (special args))
|
|
14
|
1090 (save-excursion
|
|
|
1091 (save-restriction
|
|
|
1092 (narrow-to-region (point) (point))
|
|
|
1093 ;; XXX fill-column set to 1 fails when fill-prefix is set
|
|
|
1094 ;; XXX setting fill-column at all isn't really right
|
|
|
1095 ;; for example <hr>s shouldn't be especially wide
|
|
|
1096 ;; we should set a flag that makes w3 never wrap a line
|
|
|
1097 (let ((fill-column (cond ((eq minmax 'min)
|
|
|
1098 3)
|
|
|
1099 ((eq minmax 'max)
|
|
|
1100 400)))
|
|
|
1101 (fill-prefix "")
|
|
|
1102 (w3-last-fill-pos (point-min))
|
|
|
1103 a retval
|
|
|
1104 (w3-do-incremental-display nil)
|
|
|
1105 (hr-regexp (concat "^"
|
|
|
1106 (regexp-quote
|
|
116
|
1107 (make-string 5 (w3-horizontal-rule-char)))
|
|
14
|
1108 "*$"))
|
|
|
1109 )
|
|
|
1110 ;;(push 'left w3-display-alignment-stack)
|
|
|
1111 (push (if (eq minmax 'max) 'nowrap) w3-display-whitespace-stack)
|
|
|
1112 (while tree
|
|
|
1113 (push (cons '*td args) w3-display-open-element-stack)
|
|
|
1114 (w3-display-node (pop tree)))
|
|
|
1115 (pop w3-display-whitespace-stack)
|
|
|
1116 (goto-char (point-min))
|
|
|
1117 (while (re-search-forward hr-regexp nil t)
|
|
|
1118 (replace-match "" t t))
|
|
|
1119 (goto-char (point-min))
|
|
|
1120 (while (not (eobp))
|
|
|
1121 ;; loop invariant: at beginning of uncounted line
|
|
|
1122 (end-of-line)
|
|
|
1123 (skip-chars-backward " ")
|
|
|
1124 (setq retval (cons (current-column)
|
|
|
1125 retval))
|
|
|
1126 (beginning-of-line 2))
|
|
|
1127 (if (= (point-min) (point-max))
|
|
|
1128 (setq retval 0)
|
|
|
1129 (setq retval (apply 'max (cons 0 retval))))
|
|
|
1130 (delete-region (point-min) (point-max))
|
|
|
1131 retval))))
|
|
|
1132
|
|
|
1133 (defun w3-display-table-dimensions (node)
|
|
|
1134 ;; fill-column sets maximum width
|
|
98
|
1135 (declare (special args))
|
|
14
|
1136 (let (min-vector
|
|
|
1137 max-vector
|
|
|
1138 rows cols
|
|
|
1139 ;;(w3-form-elements (and (boundp 'w3-form-elements) w3-form-elements))
|
|
|
1140 (table-info (assq 'w3-table-info (cadr node))))
|
|
|
1141
|
|
|
1142 (if table-info
|
|
|
1143 (setq min-vector (nth 1 table-info)
|
|
|
1144 max-vector (nth 2 table-info)
|
|
|
1145 rows (nth 3 table-info)
|
|
|
1146 cols (nth 4 table-info))
|
|
|
1147
|
|
|
1148 (push (cons '*table-autolayout args) w3-display-open-element-stack)
|
|
|
1149 (let (content
|
|
|
1150 cur
|
|
|
1151 (table-spans (list nil)) ; don't make this '(nil)
|
|
|
1152 ptr
|
|
|
1153 col
|
|
|
1154 constraints
|
|
|
1155
|
|
|
1156 colspan rowspan min max)
|
|
|
1157 (setq content (nth 2 node))
|
|
|
1158 (setq rows 0 cols 0)
|
|
|
1159 (while content
|
|
|
1160 (setq cur (pop content))
|
|
|
1161 (if (stringp cur)
|
|
|
1162 nil
|
|
|
1163 (case (car cur)
|
|
138
|
1164 ((thead tfoot col colgroup)
|
|
|
1165 (if (nth 2 cur)
|
|
|
1166 (setq content (append (nth 2 cur) content))))
|
|
14
|
1167 (tr
|
|
|
1168 (setq col 0)
|
|
|
1169 (setq rows (1+ rows))
|
|
|
1170 (setq ptr table-spans)
|
|
|
1171 (mapcar
|
|
|
1172 (function
|
|
|
1173 (lambda (td)
|
|
|
1174 (setq colspan (string-to-int (or (cdr-safe (assq 'colspan (nth 1 td))) "1"))
|
|
|
1175 rowspan (string-to-int (or (cdr-safe (assq 'rowspan (nth 1 td))) "1"))
|
|
|
1176 min (w3-size-of-tree (nth 2 td) 'min)
|
|
|
1177 max (w3-size-of-tree (nth 2 td) 'max)
|
|
|
1178 )
|
|
|
1179 (while (eq (car-safe (car-safe (cdr ptr))) col)
|
|
|
1180 (setq col (+ col (cdr (cdr (car (cdr ptr))))))
|
|
|
1181 (if (= 0 (decf (car (cdr (car (cdr ptr))))))
|
|
|
1182 (pop (cdr ptr))
|
|
|
1183 (setq ptr (cdr ptr))))
|
|
|
1184 (push (list col colspan min max)
|
|
|
1185 constraints)
|
|
|
1186 (if (= rowspan 1) nil
|
|
|
1187 (push (cons col (cons (1- rowspan) colspan)) (cdr ptr))
|
|
|
1188 (setq ptr (cdr ptr)))
|
|
|
1189 (setq col (+ col colspan))
|
|
|
1190 ))
|
|
|
1191 (nth 2 cur))
|
|
|
1192 (while (cdr ptr)
|
|
|
1193 (if (= 0 (decf (car (cdr (car (cdr ptr))))))
|
|
|
1194 (pop (cdr ptr))
|
|
|
1195 (setq ptr (cdr ptr))))
|
|
|
1196 (setq cols (max cols col))
|
|
|
1197 )
|
|
|
1198 (caption
|
|
|
1199 nil)
|
|
|
1200 (otherwise
|
|
|
1201 (setq content (nth 2 cur)))
|
|
|
1202 )
|
|
|
1203 )
|
|
|
1204 )
|
|
|
1205 (setq constraints (sort constraints
|
|
|
1206 (function
|
|
|
1207 (lambda (a b)
|
|
|
1208 (< (cadr a) (cadr b)))))
|
|
|
1209 min-vector (make-vector cols 0)
|
|
|
1210 max-vector (make-vector cols 0))
|
|
|
1211 (let (start end i mincellwidth maxcellwidth)
|
|
|
1212 (mapcar (function (lambda (c)
|
|
|
1213 (cond ((= (cadr c) 1)
|
|
|
1214 (aset min-vector (car c)
|
|
|
1215 (max (aref min-vector (car c))
|
|
|
1216 (nth 2 c)))
|
|
|
1217 (aset max-vector (car c)
|
|
|
1218 (max (aref max-vector (car c))
|
|
|
1219 (nth 3 c))))
|
|
|
1220 (t
|
|
|
1221 (setq start (car c)
|
|
|
1222 end (+ (car c) (cadr c))
|
|
|
1223 mincellwidth 0
|
|
|
1224 maxcellwidth 0
|
|
|
1225 i start)
|
|
|
1226 (while (< i end)
|
|
|
1227 (setq mincellwidth (+ mincellwidth
|
|
|
1228 (aref min-vector i))
|
|
|
1229 maxcellwidth (+
|
|
|
1230 maxcellwidth
|
|
|
1231 (aref max-vector i))
|
|
|
1232 i (1+ i)))
|
|
|
1233 (setq i start)
|
|
|
1234 (if (= mincellwidth 0)
|
|
|
1235 ;; if existing width is 0 divide evenly
|
|
|
1236 (while (< i end)
|
|
|
1237 (aset min-vector i
|
|
|
1238 (/ (nth 2 c) (cadr c)))
|
|
|
1239 (aset max-vector i
|
|
|
1240 (/ (nth 3 c) (cadr c)))
|
|
|
1241 (setq i (1+ i)))
|
|
|
1242 ;; otherwise weight it by existing widths
|
|
|
1243 (while (< i end)
|
|
|
1244 (aset min-vector i
|
|
|
1245 (max (aref min-vector i)
|
|
|
1246 (/ (* (nth 2 c)
|
|
|
1247 (aref min-vector i))
|
|
|
1248 mincellwidth)))
|
|
|
1249 (aset max-vector i
|
|
|
1250 (max (aref max-vector i)
|
|
|
1251 (/ (* (nth 3 c)
|
|
|
1252 (aref max-vector i))
|
|
|
1253 maxcellwidth)))
|
|
|
1254 (setq i (1+ i))))
|
|
|
1255 ))))
|
|
|
1256 constraints)))
|
|
|
1257 (push (cons 'w3-table-info
|
|
|
1258 (list min-vector max-vector rows cols))
|
|
|
1259 (cadr node))
|
|
|
1260 (pop w3-display-open-element-stack))
|
|
|
1261
|
|
|
1262 (let (max-width
|
|
|
1263 min-width
|
|
|
1264 ret-vector
|
|
|
1265 col
|
|
|
1266 )
|
|
|
1267
|
|
|
1268
|
|
|
1269 (setq max-width (apply '+ (append max-vector (list cols 1))))
|
|
|
1270 (setq min-width (apply '+ (append min-vector (list cols 1))))
|
|
|
1271
|
|
|
1272 ;; the comments in the cond are excerpts from rfc1942 itself
|
|
|
1273 (cond
|
|
|
1274 ;; 1. The minimum table width is equal to or wider than the available
|
|
|
1275 ;; space. In this case, assign the minimum widths and allow the
|
|
|
1276 ;; user to scroll horizontally. For conversion to braille, it will
|
|
|
1277 ;; be necessary to replace the cells by references to notes
|
|
|
1278 ;; containing their full content. By convention these appear
|
|
|
1279 ;; before the table.
|
|
|
1280 ((>= min-width fill-column)
|
|
|
1281 (setq ret-vector min-vector))
|
|
|
1282
|
|
|
1283 ;; 2. The maximum table width fits within the available space. In
|
|
|
1284 ;; this case, set the columns to their maximum widths.
|
|
|
1285 ((<= max-width fill-column)
|
|
|
1286 (setq ret-vector max-vector))
|
|
|
1287
|
|
|
1288 ;; 3. The maximum width of the table is greater than the available
|
|
|
1289 ;; space, but the minimum table width is smaller. In this case,
|
|
|
1290 ;; find the difference between the available space and the minimum
|
|
|
1291 ;; table width, lets call it W. Lets also call D the difference
|
|
|
1292 ;; between maximum and minimum width of the table.
|
|
|
1293
|
|
|
1294 ;; For each column, let d be the difference between maximum and
|
|
|
1295 ;; minimum width of that column. Now set the column's width to the
|
|
|
1296 ;; minimum width plus d times W over D. This makes columns with
|
|
|
1297 ;; large differences between minimum and maximum widths wider than
|
|
|
1298 ;; columns with smaller differences.
|
|
|
1299 (t
|
|
|
1300 (setq ret-vector (make-vector cols 0))
|
|
|
1301 (let ((W (- fill-column min-width))
|
|
|
1302 (D (- max-width min-width))
|
|
|
1303 d extra)
|
|
|
1304 (setq col 0)
|
|
|
1305 (while (< col (length ret-vector))
|
|
|
1306 (setq d (- (aref max-vector col)
|
|
|
1307 (aref min-vector col)))
|
|
|
1308 (aset ret-vector col
|
|
|
1309 (+ (aref min-vector col)
|
|
|
1310 (/ (* d W) D)))
|
|
|
1311 (setq col (1+ col)))
|
|
|
1312 (setq extra (- fill-column
|
|
|
1313 (apply '+ (append ret-vector
|
|
|
1314 (list (length ret-vector) 1))))
|
|
|
1315 col 0)
|
|
|
1316 (while (and (< col (length ret-vector)) (> extra 0))
|
|
|
1317 (if (= 1 (- (aref max-vector col) (aref ret-vector col) ))
|
|
|
1318 (aset ret-vector col (1+ (aref ret-vector col))))
|
|
|
1319 (setq extra (1- extra)
|
|
|
1320 col (1+ col)))
|
|
|
1321 )))
|
|
|
1322 (list rows cols ret-vector))))
|
|
|
1323
|
|
|
1324 (defun w3-display-table (node)
|
|
|
1325 (let* ((dimensions (w3-display-table-dimensions node))
|
|
|
1326 (num-cols (max (cadr dimensions) 1))
|
|
|
1327 (num-rows (max (car dimensions) 1))
|
|
|
1328 (column-dimensions (caddr dimensions))
|
|
|
1329 (table-width (apply '+ (append column-dimensions (list num-cols 1)))))
|
|
|
1330 (cond
|
|
|
1331 ((or (<= (cadr dimensions) 0) (<= (car dimensions) 0))
|
|
|
1332 ;; We have an invalid table
|
|
|
1333 nil)
|
|
|
1334 ((assq '*table-autolayout w3-display-open-element-stack)
|
|
|
1335 ;; don't bother displaying the table if all we really need is the size
|
|
|
1336 (progn (insert-char ?T table-width) (insert "\n")))
|
|
|
1337 (t
|
|
|
1338 (let* ((tag (nth 0 node))
|
|
|
1339 (args (nth 1 node))
|
|
|
1340 (border-node (cdr-safe (assq 'border args)))
|
|
|
1341 (border (or w3-display-table-force-borders
|
|
|
1342 (and border-node
|
|
|
1343 (or (/= 0 (string-to-int border-node))
|
|
|
1344 (string= "border" border-node)))))
|
|
|
1345 (w3-table-border-chars
|
|
|
1346 (if border
|
|
|
1347 w3-table-border-chars
|
|
|
1348 (make-vector (length w3-table-border-chars) ? )))
|
|
|
1349 valign align
|
|
|
1350 (content (nth 2 node))
|
|
|
1351 (avgwidth (/ (- fill-column num-cols num-cols) num-cols))
|
|
|
1352 (formatted-cols (make-vector num-cols nil))
|
|
|
1353 (table-rowspans (make-vector num-cols 0))
|
|
|
1354 (table-colspans (make-vector num-cols 1))
|
|
|
1355 (prev-colspans (make-vector num-cols 0))
|
|
|
1356 (prev-rowspans (make-vector num-cols 0))
|
|
|
1357 (table-colwidth (make-vector num-cols 0))
|
|
|
1358 (fill-prefix "")
|
|
|
1359 (height nil)
|
|
|
1360 (cur-height nil)
|
|
|
1361 (cols nil)
|
|
|
1362 (rows nil)
|
|
|
1363 (row 0)
|
|
|
1364 (this-rectangle nil)
|
|
118
|
1365 (inhibit-read-only t)
|
|
14
|
1366 (i 0)
|
|
|
1367 )
|
|
|
1368
|
|
|
1369 (push (cons tag args) w3-display-open-element-stack)
|
|
|
1370
|
|
|
1371 (if (memq 'nowrap w3-display-whitespace-stack)
|
|
|
1372 (setq fill-prefix "")
|
|
|
1373 (case (car w3-display-alignment-stack)
|
|
|
1374 (center
|
|
|
1375 (w3-set-fill-prefix-length
|
|
|
1376 (max 0 (/ (- fill-column table-width) 2))))
|
|
|
1377 (right
|
|
|
1378 (w3-set-fill-prefix-length
|
|
|
1379 (max 0 (- fill-column table-width))))
|
|
|
1380 (t
|
|
|
1381 (setq fill-prefix ""))))
|
|
|
1382 (while content
|
|
|
1383 (case (caar content)
|
|
138
|
1384 ((thead tfoot col colgroup)
|
|
|
1385 (if (nth 2 (car content))
|
|
|
1386 (setq content (append (nth 2 (car content)) (cdr content)))
|
|
|
1387 (setq content (cdr content))))
|
|
14
|
1388 (tr
|
|
|
1389 (setq w3-display-css-properties (css-get
|
|
|
1390 (nth 0 (car content))
|
|
|
1391 (nth 1 (car content))
|
|
|
1392 w3-current-stylesheet
|
|
|
1393 w3-display-open-element-stack))
|
|
|
1394 (setq cols (nth 2 (car content))
|
|
|
1395 valign (or (cdr-safe (assq 'valign (nth 1 (car content))))
|
|
|
1396 (w3-get-style-info 'vertical-align node))
|
|
|
1397 align (or (cdr-safe (assq 'align (nth 1 (car content))))
|
|
|
1398 (w3-get-style-info 'text-align node))
|
|
|
1399 content (cdr content)
|
|
|
1400 row (1+ row))
|
|
|
1401 (if (and valign (stringp valign))
|
|
|
1402 (setq valign (intern (downcase valign))))
|
|
|
1403 ;; this is iffy
|
|
|
1404 ;;(if align (push (intern (downcase align)) w3-display-alignment-stack))
|
|
|
1405 (save-excursion
|
|
|
1406 (save-restriction
|
|
|
1407 (narrow-to-region (point) (point))
|
|
|
1408 (setq fill-column avgwidth
|
|
|
1409 w3-last-fill-pos (point-min)
|
|
|
1410 i 0)
|
|
|
1411 ;; skip over columns that have leftover content
|
|
|
1412 (while (and (< i num-cols)
|
|
|
1413 (/= 0 (aref table-rowspans i)))
|
|
|
1414 (setq i (+ i (max 1 (aref table-colspans i)))))
|
|
118
|
1415 ;; Need to push the properties for the table onto the stack
|
|
|
1416 (setq w3-display-css-properties (css-get
|
|
|
1417 tag
|
|
|
1418 args
|
|
|
1419 w3-current-stylesheet
|
|
|
1420 w3-display-open-element-stack))
|
|
|
1421 (push (w3-face-for-element (list tag args nil)) w3-active-faces)
|
|
|
1422 (push (w3-voice-for-element (list tag args nil)) w3-active-voices)
|
|
|
1423 (push (cons tag args) w3-display-open-element-stack)
|
|
14
|
1424 (while cols
|
|
118
|
1425 ;; And need to push these bogus placeholders on there
|
|
|
1426 ;; so that w3-display-node doesn't pop off the real face
|
|
|
1427 ;; or voice we just put in above.
|
|
|
1428 (push nil w3-active-faces)
|
|
|
1429 (push nil w3-active-voices)
|
|
14
|
1430 (let* ((node (car cols))
|
|
|
1431 (attributes (nth 1 node))
|
|
|
1432 (colspan (string-to-int
|
|
|
1433 (or (cdr-safe (assq 'colspan attributes))
|
|
|
1434 "1")))
|
|
|
1435 (rowspan (string-to-int
|
|
|
1436 (or (cdr-safe (assq 'rowspan attributes))
|
|
|
1437 "1")))
|
|
|
1438 fill-column column-width
|
|
|
1439 (fill-prefix "")
|
|
|
1440 (w3-do-incremental-display nil)
|
|
|
1441 (indent-tabs-mode nil)
|
|
|
1442 c e
|
|
|
1443 )
|
|
|
1444
|
|
|
1445 (aset table-colspans i colspan)
|
|
|
1446 (aset table-rowspans i rowspan)
|
|
|
1447
|
|
|
1448 (setq fill-column 0)
|
|
|
1449 (setq c i
|
|
|
1450 e (+ i colspan))
|
|
|
1451 (while (< c e)
|
|
|
1452 (setq fill-column (+ fill-column
|
|
|
1453 (aref column-dimensions c)
|
|
|
1454 1)
|
|
|
1455 c (1+ c)))
|
|
|
1456 (setq fill-column (1- fill-column))
|
|
|
1457 (aset table-colwidth i fill-column)
|
|
|
1458
|
|
|
1459 (setq w3-last-fill-pos (point-min))
|
|
|
1460 (push (cons (nth 0 node) (nth 1 node))
|
|
|
1461 w3-display-open-element-stack)
|
|
|
1462 (w3-display-node node)
|
|
|
1463 (setq fill-column (aref table-colwidth i))
|
|
|
1464 (if w3-display-table-cut-words-p
|
|
|
1465 (w3-display-table-cut))
|
|
|
1466 (setq cols (cdr cols))
|
|
|
1467 (goto-char (point-min))
|
|
|
1468 (skip-chars-forward "\t\n\r")
|
|
|
1469 (beginning-of-line)
|
|
|
1470 (delete-region (point-min) (point))
|
|
|
1471 (goto-char (point-max))
|
|
|
1472 (skip-chars-backward " \t\n\r")
|
|
|
1473 (delete-region (point) (point-max))
|
|
|
1474 (if (>= fill-column (current-column))
|
|
118
|
1475 (insert-char ? (- fill-column (current-column)) t))
|
|
|
1476 (goto-char (point-min))
|
|
|
1477 ;; This gets our text properties out to the
|
|
|
1478 ;; end of lines for table rows/cells with backgrounds
|
|
|
1479 (while (not (eobp))
|
|
|
1480 (re-search-forward "$" nil t)
|
|
|
1481 (if (>= fill-column (current-column))
|
|
|
1482 (insert-char ? (- fill-column (current-column)) t))
|
|
|
1483 (or (eobp) (forward-char 1)))
|
|
14
|
1484 (aset formatted-cols i (extract-rectangle (point-min) (point-max)))
|
|
|
1485 (delete-region (point-min) (point-max))
|
|
|
1486 (let ((j (1- colspan)))
|
|
|
1487 (while (> j 0)
|
|
|
1488 (aset table-colspans (+ i j) 0)
|
|
|
1489 (setq j (1- j))))
|
|
|
1490 (setq i (+ i colspan))
|
|
|
1491 ;; skip over columns that have leftover content
|
|
|
1492 (while (and (< i num-cols)
|
|
|
1493 (/= 0 (aref table-rowspans i)))
|
|
|
1494 (setq i (+ i (max 1 (aref table-colspans i)))))
|
|
|
1495 ))
|
|
118
|
1496 (pop w3-display-open-element-stack)
|
|
|
1497 (pop w3-active-faces)
|
|
|
1498 (pop w3-active-voices)
|
|
|
1499 (w3-pop-all-face-info)
|
|
14
|
1500 ;; finish off the columns
|
|
|
1501 (while (< i num-cols)
|
|
|
1502 (aset table-colwidth i (aref column-dimensions i))
|
|
|
1503 (aset table-colspans i 1)
|
|
|
1504 (setq i (1+ i))
|
|
|
1505 (while (and (< i num-cols)
|
|
|
1506 (/= 0 (aref table-rowspans i)))
|
|
|
1507 (setq i (+ i (max 1 (aref table-colspans i))))))
|
|
|
1508
|
|
|
1509 ;; on the last row empty any pending rowspans per the rfc
|
|
|
1510 (if content nil
|
|
|
1511 (fillarray table-rowspans 1))
|
|
|
1512
|
|
|
1513 ;; Find the tallest rectangle that isn't a rowspanning cell
|
|
|
1514 (setq height 0
|
|
|
1515 i 0)
|
|
|
1516 (while (< i num-cols)
|
|
|
1517 (if (= 1 (aref table-rowspans i))
|
|
|
1518 (setq height (max height (length (aref formatted-cols i)))))
|
|
|
1519 (setq i (+ i (max 1 (aref table-colspans i)))))
|
|
|
1520
|
|
|
1521 ;; Make all rectangles the same height
|
|
|
1522 (setq i 0)
|
|
|
1523 (while (< i num-cols)
|
|
|
1524 (setq this-rectangle (aref formatted-cols i))
|
|
|
1525 (if (> height (length this-rectangle))
|
|
|
1526 (let ((colspan-fill-line
|
|
98
|
1527 (make-string (abs (aref table-colwidth i)) ? )))
|
|
14
|
1528 (case valign
|
|
|
1529 ((center middle)
|
|
|
1530 (aset formatted-cols i
|
|
|
1531 (append (make-list (/ (- height (length this-rectangle)) 2)
|
|
|
1532 colspan-fill-line)
|
|
|
1533 this-rectangle)))
|
|
|
1534 (bottom
|
|
|
1535 (aset formatted-cols i
|
|
|
1536 (append (make-list (- height (length this-rectangle))
|
|
|
1537 colspan-fill-line)
|
|
|
1538 this-rectangle))))))
|
|
|
1539 (setq i (+ i (max 1 (aref table-colspans i)))))))
|
|
|
1540
|
|
|
1541
|
|
|
1542 ;; fix broken colspans (this should only matter on illegal tables)
|
|
|
1543 (setq i 0)
|
|
|
1544 (while (< i num-cols)
|
|
|
1545 (if (= (aref table-colspans i) 0)
|
|
|
1546 (aset table-colspans i 1))
|
|
|
1547 (setq i (+ i (aref table-colspans i))))
|
|
|
1548
|
|
|
1549 ;; Insert a separator
|
|
|
1550 (insert fill-prefix)
|
|
|
1551 (setq i 0)
|
|
|
1552 (let (rflag bflag tflag lflag)
|
|
|
1553 (while (< i num-cols)
|
|
|
1554
|
|
|
1555 (setq rflag (= (aref prev-rowspans i) 0))
|
|
|
1556 (setq bflag (/= (aref table-colspans i) 0))
|
|
|
1557 (setq tflag (/= (aref prev-colspans i) 0))
|
|
|
1558
|
|
116
|
1559 (w3-insert-terminal-char (w3-table-lookup-char lflag tflag rflag bflag))
|
|
14
|
1560 (setq lflag t)
|
|
|
1561 (cond ((= (aref prev-rowspans i) 0)
|
|
116
|
1562 (w3-insert-terminal-char
|
|
|
1563 (w3-table-lookup-char t nil t nil)
|
|
|
1564 (aref column-dimensions i))
|
|
14
|
1565 (setq i (1+ i)))
|
|
|
1566 ((car (aref formatted-cols i))
|
|
|
1567 (insert (pop (aref formatted-cols i)))
|
|
|
1568 (setq lflag nil)
|
|
|
1569 (setq i (+ i (max (aref table-colspans i)
|
|
|
1570 (aref prev-colspans i) 1))))
|
|
|
1571 (t
|
|
118
|
1572 (insert-char ? (aref table-colwidth i) t)
|
|
14
|
1573 (setq lflag nil)
|
|
|
1574 (setq i (+ i (max (aref table-colspans i)
|
|
|
1575 (aref prev-colspans i) 1))))))
|
|
116
|
1576 (w3-insert-terminal-char (w3-table-lookup-char lflag (/= row 1) nil t))
|
|
|
1577 (insert "\n"))
|
|
|
1578
|
|
14
|
1579 ;; recalculate height (in case we've shortened a rowspanning cell
|
|
|
1580 (setq height 0
|
|
|
1581 i 0)
|
|
|
1582 (while (< i num-cols)
|
|
|
1583 (if (= 1 (aref table-rowspans i))
|
|
|
1584 (setq height (max height (length (aref formatted-cols i)))))
|
|
|
1585 (setq i (+ i (max 1 (aref table-colspans i)))))
|
|
|
1586
|
|
|
1587 ;; Insert a row back in original buffer
|
|
|
1588 (while (> height 0)
|
|
116
|
1589 (insert fill-prefix)
|
|
|
1590 (w3-insert-terminal-char (w3-table-lookup-char nil t nil t))
|
|
14
|
1591 (setq i 0)
|
|
|
1592 (while (< i num-cols)
|
|
|
1593 (if (car (aref formatted-cols i))
|
|
|
1594 (insert (pop (aref formatted-cols i)))
|
|
118
|
1595 (insert-char ? (aref table-colwidth i) t))
|
|
116
|
1596 (w3-insert-terminal-char (w3-table-lookup-char nil t nil t))
|
|
14
|
1597 (setq i (+ i (max (aref table-colspans i) 1))))
|
|
|
1598 (insert "\n")
|
|
|
1599 ;;(and w3-do-incremental-display (w3-pause))
|
|
|
1600 (setq height (1- height)))
|
|
|
1601
|
|
|
1602 (setq i 0)
|
|
|
1603 (while (< i num-cols)
|
|
|
1604 (if (> (aref table-rowspans i) 0)
|
|
|
1605 (decf (aref table-rowspans i)))
|
|
|
1606 (incf i))
|
|
|
1607
|
|
|
1608 (setq prev-rowspans (copy-seq table-rowspans))
|
|
|
1609 (setq prev-colspans (copy-seq table-colspans))
|
|
|
1610
|
|
|
1611 (and w3-do-incremental-display (w3-pause))
|
|
|
1612 )
|
|
|
1613 (caption
|
|
|
1614 (let ((left (length fill-prefix))
|
|
|
1615 (fill-prefix "")
|
|
|
1616 (fill-column table-width)
|
|
|
1617 (start (point)))
|
|
|
1618 (w3-display-node (pop content))
|
|
|
1619 (indent-rigidly start (point) left)))
|
|
|
1620 (otherwise
|
|
|
1621 (delete-horizontal-space)
|
|
|
1622 (setq content (nth 2 (car content))))
|
|
|
1623 ))
|
|
|
1624 (if (= (length column-dimensions) 0) nil
|
|
|
1625 (insert fill-prefix)
|
|
|
1626 (setq i 0)
|
|
|
1627 (let (tflag lflag)
|
|
|
1628 (while (< i num-cols)
|
|
|
1629 (setq tflag (/= (aref prev-colspans i) 0))
|
|
116
|
1630 (w3-insert-terminal-char (w3-table-lookup-char lflag tflag t nil))
|
|
14
|
1631 (setq lflag t)
|
|
116
|
1632 (w3-insert-terminal-char
|
|
|
1633 (w3-table-lookup-char t nil t nil)
|
|
|
1634 (aref column-dimensions i))
|
|
14
|
1635 (setq i (1+ i)))
|
|
116
|
1636 (w3-insert-terminal-char
|
|
|
1637 (w3-table-lookup-char t t nil nil))
|
|
|
1638 (insert "\n")))
|
|
14
|
1639 )
|
|
|
1640 (pop w3-display-open-element-stack)))))
|
|
|
1641
|
|
|
1642
|
|
|
1643
|
|
|
1644 (defun w3-display-create-unique-id ()
|
|
|
1645 (let* ((date (current-time-string))
|
|
|
1646 (dateinfo (and date (timezone-parse-date date)))
|
|
|
1647 (timeinfo (and date (timezone-parse-time (aref dateinfo 3)))))
|
|
|
1648 (if (and dateinfo timeinfo)
|
|
|
1649 (concat (aref dateinfo 0) ; Year
|
|
|
1650 (aref dateinfo 1) ; Month
|
|
|
1651 (aref dateinfo 2) ; Day
|
|
|
1652 (aref timeinfo 0) ; Hour
|
|
|
1653 (aref timeinfo 1) ; Minute
|
|
|
1654 (aref timeinfo 2) ; Second
|
|
|
1655 )
|
|
|
1656 "HoplesSLYCoNfUSED")))
|
|
|
1657
|
|
82
|
1658 (defun w3-display-chop-into-table (node cols)
|
|
|
1659 ;; Chop the content of 'node' up into 'cols' columns suitable for inclusion
|
|
|
1660 ;; as the content of a table
|
|
|
1661 (let ((content (nth 2 node))
|
|
|
1662 (items nil)
|
|
|
1663 (rows nil))
|
|
|
1664 (setq cols (max cols 1))
|
|
|
1665 (while content
|
|
|
1666 (push (list 'td nil (list (pop content))) items)
|
|
|
1667 (if (= (length items) cols)
|
|
|
1668 (setq rows (cons (nreverse items) rows)
|
|
|
1669 items nil)))
|
|
|
1670 (if items ; Store any leftovers
|
|
|
1671 (setq rows (cons (nreverse items) rows)
|
|
|
1672 items nil))
|
|
|
1673 (while rows
|
|
|
1674 (push (list 'tr nil (pop rows)) items))
|
|
|
1675 items))
|
|
|
1676
|
|
118
|
1677 (defun w3-fix-color (color)
|
|
|
1678 (if (and color
|
|
|
1679 (string-match "^[0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]$" color))
|
|
|
1680 (concat "#" color)
|
|
|
1681 color))
|
|
|
1682
|
|
86
|
1683 (defun w3-display-normalize-form-info (args)
|
|
|
1684 (let* ((plist (alist-to-plist args))
|
|
|
1685 (type (intern (downcase
|
|
|
1686 (or (plist-get plist 'type) "text"))))
|
|
|
1687 (name (plist-get plist 'name))
|
|
|
1688 (value (or (plist-get plist 'value) ""))
|
|
|
1689 (size (if (plist-get plist 'size)
|
|
|
1690 (string-to-int (plist-get plist 'size))))
|
|
|
1691 (maxlength (if (plist-get plist 'maxlength)
|
|
|
1692 (string-to-int
|
|
|
1693 (plist-get plist 'maxlength))))
|
|
|
1694 (default value)
|
|
|
1695 (checked (assq 'checked args)))
|
|
|
1696 (if (memq type '(checkbox radio)) (setq default checked))
|
|
|
1697 (if (and (eq type 'checkbox) (string= value ""))
|
|
|
1698 (setq value "on"))
|
|
|
1699 (if (and (not (memq type '(submit reset button)))
|
|
|
1700 (not name))
|
|
|
1701 (setq name (symbol-name type)))
|
|
|
1702 (while (and name (string-match "[\r\n]+" name))
|
|
|
1703 (setq name (concat (substring name 0 (match-beginning 0))
|
|
|
1704 (substring name (match-end 0) nil))))
|
|
|
1705 (setq plist (plist-put plist 'type type)
|
|
|
1706 plist (plist-put plist 'name name)
|
|
|
1707 plist (plist-put plist 'value value)
|
|
|
1708 plist (plist-put plist 'size size)
|
|
|
1709 plist (plist-put plist 'default default)
|
|
|
1710 plist (plist-put plist 'internal-form-number w3-current-form-number)
|
|
|
1711 plist (plist-put plist 'action w3-display-form-id)
|
|
|
1712 plist (plist-put plist 'maxlength maxlength))
|
|
|
1713 plist))
|
|
|
1714
|
|
173
|
1715 (defun w3-resurrect-images ()
|
|
|
1716 )
|
|
|
1717
|
|
165
|
1718 (defun w3-resurrect-hyperlinks ()
|
|
|
1719 (let ((st (point-min))
|
|
|
1720 (inhibit-read-only t)
|
|
|
1721 info nd node face)
|
|
|
1722 (while st
|
|
|
1723 (if (setq info (get-text-property st 'w3-hyperlink-info))
|
|
|
1724 (progn
|
|
|
1725 (setq nd (or (next-single-property-change st 'w3-hyperlink-info)
|
|
|
1726 (point-max)))
|
|
|
1727 (apply 'widget-convert-text 'link st nd st nd info)))
|
|
|
1728 (setq st (next-single-property-change st 'w3-hyperlink-info)))))
|
|
|
1729
|
|
|
1730 (defun w3-display-convert-arglist (args)
|
|
|
1731 (let ((rval nil)
|
|
|
1732 (newsym nil)
|
|
|
1733 (cur nil))
|
|
|
1734 (while (setq cur (pop args))
|
|
|
1735 (setq newsym (intern (concat ":" (symbol-name (car cur))))
|
|
|
1736 rval (plist-put rval newsym (cdr cur))))
|
|
|
1737 rval))
|
|
|
1738
|
|
14
|
1739 (defun w3-display-node (node &optional nofaces)
|
|
|
1740 (let (
|
|
|
1741 (content-stack (list (list node)))
|
|
|
1742 (right-margin-stack (list fill-column))
|
|
|
1743 (left-margin-stack (list 0))
|
|
100
|
1744 (inhibit-read-only t)
|
|
102
|
1745 (widget-push-button-gui nil)
|
|
14
|
1746 node
|
|
|
1747 insert-before
|
|
|
1748 insert-after
|
|
|
1749 tag
|
|
|
1750 args
|
|
|
1751 content
|
|
|
1752 hyperlink-info
|
|
|
1753 break-style
|
|
|
1754 cur
|
|
|
1755 id
|
|
|
1756 class
|
|
108
|
1757 last-element
|
|
14
|
1758 )
|
|
|
1759 (while content-stack
|
|
|
1760 (setq content (pop content-stack))
|
|
|
1761 (pop w3-active-faces)
|
|
|
1762 (pop w3-active-voices)
|
|
100
|
1763 (w3-display-progress-meter)
|
|
108
|
1764 (setq last-element (pop w3-display-open-element-stack))
|
|
|
1765 (case (car last-element)
|
|
14
|
1766 ;; Any weird, post-display-of-content stuff for specific tags
|
|
|
1767 ;; goes here. Couldn't think of any better way to do this when we
|
|
|
1768 ;; are iterative. *sigh*
|
|
|
1769 (a
|
|
|
1770 (if (not hyperlink-info)
|
|
|
1771 nil
|
|
|
1772 (add-text-properties (car hyperlink-info) (point)
|
|
|
1773 (list
|
|
|
1774 'duplicable t
|
|
82
|
1775 'start-open t
|
|
|
1776 'end-open t
|
|
|
1777 'rear-nonsticky t
|
|
165
|
1778 'w3-hyperlink-info (cadr hyperlink-info))))
|
|
14
|
1779 (setq hyperlink-info nil))
|
|
|
1780 ((ol ul dl dir menu)
|
|
|
1781 (pop w3-display-list-stack))
|
|
108
|
1782 (label
|
|
|
1783 (if (and (markerp w3-display-label-marker)
|
|
|
1784 (marker-position w3-display-label-marker)
|
|
|
1785 (marker-buffer w3-display-label-marker))
|
|
|
1786 (push (cons (or (cdr-safe (assq 'for (cdr last-element)))
|
|
|
1787 (cdr-safe (assq 'id (cdr last-element)))
|
|
|
1788 "unknown")
|
|
|
1789 (buffer-substring w3-display-label-marker (point)))
|
|
|
1790 w3-form-labels)))
|
|
14
|
1791 (otherwise
|
|
|
1792 nil))
|
|
|
1793 (if (car insert-after)
|
|
|
1794 (w3-handle-string-content (car insert-after)))
|
|
|
1795 (pop insert-after)
|
|
|
1796 (w3-display-handle-end-break)
|
|
|
1797 (w3-pop-all-face-info)
|
|
|
1798 ;; Handle the element's content
|
|
|
1799 (while content
|
|
100
|
1800 (w3-display-progress-meter)
|
|
14
|
1801 (if (stringp (car content))
|
|
|
1802 (w3-handle-string-content (pop content))
|
|
|
1803 (setq node (pop content)
|
|
|
1804 tag (nth 0 node)
|
|
|
1805 args (nth 1 node)
|
|
|
1806 id (or (w3-get-attribute 'name)
|
|
|
1807 (w3-get-attribute 'id))
|
|
|
1808 )
|
|
|
1809 ;; This little bit of magic takes care of inline styles.
|
|
|
1810 ;; Evil Evil Evil, but it appears to work.
|
|
|
1811 (if (w3-get-attribute 'style)
|
|
|
1812 (let ((unique-id (or (w3-get-attribute 'id)
|
|
|
1813 (w3-display-create-unique-id)))
|
|
82
|
1814 (sheet "")
|
|
|
1815 (class (assq 'class args)))
|
|
14
|
1816 (setq sheet (format "%s.%s { %s }\n" tag unique-id
|
|
|
1817 (w3-get-attribute 'style)))
|
|
82
|
1818 (if class
|
|
|
1819 (setcdr class (cons unique-id (cdr class)))
|
|
|
1820 (setf (nth 1 node) (cons (cons 'class (list unique-id))
|
|
|
1821 (nth 1 node))))
|
|
|
1822 (setf (nth 1 node) (cons (cons 'id unique-id) (nth 1 node)))
|
|
|
1823 (w3-handle-style (list 'data sheet
|
|
118
|
1824 'notation "text/css"))))
|
|
14
|
1825 (setq w3-display-css-properties (css-get
|
|
82
|
1826 (nth 0 node)
|
|
|
1827 (nth 1 node)
|
|
14
|
1828 w3-current-stylesheet
|
|
|
1829 w3-display-open-element-stack))
|
|
|
1830 (push (w3-get-style-info 'display node) break-style)
|
|
|
1831 (push (w3-get-style-info 'insert-after node) insert-after)
|
|
|
1832 (setq insert-before (w3-get-style-info 'insert-before node))
|
|
|
1833 (w3-display-handle-break)
|
|
|
1834 (if (w3-node-visible-p)
|
|
|
1835 nil
|
|
|
1836 (setq insert-before nil
|
|
|
1837 tag '*invisible)
|
|
|
1838 (setcar insert-after nil))
|
|
|
1839 (if insert-before
|
|
|
1840 (w3-handle-string-content insert-before))
|
|
165
|
1841 (if nofaces
|
|
|
1842 nil
|
|
|
1843 (push (w3-face-for-element node) w3-active-faces)
|
|
|
1844 (push (w3-voice-for-element node) w3-active-voices))
|
|
14
|
1845 (setq insert-before nil)
|
|
|
1846 (if id
|
|
|
1847 (setq w3-id-positions (cons
|
|
|
1848 (cons (intern id)
|
|
|
1849 (set-marker (make-marker)
|
|
|
1850 (point-max)))
|
|
|
1851 w3-id-positions)))
|
|
|
1852 (case tag
|
|
|
1853 (a ; Hyperlinks
|
|
|
1854 (let* (
|
|
|
1855 (title (w3-get-attribute 'title))
|
|
|
1856 (name (or (w3-get-attribute 'id)
|
|
|
1857 (w3-get-attribute 'name)))
|
|
|
1858 (btdt nil)
|
|
|
1859 class
|
|
|
1860 (before nil)
|
|
|
1861 (after nil)
|
|
|
1862 (face nil)
|
|
|
1863 (voice nil)
|
|
165
|
1864 (st nil)
|
|
|
1865 (old-props w3-display-css-properties)
|
|
|
1866 (active-face nil)
|
|
|
1867 (munged (copy-list args)))
|
|
|
1868 (if (assq 'class munged)
|
|
|
1869 (push ":active" (cdr (assq 'class munged)))
|
|
|
1870 (setq munged (cons (cons 'class '(":active")) munged)))
|
|
|
1871 (setq w3-display-css-properties (css-get
|
|
|
1872 tag
|
|
|
1873 munged
|
|
|
1874 w3-current-stylesheet
|
|
|
1875 w3-display-open-element-stack))
|
|
|
1876 (setq active-face (w3-face-for-element (list tag munged nil)))
|
|
|
1877 (w3-pop-all-face-info)
|
|
|
1878 (setq w3-display-css-properties old-props)
|
|
108
|
1879 (if (w3-get-attribute 'href)
|
|
|
1880 (setq st (point)
|
|
|
1881 hyperlink-info (list
|
|
|
1882 st
|
|
165
|
1883 (append
|
|
|
1884 (list :args nil
|
|
108
|
1885 :value "" :tag ""
|
|
|
1886 :action 'w3-follow-hyperlink
|
|
165
|
1887 :button-face '(nil)
|
|
|
1888 :active-face active-face
|
|
108
|
1889 :from (set-marker
|
|
|
1890 (make-marker) st)
|
|
|
1891 :help-echo 'w3-widget-echo
|
|
|
1892 :emacspeak-help 'w3-widget-echo
|
|
|
1893 )
|
|
165
|
1894 (w3-display-convert-arglist args)))))
|
|
14
|
1895 (w3-handle-content node)
|
|
|
1896 )
|
|
|
1897 )
|
|
82
|
1898 ((ol ul dl menu)
|
|
108
|
1899 (push (if (w3-get-attribute 'seqnum)
|
|
|
1900 (1- (string-to-int (w3-get-attribute 'seqnum)))
|
|
|
1901 0) w3-display-list-stack)
|
|
82
|
1902 (w3-handle-content node))
|
|
|
1903 (dir
|
|
14
|
1904 (push 0 w3-display-list-stack)
|
|
82
|
1905 (setq node
|
|
|
1906 (list tag args
|
|
|
1907 (list
|
|
|
1908 (list 'table nil
|
|
|
1909 (w3-display-chop-into-table node 3)))))
|
|
|
1910 (w3-handle-content node))
|
|
|
1911 (multicol
|
|
|
1912 (setq node (list tag args
|
|
|
1913 (list
|
|
|
1914 (list 'table nil
|
|
|
1915 (w3-display-chop-into-table node 2)))))
|
|
14
|
1916 (w3-handle-content node))
|
|
|
1917 (img ; inlined image
|
|
|
1918 (w3-handle-image)
|
|
|
1919 (w3-handle-empty-tag))
|
|
100
|
1920 (frameset
|
|
|
1921 (if w3-display-frames
|
|
185
|
1922 (let ((frames (nth 2 node))
|
|
|
1923 (frameset-cardinal 0)
|
|
|
1924 (cols (cdr-safe (assq 'cols args))))
|
|
|
1925 (while (and frames (memq (car (car frames)) '(frame frameset)))
|
|
|
1926 (setq frameset-cardinal (1+ frameset-cardinal)
|
|
|
1927 frames (cdr frames)))
|
|
114
|
1928 (push (list 'frameset
|
|
185
|
1929 frameset-cardinal
|
|
|
1930 (if (and cols (not (string-equal cols "*")))
|
|
|
1931 (assq 'cols args)
|
|
|
1932 (assq 'rows args)))
|
|
114
|
1933 w3-frameset-structure)
|
|
102
|
1934 (w3-handle-content node))
|
|
110
|
1935 (w3-handle-content node)))
|
|
100
|
1936 (frame
|
|
102
|
1937 (if w3-display-frames
|
|
|
1938 (let* ((href (or (w3-get-attribute 'src)
|
|
|
1939 (w3-get-attribute 'href)))
|
|
|
1940 (name (or (w3-get-attribute 'name)
|
|
|
1941 (w3-get-attribute 'title)
|
|
|
1942 (w3-get-attribute 'alt)
|
|
|
1943 "Unknown frame name")))
|
|
114
|
1944 (push (list 'frame name href) w3-frameset-structure)
|
|
102
|
1945 (w3-handle-content
|
|
|
1946 (list tag args
|
|
|
1947 (list
|
|
|
1948 (list 'p nil
|
|
|
1949 (list
|
|
|
1950 (list 'a
|
|
|
1951 (cons (cons 'href href)
|
|
|
1952 args)
|
|
114
|
1953 (list "Fetch frame: " name))))))))
|
|
110
|
1954 (w3-handle-empty-tag)))
|
|
100
|
1955 (noframes
|
|
|
1956 (if w3-display-frames
|
|
|
1957 (w3-handle-empty-tag)
|
|
|
1958 (w3-handle-content node)))
|
|
108
|
1959 (applet ; Wow, Java
|
|
|
1960 (w3-handle-content node)
|
|
|
1961 )
|
|
14
|
1962 (script ; Scripts
|
|
|
1963 (w3-handle-empty-tag))
|
|
|
1964 ((embed object) ; Embedded images/content
|
|
|
1965 (w3-handle-content node)
|
|
|
1966 )
|
|
|
1967 (hr ; Cause line break & insert rule
|
|
|
1968 (let* ((perc (or (w3-get-attribute 'width)
|
|
|
1969 (w3-get-style-info 'width node)
|
|
|
1970 "100%"))
|
|
|
1971 (width nil))
|
|
165
|
1972 (if (stringp perc)
|
|
|
1973 (setq perc (/ (min (string-to-int perc) 100) 100.0)
|
|
|
1974 width (truncate (* fill-column perc)))
|
|
|
1975 (setq width perc))
|
|
116
|
1976 (w3-insert-terminal-char (w3-horizontal-rule-char) width)
|
|
|
1977 (w3-handle-empty-tag)))
|
|
14
|
1978 (map ; Client side imagemaps
|
|
|
1979 (let ((name (or (w3-get-attribute 'name)
|
|
|
1980 (w3-get-attribute 'id)
|
|
|
1981 "unnamed"))
|
|
|
1982 (areas
|
|
|
1983 (mapcar
|
|
|
1984 (function
|
|
|
1985 (lambda (node)
|
|
|
1986 (let* ((args (nth 1 node))
|
|
|
1987 (type (downcase (or
|
|
|
1988 (w3-get-attribute 'shape)
|
|
|
1989 "rect")))
|
|
|
1990 (coords (w3-decode-area-coords
|
|
|
1991 (or (cdr-safe
|
|
|
1992 (assq 'coords args)) "")))
|
|
|
1993 (alt (w3-get-attribute 'alt))
|
|
|
1994 (href (if (assq 'nohref args)
|
|
|
1995 t
|
|
|
1996 (or (w3-get-attribute 'src)
|
|
|
1997 (w3-get-attribute 'href))))
|
|
|
1998 )
|
|
|
1999 (vector type coords href alt))
|
|
|
2000 )
|
|
|
2001 )
|
|
|
2002 (nth 2 node))))
|
|
|
2003 (setq w3-imagemaps (cons (cons name areas) w3-imagemaps)))
|
|
|
2004 (w3-handle-empty-tag)
|
|
|
2005 )
|
|
82
|
2006 (note
|
|
|
2007 ;; Ewwwwhhh. Looks gross, but it works. This converts a
|
|
|
2008 ;; <note> into a two-cell table, so that things look all
|
|
|
2009 ;; pretty.
|
|
|
2010 (setq node
|
|
|
2011 (list 'note nil
|
|
|
2012 (list
|
|
|
2013 (list 'table nil
|
|
|
2014 (list
|
|
|
2015 (list 'tr nil
|
|
|
2016 (list
|
|
|
2017 (list 'td (list 'align 'right)
|
|
|
2018 (list
|
|
|
2019 (concat
|
|
|
2020 (or (w3-get-attribute 'role)
|
|
|
2021 "CAUTION") ":")))
|
|
|
2022 (list 'td nil
|
|
|
2023 (nth 2 node)))))))))
|
|
|
2024 (w3-handle-content node)
|
|
|
2025 )
|
|
|
2026 (table
|
|
14
|
2027 (w3-display-table node)
|
|
|
2028 (setq w3-last-fill-pos (point))
|
|
|
2029 (w3-handle-empty-tag)
|
|
|
2030 )
|
|
|
2031 (isindex
|
|
|
2032 (let ((prompt (or (w3-get-attribute 'prompt)
|
|
|
2033 "Search on (+ separates keywords): "))
|
|
|
2034 action node)
|
|
|
2035 (setq action (or (w3-get-attribute 'src)
|
|
|
2036 (w3-get-attribute 'href)
|
|
|
2037 (url-view-url t)))
|
|
|
2038 (if (and prompt (string-match "[^: \t-]+$" prompt))
|
|
|
2039 (setq prompt (concat prompt ": ")))
|
|
|
2040 (setq node
|
|
|
2041 (list 'isindex nil
|
|
|
2042 (list
|
|
|
2043 (list 'hr nil nil)
|
|
|
2044 (list 'form
|
|
|
2045 (list (cons 'action action)
|
|
|
2046 (cons 'enctype
|
|
|
2047 "application/x-w3-isindex")
|
|
|
2048 (cons 'method "get"))
|
|
|
2049 (list
|
|
|
2050 prompt
|
|
|
2051 (list 'input
|
|
|
2052 (list (cons 'type "text")
|
|
|
2053 (cons 'name "isindex"))))))))
|
|
|
2054 (w3-handle-content node)
|
|
|
2055 (setq w3-current-isindex (cons action prompt)))
|
|
|
2056 )
|
|
116
|
2057 ((html body)
|
|
|
2058 (let ((fore (car (delq nil (copy-list w3-face-color))))
|
|
|
2059 (back (car (delq nil (copy-list w3-face-background-color))))
|
|
165
|
2060 (pixm (car (delq nil (copy-list w3-face-background-image))))
|
|
118
|
2061 (alink (w3-get-attribute 'alink))
|
|
|
2062 (vlink (w3-get-attribute 'vlink))
|
|
|
2063 (link (w3-get-attribute 'link))
|
|
|
2064 (sheet "")
|
|
116
|
2065 )
|
|
118
|
2066 (if link
|
|
|
2067 (setq sheet (format "%sa:link { color: %s }\n" sheet
|
|
|
2068 (w3-fix-color link))))
|
|
|
2069 (if vlink
|
|
|
2070 (setq sheet (format "%sa:visited { color: %s }\n" sheet
|
|
|
2071 (w3-fix-color vlink))))
|
|
|
2072 (if alink
|
|
|
2073 (setq sheet (format "%sa:active { color: %s }\n" sheet
|
|
|
2074 (w3-fix-color alink))))
|
|
165
|
2075 (if w3-user-colors-take-precedence
|
|
|
2076 nil
|
|
|
2077 (if (/= (length sheet) 0)
|
|
|
2078 (w3-handle-style (list 'data sheet
|
|
|
2079 'notation "text/css")))
|
|
|
2080 (if (and (w3-get-attribute 'background)
|
|
|
2081 (not pixm))
|
|
|
2082 (progn
|
|
|
2083 (setq pixm (w3-get-attribute 'background))
|
|
|
2084 (setf (car w3-face-background-image) pixm)))
|
|
|
2085 (if (and (w3-get-attribute 'text) (not fore))
|
|
|
2086 (progn
|
|
|
2087 (setq fore (w3-fix-color (w3-get-attribute 'text)))
|
|
|
2088 (setf (car w3-face-color) fore)))
|
|
|
2089 (if (not font-running-xemacs)
|
|
|
2090 (setq w3-display-background-properties (cons fore back))
|
|
|
2091 (if pixm
|
|
|
2092 (w3-maybe-start-background-image-download pixm 'default))
|
|
|
2093 (if fore
|
|
|
2094 (font-set-face-foreground 'default fore (current-buffer)))
|
|
|
2095 (if back
|
|
|
2096 (font-set-face-background 'default back (current-buffer)))))
|
|
116
|
2097 (w3-handle-content node)))
|
|
14
|
2098 (*document
|
|
|
2099 (let ((info (mapcar (lambda (x) (cons x (symbol-value x)))
|
|
|
2100 w3-persistent-variables)))
|
|
82
|
2101 (if (not w3-display-same-buffer)
|
|
|
2102 (set-buffer (generate-new-buffer "Untitled")))
|
|
14
|
2103 (setq w3-current-form-number 0
|
|
|
2104 w3-display-open-element-stack nil
|
|
102
|
2105 w3-last-fill-pos (point-min))
|
|
|
2106 (setcar right-margin-stack
|
|
|
2107 (min (- (or w3-strict-width (window-width))
|
|
|
2108 w3-right-margin)
|
|
|
2109 (or w3-maximum-line-length
|
|
|
2110 (window-width))))
|
|
116
|
2111 (condition-case nil
|
|
|
2112 (switch-to-buffer (current-buffer))
|
|
|
2113 (error (message "W3 buffer %s is being drawn." (buffer-name (current-buffer)))))
|
|
|
2114
|
|
14
|
2115 (buffer-disable-undo (current-buffer))
|
|
|
2116 (mapcar (function (lambda (x) (set (car x) (cdr x)))) info)
|
|
|
2117 ;; ACK! We don't like filladapt mode!
|
|
|
2118 (set (make-local-variable 'filladapt-mode) nil)
|
|
|
2119 (set (make-local-variable 'adaptive-fill-mode) nil)
|
|
82
|
2120 (set (make-local-variable 'voice-lock-mode) t)
|
|
165
|
2121 (set (make-local-variable 'cur-viewing-pos) (point-min))
|
|
14
|
2122 (setq w3-current-stylesheet (css-copy-stylesheet
|
|
|
2123 w3-user-stylesheet)
|
|
|
2124 w3-last-fill-pos (point)
|
|
|
2125 fill-prefix "")
|
|
118
|
2126 )
|
|
14
|
2127 (w3-handle-content node)
|
|
|
2128 )
|
|
|
2129 (*invisible
|
|
|
2130 (w3-handle-empty-tag))
|
|
|
2131 (meta
|
|
|
2132 (let* ((equiv (cdr-safe (assq 'http-equiv args)))
|
|
|
2133 (value (w3-get-attribute 'content))
|
|
|
2134 (name (w3-get-attribute 'name))
|
|
|
2135 (node (and equiv (assoc (setq equiv (downcase equiv))
|
|
|
2136 url-current-mime-headers))))
|
|
|
2137 (if equiv
|
|
|
2138 (setq url-current-mime-headers (cons
|
|
|
2139 (cons equiv value)
|
|
|
2140 url-current-mime-headers)))
|
|
|
2141 (if name
|
|
|
2142 (setq w3-current-metainfo (cons
|
|
|
2143 (cons name value)
|
|
|
2144 w3-current-metainfo)))
|
|
|
2145
|
|
|
2146 ;; Special-case the Set-Cookie header
|
|
|
2147 (if (and equiv (string= (downcase equiv) "set-cookie"))
|
|
|
2148 (url-cookie-handle-set-cookie value))
|
|
|
2149 ;; Special-case the refresh header
|
|
|
2150 (if (and equiv (string= (downcase equiv) "refresh"))
|
|
|
2151 (url-handle-refresh-header value)))
|
|
|
2152 (w3-handle-empty-tag)
|
|
|
2153 )
|
|
|
2154 (link
|
|
|
2155 ;; This doesn't handle blank-separated values per the RFC.
|
|
|
2156 (w3-parse-link args)
|
|
|
2157 (w3-handle-empty-tag))
|
|
|
2158 (title
|
|
|
2159 (let ((potential-title "")
|
|
|
2160 (content (nth 2 node)))
|
|
|
2161 (while content
|
|
|
2162 (setq potential-title (concat potential-title (car content))
|
|
|
2163 content (cdr content)))
|
|
|
2164 (setq potential-title (w3-normalize-spaces potential-title))
|
|
82
|
2165 (if (or w3-display-same-buffer
|
|
|
2166 (string-match "^[ \t]*$" potential-title))
|
|
14
|
2167 nil
|
|
|
2168 (rename-buffer (generate-new-buffer-name
|
|
|
2169 (w3-fix-spaces potential-title)))))
|
|
|
2170 (w3-handle-empty-tag))
|
|
102
|
2171 (base
|
|
|
2172 (setq w3-base-target (cdr-safe (assq 'target args)))
|
|
|
2173 (w3-handle-content node))
|
|
14
|
2174 (form
|
|
|
2175 (setq w3-current-form-number (1+ w3-current-form-number))
|
|
|
2176 (let* (
|
|
|
2177 (action (w3-get-attribute 'action))
|
|
|
2178 (url nil))
|
|
|
2179 (if (not action)
|
|
|
2180 (setq args (cons (cons 'action (url-view-url t)) args)))
|
|
82
|
2181 (setq w3-display-form-id (cons
|
|
|
2182 (cons 'form-number
|
|
|
2183 w3-current-form-number)
|
|
|
2184 args))
|
|
14
|
2185 (w3-handle-content node)))
|
|
116
|
2186 (keygen
|
|
|
2187 (w3-form-add-element
|
|
|
2188 (w3-display-normalize-form-info
|
|
|
2189 (cons '(type . "keygen")
|
|
|
2190 args))
|
|
|
2191 w3-active-faces)
|
|
|
2192 (w3-handle-empty-tag))
|
|
14
|
2193 (input
|
|
86
|
2194 (w3-form-add-element
|
|
|
2195 (w3-display-normalize-form-info args)
|
|
98
|
2196 w3-active-faces)
|
|
14
|
2197 (w3-handle-empty-tag)
|
|
|
2198 )
|
|
|
2199 (select
|
|
86
|
2200 (let* ((plist (w3-display-normalize-form-info args))
|
|
82
|
2201 (tmp nil)
|
|
|
2202 (multiple (assq 'multiple args))
|
|
86
|
2203 (value nil)
|
|
|
2204 (name (plist-get plist 'name))
|
|
|
2205 (options (mapcar
|
|
|
2206 (function
|
|
|
2207 (lambda (n)
|
|
|
2208 (setq tmp (w3-normalize-spaces
|
|
|
2209 (apply 'concat (nth 2 n)))
|
|
114
|
2210 tmp (vector tmp
|
|
|
2211 (or
|
|
|
2212 (cdr-safe
|
|
|
2213 (assq 'value (nth 1 n)))
|
|
|
2214 tmp)
|
|
|
2215 (assq 'selected (nth 1 n))))
|
|
86
|
2216 (if (assq 'selected (nth 1 n))
|
|
114
|
2217 (setq value (aref tmp 0)))
|
|
86
|
2218 tmp))
|
|
|
2219 (nth 2 node))))
|
|
82
|
2220 (if (not value)
|
|
165
|
2221 (setq value (and options (aref (car options) 0))))
|
|
86
|
2222 (setq plist (plist-put plist 'value value))
|
|
82
|
2223 (if multiple
|
|
|
2224 (progn
|
|
|
2225 (setq options
|
|
|
2226 (mapcar
|
|
|
2227 (function
|
|
|
2228 (lambda (opt)
|
|
|
2229 (list 'div nil
|
|
|
2230 (list
|
|
|
2231 (list 'input
|
|
|
2232 (list (cons 'name name)
|
|
|
2233 (cons 'type "checkbox")
|
|
114
|
2234 (cons (if (aref opt 2)
|
|
|
2235 'checked
|
|
|
2236 '__bogus__) "yes")
|
|
|
2237 (cons 'value (aref opt 1))))
|
|
|
2238 " " (aref opt 0) (list 'br nil nil)))))
|
|
82
|
2239 options))
|
|
|
2240 (setq node (list 'p nil options))
|
|
|
2241 (w3-handle-content node))
|
|
114
|
2242 (setq options (mapcar (function
|
|
|
2243 (lambda (x)
|
|
|
2244 (cons (aref x 0) (aref x 1))))
|
|
|
2245 options))
|
|
86
|
2246 (setq plist (plist-put plist 'type 'option)
|
|
|
2247 plist (plist-put plist 'options options))
|
|
98
|
2248 (w3-form-add-element plist w3-active-faces)
|
|
14
|
2249 ;; This should really not be necessary, but some versions
|
|
|
2250 ;; of the widget library leave point _BEFORE_ the menu
|
|
|
2251 ;; widget instead of after.
|
|
|
2252 (goto-char (point-max))
|
|
82
|
2253 (w3-handle-empty-tag))))
|
|
14
|
2254 (textarea
|
|
86
|
2255 (let* ((plist (w3-display-normalize-form-info args))
|
|
116
|
2256 (value (apply 'concat (nth 2 node))))
|
|
86
|
2257 (setq plist (plist-put plist 'type 'multiline)
|
|
|
2258 plist (plist-put plist 'value value))
|
|
98
|
2259 (w3-form-add-element plist w3-active-faces))
|
|
14
|
2260 (w3-handle-empty-tag)
|
|
|
2261 )
|
|
|
2262 (style
|
|
82
|
2263 (w3-handle-style (alist-to-plist
|
|
|
2264 (cons (cons 'data (apply 'concat (nth 2 node)))
|
|
|
2265 (nth 1 node))))
|
|
14
|
2266 (w3-handle-empty-tag))
|
|
108
|
2267 (label
|
|
|
2268 (if (not (markerp w3-display-label-marker))
|
|
|
2269 (setq w3-display-label-marker (make-marker)))
|
|
|
2270 (set-marker w3-display-label-marker (point))
|
|
|
2271 (w3-handle-content node))
|
|
88
|
2272 ;; Emacs-W3 stuff that cannot be expressed in a stylesheet
|
|
|
2273 (pinhead
|
|
|
2274 ;; This check is so that we don't screw up table auto-layout
|
|
|
2275 ;; by changing our text midway through the parse/layout/display
|
|
|
2276 ;; steps.
|
|
|
2277 (if (nth 2 node)
|
|
|
2278 nil
|
|
|
2279 (setcar (cddr node)
|
|
|
2280 (list
|
|
|
2281 (if (fboundp 'yow)
|
|
|
2282 (yow)
|
|
|
2283 "AIEEEEE! I am having an UNDULATING EXPERIENCE!"))))
|
|
|
2284 (w3-handle-content node))
|
|
|
2285 (flame
|
|
|
2286 (if (nth 2 node)
|
|
|
2287 nil
|
|
|
2288 (setcar
|
|
|
2289 (cddr node)
|
|
|
2290 (list
|
|
|
2291 (condition-case ()
|
|
|
2292 (concat
|
|
|
2293 (sentence-ify
|
|
|
2294 (string-ify
|
|
|
2295 (append-suffixes-hack (flatten (*flame))))))
|
|
|
2296 (error
|
|
|
2297 "You know, everything is really a graphics editor.")))))
|
|
|
2298 (w3-handle-content node))
|
|
|
2299 (cookie
|
|
|
2300 (if (nth 2 node)
|
|
|
2301 nil
|
|
|
2302 (setcar
|
|
|
2303 (cddr node)
|
|
|
2304 (list
|
|
|
2305 (w3-display-get-cookie args))))
|
|
|
2306 (w3-handle-content node))
|
|
|
2307 ;; Generic formatting - all things that can be fully specified
|
|
|
2308 ;; by a CSS stylesheet.
|
|
14
|
2309 (otherwise
|
|
|
2310 (w3-handle-content node))
|
|
|
2311 ) ; case tag
|
|
|
2312 ) ; stringp content
|
|
|
2313 ) ; while content
|
|
|
2314 ) ; while content-stack
|
|
|
2315 )
|
|
|
2316 )
|
|
|
2317
|
|
|
2318 (defun w3-draw-tree (tree)
|
|
|
2319 ;; The main entry point - wow complicated
|
|
|
2320 (setq w3-current-stylesheet w3-user-stylesheet)
|
|
|
2321 (while tree
|
|
|
2322 (w3-display-node (car tree))
|
|
|
2323 (setq tree (cdr tree)))
|
|
|
2324 (w3-display-fix-widgets)
|
|
173
|
2325 (let ((inhibit-read-only t))
|
|
|
2326 (put-text-property (point-min) (point-max) 'read-only t)
|
|
|
2327 (w3-resurrect-images)
|
|
|
2328 (w3-resurrect-hyperlinks)
|
|
|
2329 (w3-form-resurrect-widgets)))
|
|
14
|
2330
|
|
|
2331 (defun time-display (&optional tree)
|
|
|
2332 ;; Return the # of seconds it took to draw 'tree'
|
|
|
2333 (let ((st (nth 1 (current-time)))
|
|
|
2334 (nd nil))
|
|
|
2335 (w3-draw-tree (or tree w3-last-parse-tree))
|
|
|
2336 (setq nd (nth 1 (current-time)))
|
|
|
2337 (- nd st)))
|
|
|
2338
|
|
|
2339
|
|
98
|
2340 (defun w3-fixup-eol-faces ()
|
|
|
2341 ;; Remove 'face property at end of lines - underlining screws up stuff
|
|
116
|
2342 ;; also remove 'mouse-face property at the beginning and end of lines
|
|
98
|
2343 (let ((inhibit-read-only t))
|
|
|
2344 (save-excursion
|
|
|
2345 (goto-char (point-min))
|
|
118
|
2346 (while (re-search-forward "[ \t]*\n[ \t]*" nil t)
|
|
116
|
2347 (remove-text-properties (match-beginning 0) (match-end 0)
|
|
|
2348 '(face nil mouse-face nil) nil)))))
|
|
98
|
2349
|
|
82
|
2350 (defsubst w3-finish-drawing ()
|
|
98
|
2351 (let (url glyph widget)
|
|
|
2352 (while w3-image-widgets-waiting
|
|
|
2353 (setq widget (car w3-image-widgets-waiting)
|
|
|
2354 w3-image-widgets-waiting (cdr w3-image-widgets-waiting)
|
|
165
|
2355 url (widget-get widget :src)
|
|
98
|
2356 glyph (cdr-safe (assoc url w3-graphics-list)))
|
|
|
2357 (condition-case nil
|
|
|
2358 (widget-value-set widget glyph)
|
|
|
2359 (error nil))))
|
|
102
|
2360 (if (and url-current-object (url-target url-current-object))
|
|
|
2361 (progn
|
|
|
2362 (push-mark (point) t)
|
|
|
2363 (w3-find-specific-link (url-target url-current-object)))
|
|
|
2364 (goto-char (point-min)))
|
|
98
|
2365 (and (not w3-running-xemacs)
|
|
|
2366 (not (eq (device-type) 'tty))
|
|
|
2367 (w3-fixup-eol-faces))
|
|
110
|
2368 (message "Drawing... done"))
|
|
82
|
2369
|
|
|
2370 (defun w3-region (st nd)
|
|
|
2371 (if (not w3-setup-done) (w3-do-setup))
|
|
|
2372 (let* ((source (buffer-substring st nd))
|
|
108
|
2373 (w3-display-same-buffer t)
|
|
82
|
2374 (parse nil))
|
|
98
|
2375 (save-window-excursion
|
|
|
2376 (save-excursion
|
|
|
2377 (set-buffer (get-buffer-create " *w3-region*"))
|
|
|
2378 (erase-buffer)
|
|
|
2379 (insert source)
|
|
|
2380 (setq parse (w3-parse-buffer (current-buffer))))
|
|
|
2381 (narrow-to-region st nd)
|
|
|
2382 (delete-region (point-min) (point-max))
|
|
|
2383 (w3-draw-tree parse)
|
|
|
2384 (w3-finish-drawing)
|
|
|
2385 (widen))))
|
|
82
|
2386
|
|
|
2387 (defun w3-refresh-buffer ()
|
|
|
2388 (interactive)
|
|
|
2389 (let ((parse w3-current-parse)
|
|
|
2390 (inhibit-read-only t)
|
|
|
2391 (w3-display-same-buffer t))
|
|
|
2392 (if (not parse)
|
|
|
2393 (error "Could not find the parse tree for this buffer. EEEEK!"))
|
|
|
2394 (erase-buffer)
|
|
|
2395 (w3-draw-tree parse)
|
|
|
2396 (w3-finish-drawing)
|
|
|
2397 (w3-mode)
|
|
|
2398 (set-buffer-modified-p nil)))
|
|
|
2399
|
|
14
|
2400 (defun w3-prepare-buffer (&rest args)
|
|
|
2401 ;; The text/html viewer - does all the drawing and displaying of the buffer
|
|
|
2402 ;; that is necessary to go from raw HTML to a good presentation.
|
|
|
2403 (let* ((source (buffer-string))
|
|
|
2404 (source-buf (current-buffer))
|
|
|
2405 (parse (w3-parse-buffer source-buf)))
|
|
|
2406 (set-buffer-modified-p nil)
|
|
|
2407 (w3-draw-tree parse)
|
|
|
2408 (kill-buffer source-buf)
|
|
|
2409 (set-buffer-modified-p nil)
|
|
|
2410 (setq w3-current-source source
|
|
|
2411 w3-current-parse parse)
|
|
82
|
2412 (w3-finish-drawing)
|
|
14
|
2413 (w3-mode)
|
|
|
2414 (set-buffer-modified-p nil)
|
|
|
2415 (if url-keep-history
|
|
|
2416 (let ((url (url-view-url t)))
|
|
|
2417 (if (not url-history-list)
|
|
|
2418 (setq url-history-list (make-hash-table :size 131 :test 'equal)))
|
|
|
2419 (cl-puthash url (buffer-name) url-history-list)
|
|
|
2420 (if (fboundp 'w3-shuffle-history-menu)
|
|
|
2421 (w3-shuffle-history-menu)))))
|
|
114
|
2422 (w3-maybe-fetch-frames))
|
|
|
2423
|
|
|
2424 (defun w3-maybe-fetch-frames ()
|
|
|
2425 (if w3-frameset-structure
|
|
|
2426 (cond ((or (eq w3-display-frames t)
|
|
|
2427 (and (eq w3-display-frames 'ask)
|
|
|
2428 (y-or-n-p "Fetch frames? ")))
|
|
|
2429 (w3-frames)
|
|
|
2430 t))))
|
|
14
|
2431
|
|
102
|
2432 (defun w3-frames (&optional new-frame)
|
|
|
2433 "Set up and fetch W3 frames. With optional prefix, do so in a new frame."
|
|
|
2434 (interactive "P")
|
|
114
|
2435 (if (not w3-display-frames)
|
|
|
2436 (let ((w3-display-frames t))
|
|
|
2437 (w3-refresh-buffer)))
|
|
102
|
2438 (let* ((old-asynch url-be-asynchronous)
|
|
114
|
2439 (structure (reverse w3-frameset-structure)))
|
|
102
|
2440 (if new-frame
|
|
118
|
2441 (select-frame (make-frame)))
|
|
102
|
2442 (setq-default url-be-asynchronous nil)
|
|
|
2443 ;; set up frames
|
|
114
|
2444 (while structure
|
|
|
2445 (if (eq (car (car structure)) 'frameset)
|
|
185
|
2446 (setq structure (w3-display-frameset structure))
|
|
114
|
2447 (pop structure)))
|
|
102
|
2448 ;; compute target window distances
|
|
|
2449 (let ((origin-buffer (current-buffer))
|
|
|
2450 (stop nil))
|
|
|
2451 (while (not stop)
|
|
|
2452 (or w3-target-window-distances
|
|
|
2453 (setq w3-target-window-distances
|
|
|
2454 (w3-compute-target-window-distances)))
|
|
|
2455 (other-window 1)
|
|
|
2456 (if (eq (current-buffer) origin-buffer)
|
|
|
2457 (setq stop t))))
|
|
|
2458 (setq-default url-be-asynchronous old-asynch)))
|
|
|
2459
|
|
185
|
2460 (defun w3-display-frameset (frameset-structure)
|
|
|
2461 (let* ((structure frameset-structure)
|
|
|
2462 (frameset-cardinal (nth 1 (car structure)))
|
|
|
2463 (current-dims (cdr (cdr (car structure))))
|
|
|
2464 (cols (cdr-safe (assq 'cols current-dims)))
|
|
|
2465 (rows (cdr-safe (assq 'rows current-dims)))
|
|
|
2466 (char-width (if (> (frame-char-width) 1)
|
|
|
2467 (frame-char-width)
|
|
|
2468 w3-tty-char-width))
|
|
|
2469 (char-height (if (> (frame-char-height) 1)
|
|
|
2470 (frame-char-height)
|
|
|
2471 w3-tty-char-height)))
|
|
|
2472 (pop structure)
|
|
|
2473 ;; columns ?
|
|
|
2474 (if (and cols (not (string-equal cols "*")))
|
|
|
2475 (setq cols (w3-decode-frameset-dimensions
|
|
|
2476 cols (window-width) window-min-width char-width))
|
|
|
2477 ;; rows ?
|
|
|
2478 (if (and rows (not (string-equal rows "*")))
|
|
|
2479 (setq rows (w3-decode-frameset-dimensions
|
|
|
2480 rows (window-height) window-min-height char-height))
|
|
|
2481 ;; default: columns of equal width
|
|
|
2482 (let ((fwidth (/ (window-width) frameset-cardinal)))
|
|
|
2483 (while (> frameset-cardinal 0)
|
|
|
2484 (push fwidth cols)
|
|
|
2485 (setq frameset-cardinal (1- frameset-cardinal))))))
|
|
|
2486 (while (> frameset-cardinal 0)
|
|
|
2487 (cond ((cdr cols)
|
|
|
2488 (split-window-horizontally (car cols))
|
|
|
2489 (pop cols))
|
|
|
2490 ((cdr rows)
|
|
|
2491 (split-window-vertically (car rows))
|
|
|
2492 (pop rows)))
|
|
|
2493 (cond ((eq (car (car structure)) 'frame)
|
|
|
2494 (let ((href (nth 2 (car structure)))
|
|
|
2495 (name (nth 1 (car structure)))
|
|
|
2496 (url-working-buffer url-default-working-buffer) ; in case url-multiple-p is t
|
|
|
2497 (w3-notify 'semibully))
|
|
|
2498 (pop structure)
|
|
|
2499 (w3-fetch href)
|
|
|
2500 (setq w3-frame-name name
|
|
|
2501 w3-target-window-distances nil)
|
|
|
2502 (other-window 1)))
|
|
|
2503 ((eq (car (car structure)) 'frameset)
|
|
|
2504 (setq structure (w3-display-frameset structure))))
|
|
|
2505 (setq frameset-cardinal (1- frameset-cardinal)))
|
|
|
2506 structure))
|
|
|
2507
|
|
102
|
2508 (defun w3-compute-target-window-distances ()
|
|
|
2509 "Compute an alist of target names and window distances"
|
|
|
2510 (let ((origin-buffer (current-buffer))
|
|
|
2511 (distance 0)
|
|
|
2512 (stop nil)
|
|
|
2513 (window-distances nil))
|
|
|
2514 (while (not stop)
|
|
|
2515 (if w3-frame-name
|
|
|
2516 (push (cons (intern (downcase w3-frame-name)) distance)
|
|
|
2517 window-distances))
|
|
|
2518 (other-window 1)
|
|
|
2519 (setq distance (1+ distance))
|
|
|
2520 (if (eq (current-buffer) origin-buffer)
|
|
|
2521 (setq stop t)))
|
|
|
2522 window-distances))
|
|
|
2523
|
|
114
|
2524 (if (not (fboundp 'frame-char-height))
|
|
|
2525 (defun frame-char-height (&optional frame)
|
|
|
2526 "Height in pixels of a line in the font in frame FRAME.
|
|
|
2527 If FRAME is omitted, the selected frame is used.
|
|
|
2528 For a terminal frame, the value is always 1."
|
|
|
2529 (font-height (face-font 'default frame))))
|
|
|
2530
|
|
|
2531 (if (not (fboundp 'frame-char-width))
|
|
|
2532 (defun frame-char-width (&optional frame)
|
|
|
2533 "Width in pixels of characters in the font in frame FRAME.
|
|
|
2534 If FRAME is omitted, the selected frame is used.
|
|
|
2535 For a terminal screen, the value is always 1."
|
|
|
2536 (font-width (face-font 'default frame))))
|
|
|
2537
|
|
185
|
2538 (defun w3-decode-frameset-dimensions (dims available-dimension min-dim pixel-dim)
|
|
102
|
2539 "Returns numbers of lines or columns in Emacs, computed from specified frameset dimensions"
|
|
|
2540 (let ((dimensions nil))
|
|
|
2541 (if dims
|
|
|
2542 (let ((nb-stars 0)
|
|
|
2543 (remaining-available-dimension available-dimension))
|
|
|
2544 (while (string-match "\\(\\*\\|[0-9]+%?\\)" dims)
|
|
|
2545 (let ((match (substring dims (match-beginning 1) (match-end 1))))
|
|
|
2546 (setq dims (substring dims (match-end 1)))
|
|
|
2547 (cond ((string-match "\\*" match)
|
|
|
2548 ;; * : divide rest equally
|
|
|
2549 (push '* dimensions)
|
|
|
2550 (setq nb-stars (1+ nb-stars)))
|
|
|
2551 (t
|
|
|
2552 (cond ((string-match "\\([0-9]+\\)%" match)
|
|
|
2553 ;; percentage of available height
|
|
|
2554 (push (/ (* (car (read-from-string (substring match 0 -1)))
|
|
|
2555 available-dimension)
|
|
|
2556 100)
|
|
|
2557 dimensions))
|
|
|
2558 (t
|
|
|
2559 ;; absolute number: pixel height
|
|
|
2560 (push (max (1+ (/ (car (read-from-string match))
|
|
185
|
2561 pixel-dim))
|
|
114
|
2562 min-dim)
|
|
102
|
2563 dimensions)))
|
|
|
2564 (setq remaining-available-dimension
|
|
|
2565 (- remaining-available-dimension (car dimensions)))))))
|
|
|
2566 (if (zerop nb-stars)
|
|
|
2567 ;; push => reverse order
|
|
|
2568 (reverse dimensions)
|
|
|
2569 ;; substitute numbers for *
|
|
|
2570 (let ((star-replacement (/ remaining-available-dimension nb-stars))
|
|
108
|
2571 (star-dimensions dimensions))
|
|
|
2572 (setq dimensions nil)
|
|
|
2573 (while star-dimensions
|
|
|
2574 (push (if (eq '* (car star-dimensions))
|
|
|
2575 star-replacement
|
|
|
2576 (car star-dimensions))
|
|
|
2577 dimensions)
|
|
|
2578 (pop star-dimensions))
|
|
|
2579 ;; push + push => in order
|
|
|
2580 dimensions))))))
|
|
102
|
2581
|
|
14
|
2582 (provide 'w3-display)
|
