?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
rune fixes
[closure-html.git] / src / html / html-style.lisp
blobd1fe7429c07851dfdb6a688d2451668983e9784a
1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RENDERER; Readtable: GLISP; -*-
2 ;;; ---------------------------------------------------------------------------
3 ;;; Title: HTML-Specific Parts of the Renderer
4 ;;; Created: 1999-05-25
5 ;;; Author: Gilbert Baumann <gilbert@base-engineering.com>
6 ;;; License: MIT style (see below)
7 ;;; ---------------------------------------------------------------------------
8 ;;; (c) copyright 1998,1999 by Gilbert Baumann
9
10 ;;; Permission is hereby granted, free of charge, to any person obtaining
11 ;;; a copy of this software and associated documentation files (the
12 ;;; "Software"), to deal in the Software without restriction, including
13 ;;; without limitation the rights to use, copy, modify, merge, publish,
14 ;;; distribute, sublicense, and/or sell copies of the Software, and to
15 ;;; permit persons to whom the Software is furnished to do so, subject to
16 ;;; the following conditions:
17 ;;;
18 ;;; The above copyright notice and this permission notice shall be
19 ;;; included in all copies or substantial portions of the Software.
20 ;;;
21 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
22 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
23 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
24 ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
25 ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
26 ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
27 ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
28
29 ;;;; Notes
30
31 ;; -- 2003-03-04
32 ;;
33 ;; This only recently occured to me:
34 ;;
35 ;; Most of the mappings here are rather primitive and a lot of are
36 ;; already handled in the default style sheet, so the idea would be to
37 ;; _compile_ the whole set of mappings, maybe even yielding a
38 ;; different kind of style object, so that we'd spend less time on
39 ;; style mappings.
40 ;;
41
42 ;; Changes
43 ;;
44 ;; When Who What
45 ;; ----------------------------------------------------------------------------
46 ;; 2001-05-14 GB - primitive caching of parsed style sheets
47 ;;
48 ;; 1999-08-21 GB - MAKE-TEXT-REPLACEMENT, MAKE-PASSWORD-REPLACEMENT,
49 ;; MAKE-OPTION-MENU-REPLACEMENT, MAKE-TEXT-AREA-REPLACEMENT,
50 ;; REPLACED-ELEMENT/INPUT: pass text-style
51 ;; - MAKE-TEXT-AREA-REPLACEMENT, REPLACED-ELEMENT/INPUT:
52 ;; pass document
53 ;;
54 ;;
55 ;; 1999-08-19 GB - changed layout of :%REPLACEMENT attribute and
56 ;; PT-%REPLACEMENT function.
57 ;; - REPLACED-ELEMENT-P: returns two values now.
58 ;; - IMPLICIT-STYLE/IMG: IMG.border now maps to `border-width'
59 ;; - COMMAND-DOCUMENTATION: new generic function
60 ;; - COMMAND-CURSOR: new generic function
61 ;; - SERVER-SIDE-IMAGE-MAP: new class
62 ;; - FIND-A-ELEMENT-FOR-IMG-ISMAP: new function
63 ;; - IMAGE-REPLACED-ELEMENT/AUX: ISMAP support
64 ;; - GRAPHICAL-SUBMIT: new class
65 ;; - polygon image maps should work now.
66 ;;
67 ;; 1999-08-18 GB - PT-STYLE-STYLE now returns a list of assignments to
68 ;; carry "!important" to LOOKUP-STYLE.
69 ;;
70 ;; 1999-08-15 GB - PT-STYLE-STYLE new function to return style by STYLE
71 ;; attribute
72
73 (in-package :RENDERER)
74
75 (defun pt-%replacement (pt &optional default)
76 (sgml:pt-attr pt :%replacement default))
77
78 (defun (setf pt-%replacement) (new-value pt &optional default)
79 default
80 (setf (sgml:pt-attr pt :%replacement) new-value))
81
82 (defun pt-effective-url-attr (doc pt attr)
83 "Return the parsed and merged effective URL of an elements attribute."
84 (url:merge-url (url:parse-url (pt-attr/latin1 pt attr ""))
85 (document-base-url doc)))
86
87 (defun pt-body-element (pt)
88 (cond ((null pt) nil)
89 ((eq (element-gi pt) :HTML)
90 (dolist (q (element-children pt))
91 (when (eq (element-gi q) :BODY)
92 (return q))))
93 ((pt-body-element (element-parent pt))) ))
94
95 (defun pt-all-data (x)
96 (cond ((member (element-gi x) '(:pcdata :comment))
97 (map 'string (lambda (x) (or (rune-char x) #\?))
98 (element-text x)))
99 ((apply 'concatenate 'string
100 (mapcar #'pt-all-data (element-children x))))))
101
102 ;;; ---- Implicit Style -----------------------------------------------------------------------
103
104 (defun pt-attr/low (pt prop &optional (default nil))
105 (if (text-element-p pt)
106 default
107 (element-attribute pt prop)))
108
109 (defun pt-attr* (pt attr &optional default)
110 (pt-attr/low pt attr default))
111
112 (defun pt-attr/latin1 (pt attr &optional default)
113 (let ((r (pt-attr/low pt attr)))
114 (if r
115 (map 'string (lambda (x) (if (< (rune-code x) 256) (rune-char x) #\?)) r)
116 default)))
117
118 (defmethod closure-protocol:element-explicit-style (document (pt sgml::pt))
119 (let ((x (pt-attr* pt :style)))
120 (when x
121 (let ((css::*style-sheet-base-url* (document-base-url document)))
122 (css::parse-assignment-list x)))))
123
124 ;;;;
125 ;;;; Parsers
126 ;;;;
127
128 (defun pt-attr-warn (pt format &rest args)
129 (apply #'warn format args))
130
131 (defun pt-attr/list-style-type (pt slot &optional (default nil))
132 (let ((v (pt-attr* pt slot nil)))
133 (if v
134 (parse-list-style-type pt v)
135 default)))
136
137 (defun parse-list-style-type (pt value)
138 ;; Translate the HTML notation of a list-style-type 'value' to the CSS-1 notation.
139 (when (typep value 'rod)
140 (setf value (map 'string (lambda (x) (or (code-char x) #\?)) value)))
141 (cond ((string= value "1") :decimal)
142 ((string= value "a") :lower-alpha)
143 ((string= value "A") :upper-alpha)
144 ((string= value "i") :lower-roman)
145 ((string= value "I") :upper-roman)
146 ((string-equal value "disc") :disc)
147 ((string-equal value "square") :square)
148 ((string-equal value "circle") :circle)
149 (t
150 (pt-attr-warn pt "The value '~S' is unknown to the 'TYPE' slot." value)
151 (if (eq (element-gi (element-parent pt)) :UL) :disc :decimal)) ))
152
153 (defun parse-html-multi-length (string &optional (error-p t))
154 ;; -> list of (:% . N) | (* . N) | (:px . N) | NIL
155 (cond ((parse-html-length string nil))
156 ((and (> (length string) 1)
157 (char= (char string 0) #\*)
158 (every #'digit-char-p (subseq string 1)))
159 (cons '* (parse-integer (subseq string 1))))
160 ((and (> (length string) 1)
161 (char= (char string (1- (length string))) #\*)
162 (every #'digit-char-p (subseq string 0 (1- (length string)))))
163 (cons '* (parse-integer (subseq string 0 (1- (length string))))))
164 ((string-equal string "*") ; '*' is short cut for '1*'
165 (cons '* 1))
166 (error-p
167 (error "'~S' is not a valid HTML 'MultiLength'." string))
168 (t
169 nil)))
170
171 (defun parse-html-length (string &optional (error-p t))
172 ;; -> (:% . N) | (:px . N) | NIL
173 (cond ((and (> (length string) 0) (every #'digit-char-p string))
174 (cons :px (parse-integer string)))
175 ((and (> (length string) 1)
176 (char= (char string (1- (length string))) #\%)
177 (every #'digit-char-p (subseq string 0 (1- (length string)))))
178 (cons :% (parse-integer (subseq string 0 (1- (length string))))))
179 (error-p
180 (error "'~S' is not a valid HTML 'Length'." string))
181 (t
182 nil)) )
183
184 (defun unparse-html-length (value)
185 (cond ((and (consp value) (eq (car value) :%))
186 (format nil "~D%" (cdr value)))
187 ((and (consp value) (eq (car value) :px))
188 (format nil "~D" (cdr value)))
189 ((null value)
190 "#implied")
191 (t
192 (format nil "[invalid html-length: ~S]" value))))
193
194 (defun pt-attr/with-parser (pt slot default parser pretty-type-name)
195 (let ((s (pt-attr* pt slot)))
196 (if (not s)
197 default
198 (let ((value (funcall parser s)))
199 (if value
200 value
201 (progn
202 (pt-attr-warn pt "The value of the ~A attribute, ~S, is not ~A."
203 slot (rod-string s) pretty-type-name)
204 default))))))
205
206 (defun pt-attr/integer (pt slot &optional default)
207 (pt-attr/with-parser pt slot default #'html/parse-integer "an integer"))
208
209 (defun pt-attr/pixels (pt slot &optional default)
210 (pt-attr/with-parser pt slot default #'html/parse-integer "an integer"))
211
212 (defun pt-attr/length (pt slot &optional default)
213 (pt-attr/with-parser pt slot default #'html/parse-length "a length"))
214
215 (defun pt-attr/length-list (pt slot &optional default)
216 (pt-attr/with-parser pt slot default #'html/parse-length-list
217 "a comma separated list of lengths"))
218
219 (defun pt-attr/multi-length (pt slot &optional default)
220 (pt-attr/with-parser pt slot default #'html/parse-multi-length "a length"))
221
222 (defun pt-attr/enum (pt slot default keys)
223 (let ((s (pt-attr* pt slot)))
224 (cond ((not s)
225 default)
226 (t
227 (let ((val (some (lambda (key)
228 (and (= (length s) (length (symbol-name key)))
229 (every (lambda (x y)
230 (char-equal (rune-char x) y))
231 s (symbol-name key))
232 key))
233 keys)))
234 (or val
235 (progn
236 (pt-attr-warn pt "The value of the ~A attribute, ~
237 should be ~{\"~A\"~#[~; or ~:;, ~]~}, but not ~S."
238 slot keys (rod-string s))
239 default)))))))
240
241 (defun pt-attr/table.frame (pt slot &optional default)
242 (pt-attr/enum pt slot default
243 '(:void :above :below :hsides :lhs :rhs :vsides :box :border)))
244
245 (defun pt-attr/table.rules (pt slot &optional default)
246 (pt-attr/enum pt slot default
247 '(:none :groups :rows :cols :all)))
248
249 (defun pt-attr/table.align (pt slot &optional default)
250 (pt-attr/enum pt slot default
251 '(:left :center :right)))
252
253 (defun pt-attr/cell-halign (pt slot &optional default)
254 (pt-attr/enum pt slot default
255 '(:left :center :right :justify :char)))
256
257 (defun pt-attr/cell-valign (pt slot &optional default)
258 ;; Note for compatibility, we also accept :center but map that to :middle
259 ;; ### oops, :center actually is HTML, while :middle is CSSSpeak.
260 (subst :middle :center
261 (pt-attr/enum pt slot default
262 '(:top :middle :bottom :baseline :center))))
263
264 (defun pt-attr/input-type (pt slot &optional (default :text))
265 (pt-attr/enum pt slot default
266 '(:text :password :checkbox :radio :submit :reset
267 :file :hidden :image :button)))
268
269 (defun pt-attr/img-align (pt slot &optional default)
270 (pt-attr/enum pt slot default '(:top :middle :bottom :left :right)))
271
272 (defun pt-attr/align (pt &optional (slot :align) (default nil))
273 (pt-attr/enum pt slot default '(:left :center :right :justify)))
274
275 (defun pt-attr/clear (pt &optional (slot :clear) (default nil))
276 (pt-attr/enum pt slot default '(:left :right :all :none)))
277
278 (defun pt-attr/color (pt slot &optional (default nil))
279 (pt-attr/latin1 pt slot default))
280
281 (defun pt-attr/boolean-flag (pt slot)
282 (eq (pt-attr/enum pt slot nil (list slot)) slot))
283
284 ;; multi-length
285
286 ;; NOTE: The if-match macro is defined in match.lisp
287
288 (define-match-macro integer (&optional (radix 10))
289 `(& (? (/ #/+ #/-))
290 (+ (p (lambda (ch) (digit-rune-p ch ,radix))))))
291
292 (define-match-macro w* ()
293 `(* (p #'white-space-rune-p)))
294
295 (defun html/parse-integer (s)
296 (if-match (s :type rod :test #'rune=)
297 (& (w*) (= $res (integer)) (w*))
298 (parse-integer (rod-string (subseq s $res-start $res-end)))))
299
300 (defun html/parse-length (s)
301 (or
302 (if-match (s :type rod :test #'rune=)
303 (& (w*) (= $res (integer)) (w*))
304 (cons :px (parse-integer (rod-string (subseq s $res-start $res-end)))))
305 (if-match (s :type rod :test #'rune=)
306 (& (w*) (= $res (integer)) #/% (w*))
307 (cons :% (parse-integer (rod-string (subseq s $res-start $res-end)))))))
308
309 (defun html/parse-multi-length (s)
310 (or
311 (html/parse-length s)
312 (if-match (s :type rod :test #'rune=)
313 (& (w*) (= $res (integer)) #/* (w*))
314 (cons '* (parse-integer (rod-string (subseq s $res-start $res-end)))))
315 ;; This below is illegal syntax '*i' is not allowed
316 #+(OR)
317 (if-match (s :type rod :test #'rune=)
318 (& (w*) #.(char-code #\*) (= $res (integer)) (w*))
319 (cons '* (parse-integer (rod-string (subseq s $res-start $res-end)))))
320 ;; "*" is abbrev for "1*"
321 (if-match (s :type rod :test #'rune=)
322 (& (w*) #/* (w*))
323 (cons '* 1)) ))
324
325 (defun html/parse-length-list (s)
326 ;; A comma separated list of lengths
327 (let ((q (mapcar #'html/parse-length (split-by (char-code #\,) s))))
328 (unless (member nil q)
329 q)))
330
331 ;;;
332
333 (defun pt-attr/link-types (pt att)
334 (pt-attr/with-parser pt att nil
335 #'(lambda (rod)
336 ;; profile!!
337 (mapcar #'rod-string
338 (split-by-if #'white-space-rune-p
339 rod
340 :nuke-empty-p t)))
341 "a list of link types"))
342
343 (defun pt-attr/comma-separated-list (pt att)
344 (pt-attr/with-parser pt att nil
345 #'(lambda (x)
346 (mapcar #'rod-string
347 (mapcar #'(lambda (x)
348 (r2::rod-trim (list 9 10 12 13 32) x))
349 (split-by #/, x))))
350 "a comma separated list"))
351
352 ;;;; --------------------------------------------------------------------------------
353
354 (defun find-html-head (pt)
355 (dolist (k (element-children (sgml:pt-root pt)))
356 (cond ((member (element-gi k) '(:HEAD))
357 (return k)))))
358
359 (defun pt-map-over-link-nodes (fn pt)
360 "Map the function `fn' over all <LINK> nodes in the `pt' document's header."
361 (let ((head (find-html-head pt)))
362 (and head
363 (dolist (k (element-children head))
364 (when (eq (element-gi k) :LINK)
365 (funcall fn k))))))
366
367 (defun the-style-node (pt)
368 "Given a parse tree, find the <STYLE> node in its header, if any."
369 (let ((head (find-html-head pt)))
370 (and head
371 (dolist (k (element-children head))
372 (when (eq (element-gi k) :STYLE)
373 (return k))))))
374
375 ;; Grff...
376
377 (defparameter *style-sheet-cache*
378 (make-hash-table :test #'equalp))
379
380 (defparameter *style-sheet-cache*/lock
381 (bordeaux-threads:make-lock "*style-sheet-cache*"))
382
383 (defun maybe-parse-style-sheet-from-url (url &key (name "anonymous")
384 (supersheet nil)
385 (media-type :all))
386 (multiple-value-bind (looked presentp)
387 (bordeaux-threads:with-recursive-lock-held (*style-sheet-cache*/lock)
388 (gethash url *style-sheet-cache*))
389 (cond (presentp
390 (format *debug-io* "~&;; Serving style sheet ~S [at ~S] from cache.~%"
391 name url)
392 looked)
393 (t
394 (format *debug-io* "~&;; fetching and parsing style sheet ~S [at ~S].~%"
395 name url)
396 (let ((res (maybe-parse-style-sheet-from-url-aux
397 url
398 :name name
399 :supersheet supersheet
400 :media-type media-type)))
401 (bordeaux-threads:with-recursive-lock-held (*style-sheet-cache*/lock)
402 (setf (gethash url *style-sheet-cache*) res))
403 res)))))
404
405 (defun maybe-parse-style-sheet-from-url-aux (url &key (name "anonymous")
406 (supersheet nil)
407 (media-type :all))
408 (and (css::is-of-media-type-p :screen media-type) ;xxx
409 (let ((netlib::*always-use-cache-p* t)) ;hack to improve performance
410 (netlib:with-open-document ((input mime-type) url)
411 (cond ((and mime-type (netlib::mime-type-equal mime-type :text :css))
412 (multiple-value-bind (res condition)
413 (ignore-errors
414 (css:parse-style-sheet input supersheet
415 :name name
416 :base-url url
417 :media-type media-type))
418 (cond ((null res)
419 (warn "Error while parsing style sheet from ~S:~% ~A"
420 url condition)
421 nil)
422 (t
423 res))))
424 (t
425 (warn "The resource `~A' has mime type ~A, ~
426 but I expected text/css; style sheet ignored."
427 (url:unparse-url url)
428 (and mime-type (netlib::mime-type-name mime-type)))
429 nil))))))
430
431
432
433 ;;; big grrf!
434 ;; * html-4.0.zip/struct/links.html#adef-rel:
435 ;; | rel = cdata
436 ;; | This attribute describes the link from the current document
437 ;; | to the anchor specified by the href attribute. This value
438 ;; | of this attribute is one or more link types separated by
439 ;; | white space characters.
440
441 (defun style-link-does-apply-p (link select-style)
442 (unless (equal (slot-value link 'media) "print") ;### kludge
443 (cond ((set-equal (link-rel link) '("stylesheet") :test #'string-equal)
444 (or
445 (null (link-title link)) ;persistent
446 (eq select-style :default))) ;selected
447 ((set-equal (link-rel link) '("alternate" "stylesheet") :test #'string-equal)
448 (or
449 (null (link-title link)) ;persistent
450 (string-equal (link-title link) select-style))) )))
451
452 (defun style-sheet-link-p (link)
453 (or (set-equal (link-rel link) (list "alternate" "stylesheet") :test #'string-equal)
454 (set-equal (link-rel link) (list "stylesheet") :test #'string-equal)))
455
456 (defun alternate-style-sheet-link-p (link)
457 (or (set-equal (link-rel link) (list "alternate" "stylesheet") :test #'string-equal)))
458
459 (defun default-style-sheet-link-p (link)
460 (or (set-equal (link-rel link) (list "stylesheet") :test #'string-equal)))
461
462 (defun style-sheet-name-equal-p (x y)
463 ;; just in case this changes
464 (string= x y))
465
466
467 ;;;; --------------------------------------------------------------------------------
468
469 (defclass html-document-language ()
470 ())
471
472 (defclass html-4.0-document-language (html-document-language)
473 ())
474
475 (defmethod closure-protocol:element-replaced-element-1
476 ((language html-4.0-document-language)
477 user-agent document device
478 elm)
479 (declare (ignorable language user-agent))
480 (values-list
481 (cond ((and (not gui:*user-wants-images-p*)
482 (member (element-gi elm) '(:IMG)))
483 nil)
484 ((member (element-gi elm) '(:IMG))
485 ;;xxx (member (element-gi elm) '(:form :button :input :select :textarea :img))
486 (cond ((eq (pt-%replacement elm :unset) :unset)
487 (multiple-value-bind (robj action-map) (build-replaced-element document device elm)
488 (setf (pt-%replacement elm) (list robj action-map) )))
489 (t
490 (pt-%replacement elm))))
491 (t
492 nil))))
493
494 ;;;; --------------------------------------------------------------------------------
495
496 (defun replaced-element-p (document device element)
497 (closure-protocol:element-replaced-element-1
498 closure-protocol:*document-language*
499 closure-protocol:*user-agent*
500 document device element))
501
502 (defun build-replaced-element (document device elm)
503 (case (element-gi elm)
504 ((:form)
505 (replaced-element/form document device elm))
506 ((:button)
507 (handle-button device elm))
508 ((:input)
509 (replaced-element/input document device elm))
510 ((:select)
511 (make-option-menu-replacement device elm))
512 ((:textarea)
513 (make-text-area-replacement document device elm))
514 ((:img)
515 (image-replaced-element document device elm))
516 (t
517 nil)))
518
519 (defun replaced-element/input (document device elm)
520 document
521 (case (pt-attr/input-type elm :type :text)
522 (:submit
523 (gui:ro/make-submit-button
524 device
525 :pt elm
526 :label (pt-attr* elm :value (rod "Submit Query"))
527 :name (pt-attr* elm :name)
528 :size (pt-attr/integer elm :size nil)
529 :disabled-p (pt-attr/boolean-flag elm :disabled)
530 :read-only-p (pt-attr/boolean-flag elm :readonly)
531 :text-style (pt-text-style device elm)
532 :document document))
533
534 (:button
535 (gui:ro/make-button
536 device
537 :pt elm
538 :label (pt-attr* elm :value (rod "A Button"))
539 :name (pt-attr* elm :name)
540 :size (pt-attr/integer elm :size nil)
541 :disabled-p (pt-attr/boolean-flag elm :disabled)
542 :read-only-p (pt-attr/boolean-flag elm :readonly)
543 :text-style (pt-text-style device elm)
544 :document document))
545
546 (:reset
547 (gui:ro/make-reset-button
548 device
549 :pt elm
550 :label (pt-attr* elm :value (rod "Reset"))
551 :name (pt-attr* elm :name)
552 :size (pt-attr/integer elm :size nil)
553 :disabled-p (pt-attr/boolean-flag elm :disabled)
554 :read-only-p (pt-attr/boolean-flag elm :readonly)
555 :text-style (pt-text-style device elm)
556 :document document))
557
558 (:password
559 (make-password-replacement device elm))
560
561 ((:text)
562 (make-text-replacement device elm))
563
564 (:checkbox
565 (make-checkbox-replacement device elm))
566
567 (:radio
568 (make-radio-replacement device elm))
569
570 (:hidden
571 ;; Hell, why is this ever reached?
572 ;; After all HIDDEN input element have display: none;
573 (gui::ro/make-hidden
574 device
575 :name (pt-attr* elm :name)
576 :value (pt-attr* elm :value)
577 :disabled-p (pt-attr/boolean-flag elm :disabled)))
578
579 ((:image)
580 (let ((ro (image-replaced-element/aux document device elm
581 :uri (pt-effective-url-attr document elm :src)
582 :alt (pt-attr* elm :alt (rod "Submit Query")))))
583 ;; usemap from image-replaced-element/aux?!?
584 (let ((map (list (make-instance 'imap-everywhere
585 :link (make-instance 'graphical-submit
586 :pt elm
587 :name (pt-attr* elm :name nil))))))
588 (values ro map))) )
589
590 (t
591 (warn "Unrecognized input type: ~S." (pt-attr/input-type elm :type :text))
592 nil)))
593
594 (defun replaced-element/form (document device elm)
595 ;; hack alert
596 (setf (pt-%replacement elm) nil)
597 (sgml:map-pt (lambda (x) (replaced-element-p document device x)) elm)
598 (pt-%replacement elm :unset))
599
600 (defun make-text-replacement (device elm)
601 (gui:ro/make-text
602 device
603 :pt elm
604 :name (pt-attr* elm :name (rod ""))
605 :initial-value (pt-attr* elm :value (rod ""))
606 :size (pt-attr/integer elm :size nil)
607 :max-length (pt-attr/integer elm :maxlength nil)
608 :disabled-p (pt-attr/boolean-flag elm :disabled)
609 :read-only-p (pt-attr/boolean-flag elm :readonly)
610 :text-style (pt-text-style device elm)))
611
612 (defun make-password-replacement (device elm)
613 (gui:ro/make-password
614 device
615 :pt elm
616 :name (pt-attr* elm :name (rod ""));hmm warum "" hier?
617 :initial-value (pt-attr* elm :value (rod ""))
618 :size (pt-attr/integer elm :size nil)
619 :max-length (pt-attr/integer elm :maxlength nil)
620 :disabled-p (pt-attr/boolean-flag elm :disabled)
621 :read-only-p (pt-attr/boolean-flag elm :readonly)
622 :text-style (pt-text-style device elm)))
623
624 (defun make-text-area-replacement (document device elm)
625 (gui::ro/make-text-area
626 device
627 :pt elm
628 :name (pt-attr* elm :name nil)
629 :initial-value (string-trim '(#\space #\return #\newline #\tab) (pt-data elm))
630 :cols (pt-attr/integer elm :cols nil)
631 :rows (pt-attr/integer elm :rows nil)
632 :disabled-p (pt-attr/boolean-flag elm :disabled)
633 :read-only-p (pt-attr/boolean-flag elm :readonly)
634 :text-style (pt-text-style device elm)
635 :document document))
636
637 (defun make-radio-replacement (device elm)
638 (gui::ro/make-radio-box
639 device
640 :pt elm
641 :name (pt-attr* elm :name)
642 :initial-value (pt-attr* elm :value)
643 :checked-p (pt-attr/boolean-flag elm :checked)
644 :disabled-p (pt-attr/boolean-flag elm :disabled)
645 :read-only-p (pt-attr/boolean-flag elm :readonly)
646 :size (pt-attr/integer elm :size nil)))
647
648 (defun make-checkbox-replacement (device elm)
649 (gui:ro/make-check-box
650 device
651 :name (pt-attr* elm :name)
652 :initial-value (pt-attr* elm :value)
653 :checked-p (pt-attr/boolean-flag elm :checked)
654 :disabled-p (pt-attr/boolean-flag elm :disabled)
655 :read-only-p (pt-attr/boolean-flag elm :readonly)
656 :size (pt-attr/integer elm :size nil)))
657
658 (defun rod-trim (bag rod)
659 (let ((p1 (position-if-not (lambda (x) (member x bag)) rod))
660 (p2 (position-if-not (lambda (x) (member x bag)) rod :from-end t)))
661 (if (and p1 p2)
662 (subseq rod p1 (+ p2 1))
663 (rod ""))))
664
665 (defun parse-options (elm)
666 (case (element-gi elm)
667 ((:OPTION)
668 (let ((content (pt-data-iso10646 elm) ))
669 (setf content (and content (rod-trim '(9 10 12 13 32) content)))
670 (gui:make-option-menu-option
671 :label (pt-attr* elm :label content)
672 :value (or (pt-attr* elm :value content))
673 :disabled-p (pt-attr/boolean-flag elm :disabled)
674 :selected-p (pt-attr/boolean-flag elm :selected)
675 :content content)))
676 ((:OPTGROUP)
677 (gui:make-option-menu-option-group
678 :disabled-p (pt-attr/boolean-flag elm :disabled)
679 :label (pt-attr* elm :label (rod "--submenu--"))
680 :children (remove nil (mapcar #'parse-options (element-children elm)))))
681 (otherwise
682 (warn "The ~A element is not allowed with <SELECT>." (element-gi elm))
683 nil)))
684
685 (defun make-option-menu-replacement (device elm)
686 (gui::make-option-menu
687 device
688 :pt elm
689 :options (remove nil (mapcar #'parse-options (element-children elm)))
690 :name (pt-attr* elm :name)
691 :multiple-p (pt-attr/boolean-flag elm :multiple)
692 :disabled-p (pt-attr/boolean-flag elm :disabled)
693 :size (pt-attr/integer elm :size nil)
694 :text-style (pt-text-style device elm)))
695
696 ;;;;;
697
698 ;;; ARG!
699 ;;
700 ;; <FORM action="..." method="post">
701 ;; <P>
702 ;; <INPUT type="password" style="display:none"
703 ;; name="invisible-password"
704 ;; value="mypassword">
705 ;;
706 ;;
707
708 ;;;
709
710 (defparameter *use-images-p* t)
711
712 (defun image-replaced-element (document device elm)
713 (image-replaced-element/aux document device elm
714 :uri (pt-effective-url-attr document elm :src)
715 :usemap (pt-attr* elm :usemap nil)
716 :width (pt-attr/pixels elm :width nil)
717 :height (pt-attr/pixels elm :height nil)
718 :alt (pt-attr* elm :alt (rod "[image]"))))
719
720 (defclass graphical-submit ()
721 ((name :initarg :name :reader gs-name)
722 (pt :initarg :pt :reader gs-pt)
723 ))
724
725 (defmethod command-documentation ((self graphical-submit))
726 "Submit Form")
727
728 (defclass server-side-image-map ()
729 ((url :initarg :url :reader ssim-url)
730 (target :initarg :target :reader ssim-target)
731 (title :initarg :title :reader ssim-title)))
732
733 (defun find-A-element-for-img-ismap (img-element)
734 (do ((q img-element (element-parent q)))
735 ((null q))
736 (when (and (eq (element-gi q) :a)
737 (not (null (pt-attr* q :href))))
738 (return q))))
739
740 (defmethod command-documentation ((self server-side-image-map))
741 (with-slots (title url) self
742 (format nil "Server side image map: ~A (~A)."
743 (or title "")
744 (url:unparse-url url))))
745
746 (defun image-replaced-element/aux (document device elm
747 &key uri (usemap nil) (width nil) (height nil)
748 alt)
749 (cond (*use-images-p*
750 (let* ((w width)
751 (h height)
752 (usemap (and usemap (url:parse-url
753 ;;xxx use something better than rod-string
754 (rod-string usemap))))
755 (url uri))
756 (let ((obj (gui::make-image-replacement device document :url url :width w :height h))
757 (map nil)
758 (usemapmap nil))
759
760 (when usemap
761 (setf usemapmap
762 (find-and-parse-image-map document usemap)))
763
764 (when (pt-attr* elm :ismap nil)
765 (cond (usemapmap
766 (warn "ISMAP ignored, since client side image map is present."))
767 (t
768 (let ((aelm (find-A-element-for-img-ismap elm)))
769 (cond ((not aelm)
770 (warn "Found <IMG ISMAP ..> without surounding A element."))
771 (t
772 ;; find the title
773 (let ((title
774 (or (pt-attr* elm :alt nil)
775 (pt-attr* aelm :title nil)
776 (pt-attr* aelm :alt nil))))
777 (setf map
778 (list (make-instance 'imap-everywhere
779 :link (make-instance 'server-side-image-map
780 :url (pt-effective-url-attr document aelm :href)
781 :target "_top" ;; xxx
782 :title title)))))))))))
783
784 (setf map (append map usemapmap))
785 (setf (pt-%replacement elm) (list obj nil)) ;warum wird das gebraucht!?
786 (values obj map))))
787 (t
788 (let ((r (sgml::copy-pt elm)))
789 (setf (pt-%replacement r) nil)
790 (setf (element-children r)
791 (list
792 (sgml::make-pt/low :name :pcdata
793 :attrs alt
794 :parent r
795 :children nil)))
796 r))))
797
798 ;; wir haben das mit dem impliciten stil noch falsch gemacht:
799
800 ;; | 3.2 CASCADING ORDER
801 ;; |
802 ;; | A declaration in the 'STYLE' attribute of an element (see section 1.1
803 ;; | for an example) has the same weight as a declaration with an ID-based
804 ;; | selector that is specified at the end of the style sheet:
805 ;; |
806 ;; | <STYLE TYPE="text/css">
807 ;; | #x97z { color: blue }
808 ;; | </STYLE>
809 ;; |
810 ;; | <P ID=x97z STYLE="color: red">
811 ;; |
812 ;; | In the above example, the color of the 'P' element would be red.
813 ;; | Although the specificity is the same for both declarations, the
814 ;; | declaration in the 'STYLE' attribute will override the one in the
815 ;; | 'STYLE' element because of cascading rule number 5.
816 ;; |
817 ;; | The UA may choose to honor other stylistic HTML attributes, for
818 ;; | example 'ALIGN'. If so, these attributes are translated to the
819 ;; | corresponding CSS rules with specificity equal to 1. [*] The rules are
820 ;; | assumed to be at the start of the author style sheet and may be
821 ;; | overridden by subsequent style sheet rules. In a transition phase,
822 ;; | this policy will make it easier for stylistic attributes to coexist
823 ;; | with style sheets.
824
825 ;; [*] that is they should be treated like a selector featuring
826 ;; exactly the gi.
827 ;; Note: This rule about the HTML attrs is bad. If say e.g.
828 ;;
829 ;; P { text-align: left; }, i have no option to say in the HTML
830 ;; document e.g. <P align=right> Arg!
831 ;;
832
833 ;; Command protocol
834 ;;
835 ;; command-documentation command -> rod
836 ;; command-cursor command -> cursor keyword
837 ;;
838
839 (defstruct hyper-link
840 ;; structure for a hyper-link
841 url ;the URL this points to
842 alt ;alternate text or NIL
843 target ;target frame
844 ;; wir brauchen noch:
845 ;; - is-map-p (für server-side image maps).
846
847 ;; und Möglichkeiten noch zu specifizieren, daß das hier eine FORM
848 ;; submitten soll.
849 ;; d.h. wir benötigen eher so etwas wie ein assoziertes Commando.
850 )
851
852 (defmethod command-documentation ((self hyper-link))
853 (let ((url-string (if (not (null (hyper-link-url self)))
854 (url:unparse-url (hyper-link-url self))
855 "--no url--")))
856 (if (hyper-link-alt self)
857 (format nil "~A (~A)"
858 (rod-string (hyper-link-alt self)) url-string)
859 (format nil "~A" url-string))))
860
861 (defmethod command-documentation ((self hyper-link))
862 (let ((url-string (if (not (null (hyper-link-url self)))
863 (url:unparse-url (hyper-link-url self))
864 "--no url--")))
865 (if (hyper-link-alt self)
866 (concatenate 'rod (hyper-link-alt self)
867 (string-rod " (")
868 (string-rod url-string)
869 (string-rod ")"))
870 (format nil "~A" url-string))))
871
872 (defmethod command-documentation ((self t))
873 ;; fall back method
874 (format nil "~S" self))
875
876 ;;;; Image Maps
877
878 (defclass imap-area ()
879 ((link :initarg :link :initform nil :reader imap-area-link)));hyper link
880
881 (defclass imap-everywhere (imap-area)
882 () )
883
884 (defclass imap-rectangle (imap-area)
885 ((x0 :initarg :x0)
886 (y0 :initarg :y0)
887 (x1 :initarg :x1)
888 (y1 :initarg :y1)) )
889
890 (defclass imap-circle (imap-area)
891 ((x :initarg :x)
892 (y :initarg :y)
893 (radius :initarg :radius)) )
894
895 (defclass imap-polygon (imap-area)
896 ((point-seq :initarg :point-seq))) ;sequence (x0 y0 x1 y1 .. xn yn) as in CLX
897
898 (defun area-node-to-imap-area (elm)
899 ;; Parses an AREA (or A) element into an imap-area object.
900 ;; Returns NIL, if something goes wrong.
901 (assert (member (element-gi elm) '(:AREA :A)))
902 (let ((href (and (pt-attr* elm :href nil)
903 (url:parse-url (pt-attr/latin1 elm :href))))
904 (nohref (pt-attr/boolean-flag elm :nohref))
905 (alt (pt-attr* elm :alt nil))
906 (shape (pt-attr/enum elm :shape :rect '(:default :rect :circle :poly)))
907 (coords (pt-attr/length-list elm :coords nil))
908 (target (pt-effective-target-attr elm :target)))
909 (when (and nohref href)
910 (warn "AREA element has HREF attribute despite of present NOHREF attribute.~
911 NOHREF takes precedence.")
912 (setq href nil))
913 (unless alt
914 (warn "Each AREA element should have an 'alt' attribute."))
915 (let ((link (make-hyper-link
916 :url href
917 :alt alt
918 :target target)))
919 (ecase shape
920 ((:default) (area-node-to-imap-area/default elm link coords))
921 ((:rect) (area-node-to-imap-area/rect elm link coords))
922 ((:circle) (area-node-to-imap-area/circle elm link coords))
923 ((:poly) (area-node-to-imap-area/poly elm link coords))) )) )
924
925 (defun area-node-to-imap-area/default (elm link coords)
926 (declare (ignore elm))
927 (cond ((= 0 (length coords))
928 (make-instance 'imap-everywhere
929 :link link))
930 (t
931 (warn "A `default' AREA should not specify any `coords'.")
932 nil)))
933
934 (defun area-node-to-imap-area/rect (elm link coords)
935 (declare (ignore elm))
936 (cond ((= 4 (length coords))
937 (make-instance 'imap-rectangle
938 :link link
939 :x0 (first coords)
940 :y0 (second coords)
941 :x1 (third coords)
942 :y1 (fourth coords) ))
943 (t
944 (warn "A `rect' AREA should specify exactly four `coords'.")
945 nil)))
946
947 (defun area-node-to-imap-area/circle (elm link coords)
948 (declare (ignore elm))
949 (cond ((= 3 (length coords))
950 (make-instance 'imap-circle
951 :link link
952 :x (first coords)
953 :y (second coords)
954 :radius (third coords) ))
955 (t
956 (warn "A `circle' AREA should specify exactly three `coords'.")
957 nil)))
958
959 (defun area-node-to-imap-area/poly (elm link coords)
960 (declare (ignore elm))
961 (cond ((evenp (length coords))
962 (make-instance 'imap-polygon
963 :link link
964 :point-seq coords))
965 (t
966 (warn "A `poly' AREA should specify an even number of `coords'.")
967 nil)))
968
969 (defun parse-image-map (document node)
970 "Parses a <MAP> node into a list of IMAP-AREA objects"
971 ;; TODO: warning message, if old and new style <MAP>'s are mixed.
972 ;; for now we simply collect all AREA and A elements.
973 (declare (ignore document))
974 (assert (eq (element-gi node) :MAP))
975 (let ((res nil))
976 (sgml:map-pt (lambda (x)
977 (when (member (element-gi x) '(:A :AREA))
978 (let ((q (area-node-to-imap-area x)))
979 (when q
980 (push q res)))))
981 node)
982 ;; order is important
983 (nreverse res)))
984
985 (defun find-image-map (document url)
986 (cond ((not (null (url:url-anchor url)))
987 (cond ((and (null (url:url-protocol url))
988 (null (url:url-host url))
989 (null (url:url-port url))
990 (null (url:url-path url))
991 (null (url:url-host url)))
992 ;; something in this document
993 (find-image-map-in-pt (document-pt document) (url:url-anchor url)) )
994 (t
995 (warn "Image maps in other documents than the current are not supported.")
996 nil)))
997 (t
998 (warn "Found `usemap' URI without an anchor component.")
999 nil)))
1000
1001 (defun find-image-map-in-pt (pt anchor)
1002 (sgml:map-pt (lambda (node)
1003 (when (and (eq (element-gi node) :map)
1004 (pt-attr* node :name)
1005 (string-equal (pt-attr/latin1 node :name) anchor))
1006 (return-from find-image-map-in-pt node)))
1007 pt))
1008
1009 ;; Questions with regard to image maps:
1010 ;; 1. What is the exact meaning of percentage values?
1011 ;; 2. Why does the A element have no "nohref" attribute. Accident?
1012 ;; 3. Why has AREA none of the rel, rev, charset etc. Attributes?
1013
1014 ;;;;
1015
1016 (defmethod area-contains-point-p ((area imap-everywhere) x y w h)
1017 (declare (ignore x y w h))
1018 t)
1019
1020 (defmethod area-contains-point-p ((area imap-rectangle) x y w h)
1021 (with-slots (x0 y0 x1 y1) area
1022 (let ((x0 (area-resolve-coordinate x0 w))
1023 (y0 (area-resolve-coordinate y0 h))
1024 (x1 (area-resolve-coordinate x1 w))
1025 (y1 (area-resolve-coordinate y1 h)))
1026 (and (<= (min x0 x1) x (max x0 x1))
1027 (<= (min y0 y1) y (max y0 y1))))))
1028
1029 (defmethod area-contains-point-p ((area imap-circle) px py w h)
1030 (with-slots (x y radius) area
1031 (let ((x (area-resolve-coordinate x w))
1032 (y (area-resolve-coordinate y h))
1033 (radius (min (area-resolve-coordinate radius w)
1034 (area-resolve-coordinate radius h))))
1035 (<= (+ (* (- px x) (- px x))
1036 (* (- py y) (- py y)))
1037 (* radius radius)))))
1038
1039 (defun polygon-contains-point-p (coord-seq x y)
1040 (let ((n (floor (length coord-seq) 2))
1041 (k 0))
1042 (macrolet ((px (i) `(elt coord-seq (* 2 (mod ,i n))))
1043 (py (i) `(elt coord-seq (+ 1 (* 2 (mod ,i n))))))
1044 (dotimes (i n)
1045 (let ((x0 (px i)) (y0 (py i))
1046 (x1 (px (+ i 1))) (y1 (py (+ i 1))))
1047 (cond ((or (< y0 y y1)
1048 (> y0 y y1))
1049 (let ((xi
1050 (cond ((= (- x1 x0) 0) x0)
1051 (t
1052 (* (+ (* (/ (- y1 y0) (- x1 x0)) x0)
1053 (- y y0))
1054 (/ (- x1 x0) (- y1 y0)))))))
1055 (cond ((< xi x) (incf k))
1056 ((= xi x) (return-from polygon-contains-point-p t)))))
1057 ((and (/= y0 y) (= y1 y))
1058 (let ((j (do ((j (+ i 1) (+ j 1)))
1059 ((= j (+ i n)) j)
1060 (when (/= (py j) y)
1061 (return j)))))
1062 (when (/= (signum (- y y0)) (signum (- y (py j))))
1063 (cond ((< x1 x) (incf k))
1064 ((= x1 x) (return-from polygon-contains-point-p t))))))
1065 ((and (= y0 y) (= y 1 y))
1066 (when (or (<= x0 x x1) (>= x0 x x1))
1067 (return-from polygon-contains-point-p t))))))
1068 (oddp k))))
1069
1070 (defmethod area-contains-point-p ((area imap-polygon) px py w h)
1071 (let ((new-point-seq nil))
1072 ;; resolve all coordinates and put then into points as list of conses
1073 (with-slots (point-seq) area
1074 (do ((q point-seq (cddr q)))
1075 ((or (endp q) (endp (cdr q))))
1076 (push (area-resolve-coordinate (cadr q) h) new-point-seq)
1077 (push (area-resolve-coordinate (car q) w) new-point-seq)))
1078 ;; the hard work is done in GU
1079 (polygon-contains-point-p new-point-seq px py)))
1080
1081 (defun area-resolve-coordinate (coordinate whole)
1082 (ecase (car coordinate)
1083 ((:PX) (cdr coordinate))
1084 ((:%) (/ (* (cdr coordinate) whole) 100))))
1085
1086 ;;;;
1087
1088 (defun find-and-parse-image-map (document url)
1089 "Attemps to convert a URL to an image, return NIL, if anything fails."
1090 (let ((p (find-image-map document url)))
1091 (when p
1092 (setf p (parse-image-map document p)))
1093 (when p
1094 (setf p (mapcar (lambda (x)
1095 ;;zzz
1096 (when (hyper-link-url (slot-value x 'link))
1097 (setf (hyper-link-url (slot-value x 'link))
1098 (url:merge-url (hyper-link-url (slot-value x 'link))
1099 (document-base-url document))))
1100 x)
1101 p)))
1102 p))
1103
1104 (defclass ro/image ()
1105 ((url :initarg :url)
1106 (iwidth :initarg :iwidth)
1107 (iheight :initarg :iheight)
1108 (awidth :initarg :awidth :initform nil)
1109 (aheight :initarg :aheight :initform nil)
1110 (alt :initarg :alt)
1111 (aimage :initarg :aimage :initform nil)
1112 (pixmap :initform nil)
1113 (mask :initform nil)
1114 (fixed-size-p :initform nil :initarg :fixed-size-p)
1115 ))
1116
1117 (defmethod ro/intrinsic-size ((self ro/image))
1118 (with-slots (url iwidth iheight) self
1119 (cond ((and iwidth iheight)
1120 (values iwidth iheight 0))
1121 (t
1122 (values 20 20 0)))))
1123
1124 (defmethod ro/size ((self ro/image))
1125 (with-slots (url awidth aheight) self
1126 (cond ((and awidth aheight)
1127 (values awidth aheight 0))
1128 (t
1129 (values 20 20 0)))))
1130
1131 (defmethod update-lazy-object (document (self ro/image))
1132 (with-slots (url fixed-size-p) self
1133 (let ((aim (document-fetch-image document self url)))
1134 (with-slots (iwidth iheight (self.aimage aimage) awidth aheight) self
1135 (setf iwidth (aimage-width aim)
1136 iheight (aimage-height aim)
1137 self.aimage aim)
1138 (unless awidth (setf awidth (aimage-width aim)))
1139 (unless aheight (setf aheight (aimage-height aim)))
1140 ))
1141 (cond (fixed-size-p
1142 ;; **hack**
1143 (with-slots (aimage awidth aheight) self
1144 (let ((drawable (xlib:screen-root (xlib:display-default-screen clue-gui2::*dpy*))))
1145 (with-slots (pixmap mask) self
1146 (unless pixmap
1147 (let ((q (clue-gui2::make-pixmap-from-aimage drawable aimage awidth aheight)))
1148 (setf pixmap (car q)
1149 mask (cadr q)))))))
1150 ;; return
1151 nil)
1152 (t
1153 ;; return
1154 t))))
1155
1156 (defmethod x11-draw-robj (drawable gcontext (self ro/image) box x y)
1157 (setf x (floor x))
1158 (setf y (floor y))
1159 (with-slots (alt awidth aheight aimage url) self
1160 (cond (aimage
1161 (unless awidth (setf awidth (aimage-width aimage)))
1162 (unless aheight (setf aheight (aimage-height aimage)))
1163 (with-slots (pixmap mask) self
1164 (unless pixmap
1165 (warn "Rendering pixmap while redisplay (~S)"
1166 url)
1167 (let ((q (clue-gui2::make-pixmap-from-aimage drawable aimage awidth aheight)))
1168 (setf pixmap (car q)
1169 mask (cadr q))))
1170 (cond ((not (null mask))
1171 (xlib:with-gcontext (gcontext :clip-mask mask
1172 :clip-x x
1173 :clip-y (- y aheight))
1174 (xlib:copy-area pixmap gcontext 0 0 awidth aheight
1175 drawable x (- y aheight))) )
1176 (t
1177 (xlib:copy-area pixmap gcontext 0 0 awidth aheight
1178 drawable x (- y aheight) )))))
1179
1180 (t
1181 (multiple-value-bind (w h) (ro/size self)
1182 (setf w (floor w))
1183 (setf h (floor h))
1184 (xlib:with-gcontext (gcontext
1185 :foreground (ws/x11::x11-find-color drawable :black)
1186 )
1187 (xlib:draw-glyphs drawable gcontext x y (rod-string alt))
1188 (xlib:draw-rectangle drawable gcontext x (- y h) w h)))) )))
1189
1190
1191 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1192
1193 ;; Now this is misnomer, since being HTML is no property of the tree,
1194 ;; but of the "document language", we'll refine that later.
1195 ;; 2002-08-07 GB
1196
1197 (defmethod closure-protocol:element-css-class ((element sgml::pt))
1198 (element-attribute element :CLASS))
1199
1200 (defmethod closure-protocol:element-css-id ((element sgml::pt))
1201 (element-attribute element :ID))
1202
1203 (defmethod closure-protocol:pseudo-class-matches-p (pseudo-class (pt sgml::pt))
1204 (case pseudo-class
1205 ((:link :visited)
1206 (and (not (null (r2::pt-attr/latin1 pt :href))))) ;this is of course a bit too lazy!
1207 ((:hover)
1208 (and
1209 (sgml:pt-attr pt :%hover-p nil)))
1210 ((:first-letter)
1211 (eq (sgml::pt-attr pt :%pseudo-class) pseudo-class))
1212 (otherwise
1213 nil)))
1214
1215 (defmethod closure-protocol:element-style-cache ((element sgml::pt))
1216 (sgml::pt-cache element))
1217
1218 (defmethod (setf closure-protocol:element-style-cache) (new-value (element sgml::pt))
1219 (setf (sgml::pt-cache element) new-value))
1220
1221 ;;;
1222
1223 (defmethod closure-protocol:element-base-url ((language html-document-language) element)
1224 (let ((base-element (pt-headers-base-element element)))
1225 (cond ((and (not (null base-element))
1226 (not (null (pt-attr* base-element :HREF))))
1227 (url:parse-url (pt-attr/latin1 base-element :HREF)))
1228 (t
1229 nil) )))
1230
1231 (defun pt-headers-base-element (pt)
1232 "Return the <BASE> element of the document `pt' is a sub-node of."
1233 (cond ((null pt) nil)
1234 ((eq (element-gi pt) :HTML)
1235 (dolist (q (element-children pt))
1236 (when (eq (element-gi q) :HEAD)
1237 (dolist (k (element-children q))
1238 (when (eq (element-gi k) :BASE)
1239 (return-from pt-headers-base-element k))))))
1240 ((pt-headers-base-element (element-parent pt))) ))
1241
1242 (defun pt-base-target (pt)
1243 ;; only used from CLUE-GUI and PT-EFFECTIVE-TARGET-ATTR, soon to be nuked.
1244 (let ((base-element (pt-headers-base-element pt)))
1245 (and base-element
1246 (pt-attr/latin1 base-element :TARGET NIL))))
1247
1248 (defun pt-effective-target-attr (pt attr)
1249 "Return the effective target attribute of `pt' named `attr';
1250 Does look at the header, if `pt' has no attribute called `attr'."
1251 (or (pt-attr/latin1 pt attr nil)
1252 (pt-base-target pt)))
1253
1254 (defmethod closure-protocol:element-imap ((document-language html-document-language)
1255 document
1256 element)
1257 (cond ((and (eq (element-gi element) :A)
1258 (pt-attr* element :href nil))
1259 (make-instance 'imap-everywhere
1260 :link (make-hyper-link
1261 :url (pt-effective-url-attr document element :href)
1262 :alt (pt-attr* element :title nil)
1263 :target (pt-effective-target-attr element :target))))
1264 (t
1265 nil))
1266 )
1267
1268
1269 (defmethod closure-protocol:render
1270 ((document-language html-document-language)
1271 document device pt
1272 w
1273 &optional (flag t) (h 0)
1274 &key (selected-style :default))
1275 (declare (ignorable document-language))
1276
1277 ;; temporary medicine
1278 (setf (document-title document) nil
1279 (document-links document) nil)
1280
1281 ;; Post possible HTTP Link: header fields.
1282 (dolist (k (document-http-header document))
1283 (cond ((string-equal :link (car k))
1284 (let ((links (netlib:parse-http-link-field (cdr k))))
1285 (cond ((null links)
1286 (warn "HTTP \"Link\" header field has illegal syntax: ~S." (cdr k)))
1287 (t
1288 (dolist (link links)
1289 (process-head-child document (sgml:lhtml->pt link)))))))))
1290
1291 ;; First of all process the head
1292 (dolist (k (element-children pt))
1293 (when (eq (element-gi k) :head)
1294 (process-head document k)))
1295
1296 ;;
1297 (unless (document-title document)
1298 (setf (document-title document) "no title")
1299 (warn "Each document should have a TITLE element."))
1300
1301 (render2 device document pt selected-style)
1302 '(render-pt device document pt w flag h :selected-style selected-style)
1303 )
1304
1305 (defun process-head (document pt)
1306 (dolist (k (element-children pt))
1307 (process-head-child document k)))
1308
1309 (defun process-head-child (doc pt)
1310 (cond ((eq (element-gi pt) :title)
1311 (setf (document-title doc) (pt-data pt)))
1312 ((eq :link (element-gi pt))
1313 (setf (document-links doc)
1314 (append (document-links doc)
1315 (list (make-instance 'link
1316 :title (pt-attr/latin1 pt :title)
1317 :rel (pt-attr/link-types pt :rel)
1318 :rev (pt-attr/link-types pt :rev)
1319 :media (pt-attr/latin1 pt :media) ;; xxx (comma-separated-list k :media)
1320 :target (pt-attr/latin1 pt :target)
1321 :href (pt-effective-url-attr doc pt :href))))))
1322 (t
1323 )))
1324
1325 (defmethod closure-protocol:root-element-embedded-style ((language html-document-language) pt)
1326 (let ((style-node (the-style-node pt)))
1327 (and style-node
1328 (pt-all-data style-node))))
1329
1330 (defun br-element-p (element)
1331 (and (not (text-element-p element))
1332 (eql :BR (element-gi element))))
1333
1334 ;;;;
1335
1336 (defgeneric element-attribute-parser (document-language gi attribute))
1337
1338 (defun parsed-attribute (document-language element attribute)
1339 (funcall (element-attribute-parser document-language (element-gi element) attribute)
1340 (element-attribute element attribute)))
1341
1342 ;;;
1343
1344 (defgeneric eis (document-language element)
1345 (:method-combination append))
1346
1347 (defgeneric eis-by-gi (document-language element gi)
1348 (:method-combination append))
1349
1350 (defgeneric eis-by-attr (document-language element gi attr value)
1351 (:method-combination append))
1352
1353 (defmethod eis append (document-language element)
1354 ;; fallback returning NIL
1355 nil)
1356
1357 (defmethod eis :around (document-language element)
1358 (append
1359 (eis-by-gi document-language element (element-gi element))
1360 (call-next-method)))
1361
1362 (defmethod eis-by-gi :around (document-language element gi)
1363 (append
1364 (loop for (attr value . rest) = (sgml::pt-attrs element) then rest while attr
1365 append
1366 (eis-by-attr document-language element
1367 (element-gi element)
1368 attr
1369 value))
1370 (call-next-method)))
1371
1372 (defmethod eis-by-attr append (document-language element gi attr value)
1373 nil)
1374
1375 (defmethod eis-by-gi append (document-language element gi)
1376 nil)
1377
1378 (defmacro define-style-mapping (document-language (element &optional gi attr value) &body body)
1379 (cond ((and (consp gi)
1380 (consp (cadr gi))
1381 (eq (car (cadr gi)) 'member))
1382 `(progn
1383 ,@(mapcar (lambda (elt)
1384 `(define-style-mapping ,document-language
1385 (,element (,(car gi) (eql ,elt)) ,attr ,value)
1386 .,body))
1387 (cdr (cadr gi)))))
1388 (t
1389 `(defmethod ,(cond (value 'eis-by-attr)
1390 (gi 'eis-by-gi)
1391 (t 'eis))
1392 append
1393 ((document-language ,document-language)
1394 ,element
1395 ,@(and gi `(,gi))
1396 ,@(and gi attr value `(,attr ,value)))
1397 (declare (ignorable document-language ,element
1398 ,@(and gi (list (car gi)))
1399 ,@(and attr (list (car attr)))
1400 ,@(and value (list value))))
1401 (let ((res nil))
1402 (labels ((add-style (attr value)
1403 (push (cons attr value) res)))
1404 ,@body
1405 res)))) ))
1406
1407 ;;;;
1408
1409 (defmethod closure-protocol:element-implicit-style (document (element sgml::pt))
1410 (element-implicit-style-2 *document-language* document element))
1411
1412 (defun element-implicit-style-2 (document-language document element)
1413 (declare (ignore document))
1414 (eis document-language element))
1415
1416 (defun implicit-style/IMG (pt)
1417 (let ((res nil) x)
1418 (case (pt-attr/img-align pt :align nil)
1419 (:top (push (cons 'css:@vertical-align :top) res))
1420 (:bottom (push (cons 'css:@vertical-align :baseline) res)) ;wrong?
1421 (:middle (push (cons 'css:@vertical-align :img-middle) res))
1422 (:left (push (cons 'css:@float :left) res))
1423 (:right (push (cons 'css:@float :right) res)))
1424 (when (setf x (pt-attr/pixels pt :vspace nil))
1425 (push (cons 'css:@margin-top (cons :px x)) res)
1426 (push (cons 'css:@margin-bottom (cons :px x)) res))
1427 (when (setf x (pt-attr/pixels pt :hspace nil))
1428 (push (cons 'css:@margin-left (cons :px x)) res)
1429 (push (cons 'css:@margin-right (cons :px x)) res))
1430 ;;
1431 (when (setf x (pt-attr/pixels pt :border nil))
1432 (push (cons 'css:@border-left-width (cons :px x)) res)
1433 (push (cons 'css:@border-right-width (cons :px x)) res)
1434 (push (cons 'css:@border-top-width (cons :px x)) res)
1435 (push (cons 'css:@border-bottom-width (cons :px x)) res))
1436 ;;
1437 (when (setf x (pt-attr/length pt :width nil))
1438 (push (cons 'css:@width x) res))
1439 (when (setf x (pt-attr/length pt :height nil))
1440 (cond ((css:percentage-p x)
1441 ;; REC-html40-19980424, 13.7.1 says:
1442 ;; | [...] that lengths expressed as percentages are based on the
1443 ;; | [...] vertical space currently available
1444 ;; without defining that "vertical space currently available"
1445 (warn "No percentage values on IMG.height please."))
1446 (t
1447 (push (cons 'css:@height x) res))))
1448 res))
1449
1450 (defmacro define-simple-style (document-language (gi attr value) (css-attr css-value))
1451 `(define-style-mapping ,document-language (element (gi (eql ,gi)) (attr (eql ,attr)) (value (eql ,value)))
1452 (declare (ignore value))
1453 (add-style ',css-attr ',css-value)))
1454
1455 ;;;; IMG
1456
1457 (define-style-mapping html-4.0-document-language (element (gi (eql :IMG)) (attr (eql :ALIGN)) value)
1458 (case (pt-attr/img-align element :align nil)
1459 (:top (add-style 'css:@vertical-align :top))
1460 (:bottom (add-style 'css:@vertical-align :baseline)) ;wrong?
1461 (:middle (add-style 'css:@vertical-align :img-middle))
1462 (:left (add-style 'css:@float :left))
1463 (:right (add-style 'css:@float :right))))
1464
1465 (define-style-mapping html-4.0-document-language (element (gi (eql :IMG)) (attr (eql :VSPACE)) value)
1466 (let (x)
1467 (when (setf x (pt-attr/pixels element :vspace nil))
1468 (add-style 'css:@margin-top (cons :px x))
1469 (add-style 'css:@margin-bottom (cons :px x)))))
1470
1471 (define-style-mapping html-4.0-document-language (element (gi (eql :IMG)) (attr (eql :HSPACE)) value)
1472 (let (x)
1473 (when (setf x (pt-attr/pixels element :hspace nil))
1474 (add-style 'css:@margin-left (cons :px x))
1475 (add-style 'css:@margin-right (cons :px x)))))
1476
1477 (define-style-mapping html-4.0-document-language (element (gi (eql :IMG)) (attr (eql :BORDER)) value)
1478 (let (x)
1479 (when (setf x (pt-attr/pixels element :border nil))
1480 (add-style 'css:@border-left-width (cons :px x))
1481 (add-style 'css:@border-right-width (cons :px x))
1482 (add-style 'css:@border-top-width (cons :px x))
1483 (add-style 'css:@border-bottom-width (cons :px x)))))
1484
1485 (define-style-mapping html-4.0-document-language (element (gi (eql :IMG)) (attr (eql :WIDTH)) value)
1486 (let (x)
1487 (when (setf x (pt-attr/length element :width nil))
1488 (add-style 'css:@width x))))
1489
1490 (define-style-mapping html-4.0-document-language (element (gi (eql :IMG)) (attr (eql :HEIGHT)) value)
1491 (let (x)
1492 (when (setf x (pt-attr/length element :height nil))
1493 (cond ((css:percentage-p x)
1494 ;; REC-html40-19980424, 13.7.1 says:
1495 ;; | [...] that lengths expressed as percentages are based on the
1496 ;; | [...] vertical space currently available
1497 ;; without defining that "vertical space currently available"
1498 (warn "No percentage values on IMG.height please."))
1499 (t
1500 (add-style 'css:@height x))))))
1501
1502 ;;;; UL/OL/LI
1503
1504 (define-style-mapping html-4.0-document-language (element (gi (member :UL :OL :LI)) (attr (eql :TYPE)) value)
1505 (let ((x (pt-attr/list-style-type element :type)))
1506 (and x (add-style 'css:@list-style-type x))))
1507
1508 (define-style-mapping html-4.0-document-language (element (gi (member :UL :OL)) (attr (eql :COMPACT)) value)
1509 (when value (add-style 'css:@list-style-position :inset)))
1510
1511
1512 ;;;;
1513
1514 (define-style-mapping html-4.0-document-language (element
1515 (gi (member :P :DIV :H1 :H2 :H3 :H4 :H5 :H6))
1516 (attr (eql :align))
1517 value)
1518 (let ((x (pt-attr/align element)))
1519 (and x (add-style 'css:@text-align x))))
1520
1521 ;;;; BR
1522
1523 (define-style-mapping html-4.0-document-language (element (gi (eql :BR)) (attr (eql :clear)) value)
1524 (case (pt-attr/clear element)
1525 ((:left) (add-style 'css:@clear :left))
1526 ((:right) (add-style 'css:@clear :right))
1527 ((:all) (add-style 'css:@clear :both))))
1528
1529 ;;;; FONT
1530
1531 (define-style-mapping html-4.0-document-language (pt (gi (eql :FONT)))
1532 (let (sz)
1533 (when (pt-attr/color pt :color)
1534 (add-style 'css:@color (pt-attr/color pt :color)))
1535 (when (pt-attr/latin1 pt :face)
1536 (let ((f (split-by-if (lambda (x)
1537 (member x (list #\, #\space #\tab #\newline #\return)
1538 :test #'char=))
1539 (pt-attr/latin1 pt :face) :nuke-empty-p t)))
1540 (add-style 'css:@font-family f)))
1541 (when (setq sz (maybe-parse-integer (pt-attr/latin1 pt :size)))
1542 (cond ((or (char= (char (pt-attr/latin1 pt :size) 0) #\+)
1543 (char= (char (pt-attr/latin1 pt :size) 0) #\-))
1544 ;;(add-style 'css:@font-size (cons :% (* 100 (expt 7/6 sz))))
1545 (add-style 'css:@font-size (cons :px (* 14 (expt 7/6 sz)))))
1546 (t
1547 (add-style 'css:@font-size
1548 (cond ((<= sz 0) (cons :pt 6))
1549 ((= sz 1) (cons :pt 8))
1550 ((= sz 2) (cons :pt 10))
1551 ((= sz 3) (cons :pt 12))
1552 ((= sz 4) (cons :pt 14))
1553 ((= sz 5) (cons :pt 16))
1554 ((= sz 6) (cons :pt 18))
1555 ((>= sz 7) (cons :pt 20))))) )) ))
1556
1557 ;;;; TR
1558
1559 (define-style-mapping html-4.0-document-language (pt (gi (eql :TR)))
1560 (let (x)
1561 (when (member (setq x (pt-attr/cell-halign pt :align)) '(:left :center :right :justify))
1562 (add-style 'css:@text-align x))))
1563
1564 ;;;; HR
1565
1566 (define-style-mapping html-4.0-document-language (pt (gi (eql :HR)))
1567 (let ((noshade (pt-attr/boolean-flag pt :noshade))
1568 (size (pt-attr/pixels pt :size))
1569 (width (pt-attr/length pt :width))
1570 (align (pt-attr/align pt :align)))
1571 (when noshade
1572 (add-style 'css:@border-top-style :solid)
1573 (add-style 'css:@border-right-style :solid)
1574 (add-style 'css:@border-bottom-style :solid)
1575 (add-style 'css:@border-left-style :solid))
1576 (when width
1577 (add-style 'css:@width width))
1578 (when size
1579 (add-style 'css:@border-top-width (cons :px (floor size 2)))
1580 (add-style 'css:@border-bottom-width (cons :px (ceiling size 2))))
1581 (case align
1582 (:left
1583 (add-style 'css:@margin-left '(:px . 0))
1584 (add-style 'css:@margin-right :auto))
1585 (:right
1586 (add-style 'css:@margin-left :auto)
1587 (add-style 'css:@margin-right '(:px . 0)))
1588 (:center
1589 (add-style 'css:@margin-left :auto)
1590 (add-style 'css:@margin-right :auto))) ))
1591
1592 ;;;; TD/TH
1593
1594 (define-style-mapping html-4.0-document-language (pt (gi (member :TD :TH)))
1595 (let (x)
1596 (when (pt-attr/color (element-parent pt) :bgcolor)
1597 (add-style 'css:@background-color (pt-attr/color (element-parent pt) :bgcolor)))
1598 (when (pt-attr/color pt :bgcolor)
1599 (add-style 'css:@background-color (pt-attr/color pt :bgcolor)))
1600 (when (pt-attr/boolean-flag pt :nowrap)
1601 (progn;;unless (pt-attr* pt :width) ;emulate netscape behaviour.
1602 (add-style 'css:@white-space :nowrap)))
1603 (when (pt-attr/latin1 pt :background)
1604 (add-style 'css:@background-image (pt-effective-url-attr *document* pt :background)))
1605 ;; The valign attribute is inherited
1606 ;; ### we miss inheriting valign from the column and column-group elements
1607 ;; Which is not that easy to gather from here, since for that
1608 ;; we actually are forced to parse the table structure, which
1609 ;; we do in the CSS renderer already.
1610 (when (setq x (or (pt-attr/cell-valign pt :valign)
1611 (pt-attr/cell-valign (element-parent pt) :valign) ;row
1612 (pt-attr/cell-valign (element-parent (element-parent pt)) :valign) ;row-group
1613 (pt-attr/cell-valign (element-parent (element-parent (element-parent pt))) :valign) ;table
1614 :middle)) ;note that the default is not actually specified
1615 (add-style 'css:@vertical-align x))
1616 ;; ### we miss inheriting align from the column and column-group elements
1617 ;; (see note above)
1618 (when (member (setf x (or (pt-attr/cell-halign pt :align)
1619 (pt-attr/cell-halign (element-parent pt) :align) ;row
1620 (pt-attr/cell-halign (element-parent (element-parent pt)) :align) ;row-group
1621 (pt-attr/cell-halign (element-parent (element-parent (element-parent pt))) :align) ;table
1622 :left))
1623 '(:left :center :right :justify))
1624 (add-style 'css:@text-align x))
1625
1626 (when (setq x (pt-attr/length pt :width nil))
1627 (when (css:percentage-p x)
1628 (setf x (cons :% (cdr x))))
1629 (add-style 'css:@width x))
1630
1631 ;; ### we miss height.
1632
1633 (let ((table (element-parent (element-parent (element-parent pt)))))
1634 (when (and (eq (element-gi table) :table))
1635 (when (setq x (pt-attr/length table :cellpadding))
1636 (add-style 'css:@padding-top x)
1637 (add-style 'css:@padding-bottom x)
1638 (add-style 'css:@padding-left x)
1639 (add-style 'css:@padding-right x))
1640 ;; hmmm
1641 (add-style 'css:@border-top-width 0)
1642 (add-style 'css:@border-bottom-width 0)
1643 (add-style 'css:@border-left-width 0)
1644 (add-style 'css:@border-right-width 0)
1645 (add-style 'css:@border-top-style :none)
1646 (add-style 'css:@border-bottom-style :none)
1647 (add-style 'css:@border-left-style :none)
1648 (add-style 'css:@border-right-style :none)
1649 (when (equal '(:px . 0) (pt-attr/length table :border '(:px . 0)))
1650 (add-style 'css:@border-top-width 0)
1651 (add-style 'css:@border-bottom-width 0)
1652 (add-style 'css:@border-left-width 0)
1653 (add-style 'css:@border-right-width 0)) ))))
1654
1655 ;;;; TABLE
1656
1657 (define-style-mapping html-4.0-document-language (pt (gi (eql :TABLE)))
1658 (let (x)
1659 (when (eq (pt-attr/table.align pt :align nil) :left)
1660 (add-style 'css:@float :left))
1661 (when (eq (pt-attr/table.align pt :align nil) :right)
1662 (add-style 'css:@float :right))
1663 #||
1664 (when (eq (css:style- attr (element-parent pt) 'css:@text-align)
1665 :right)
1666 (add-style 'css:@margin-left :auto)
1667 (add-style 'css:@margin-right 0))
1668 ||#
1669 #||
1670 (when (or (eq (pt-attr/table.align pt :align nil) :center)
1671 (eq (css:style- attr (element-parent pt) 'css:@text-align)
1672 :center) )
1673 (add-style 'css:@margin-left :auto)
1674 (add-style 'css:@margin-right :auto))
1675 ||#
1676 (when (setq x (pt-attr/length pt :cellspacing nil))
1677 (add-style 'css::@border-spacing (list x x)))
1678 ;;
1679 (when (setq x (pt-attr/length pt :width nil))
1680 '(when (css:percentage-p x)
1681 (setf x (cons :canvas-h-percentage (cdr x))))
1682 (when (css:percentage-p x)
1683 (setf x (cons :% (cdr x))))
1684 (add-style 'css:@width x))
1685 (when (setq x (pt-attr/color pt :bgcolor))
1686 (add-style 'css:@background-color x))))
1687
1688 ;;;; BODY
1689
1690 (define-style-mapping html-4.0-document-language (pt (gi (eql :BODY)))
1691 (let (x)
1692 (when (pt-attr/latin1 pt :background)
1693 (add-style 'css:@background-image (pt-effective-url-attr *document* pt :background)))
1694 (when (setq x (pt-attr/color pt :bgcolor))
1695 (add-style 'css:@background-color x))
1696 (when (setq x (pt-attr/color pt :text))
1697 (add-style 'css:@color x))))
1698
1699 ;;;; THEAD/TBODY/TFOOT
1700
1701 (define-style-mapping html-4.0-document-language (pt (gi (member :THEAD :TBODY :TFOOT)))
1702 (let (x)
1703 ;; Note: align=justify is in the HTML spec but utter nonsense
1704 (when (member (setq x (pt-attr/cell-halign pt :align))
1705 '(:left :center :right :justify))
1706 (add-style 'css:@text-align x))))
1707
1708 ;;;; A
1709
1710 (define-style-mapping html-4.0-document-language (pt (gi (eql :A)))
1711 (let (x)
1712 ;; ### Now, this is crude!
1713 (when (and (pt-attr/latin1 pt :href)
1714 (setq x (pt-body-element pt))
1715 (setq x (pt-attr/color x :link)))
1716 (add-style 'css:@color x))))
1717
1718 ;;;; INPUT
1719
1720 (define-style-mapping html-4.0-document-language (pt (gi (eql :INPUT)))
1721 (when (eq :hidden (pt-attr/input-type pt :type))
1722 (add-style 'css:@display :none))
1723 (when (eq :image (pt-attr/input-type pt :type))
1724 ;; ### - netscape 4 doesn't do this.
1725 (when (pt-attr/pixels pt :size)
1726 (add-style 'css:@width (cons :px (pt-attr/pixels pt :size))))))
1727
1728 ;;;; CAPTION
1729
HTML parser written in Common Lisp