src/css/css-support.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CSS; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: [temporary] parse tree support for the css stuff
   4 ;;;   Created: 2002-08-07
   5 ;;;    Author: Gilbert Baumann <gilbert@base-engineering.com>
   6 ;;;   License: MIT style (see below)
   7 ;;; ---------------------------------------------------------------------------
   8 ;;;  (c) copyright 2002 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
  30 (in-package :css)
  31
  32 (defun element-has-class-p (element class)
  33   (class-eq class (element-css-class element)))
  34
  35 (defun element-has-id-p (element id)
  36   (id-eq id (element-css-id element)))
  37
  38 ;;; hmmm
  39
  40 (defun intern-attribute-name (papyrus)
  41   ;; XXX hack
  42   (intern (string-upcase (if (stringp papyrus)
  43                              papyrus
  44                              (papyrus-string papyrus)))
  45           :keyword))
  46
  47 (defun intern-gi (string)
  48   (intern-attribute-name string))
  49
  50 (defun css2-class-match-p (string element)
  51   (attribute-contains-p element #.(map 'vector #'char-code "CLASS") string t))
  52
  53 (defun css2-class-match-p (string element)
  54   ;; XXX we should search for occurence
  55   (equalp string (closure-protocol:element-css-class element)))
  56 ;;   (attribute-contains-p element #.(map 'vector #'char-code "CLASS") string t))
  57
  58 (defun css2-id-match-p (string element)
  59   (attribute-equal-p element #.(map 'vector #'char-code "ID") string t))
  60
  61 (defun css2-gi-match-p (string element)
  62   (eq (element-gi element) string))
  63
  64 ;; We probably want
  65 ;;   intern-gi    document-language id-rod
  66 ;;   intern-class document-language class-rod
  67 ;;   intern-id    document-language class-id
  68 ;; and
  69 ;;   element-css-gi element
  70 ;;   element-css-classes element
  71 ;;   element-css-id element
  72 ;;
  73
  74 (defun class-eq (x y)
  75   (equalp x y))
  76
  77 (defun id-eq (x y)
  78   (equalp x y))
  79
  80 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  81
  82 ;; we still need to cover these:
  83 ;;
  84 ;; css-parse.lisp:                      (renderer::maybe-parse-style-sheet-from-url
  85 ;; css-setup.lisp: ((interpret-length device value pt (r2::pt-font-size pt)))))
  86 ;; css-setup.lisp:                 (*dpi* (r2::device-dpi *device*))
  87 ;; css-setup.lisp:                 (dpi (r2::device-dpi *device*)))
  88 ;; css-setup.lisp:              (round (* a (r2::device-canvas-width device))
  89 ;; css-setup.lisp:              (round (* a (r2::device-canvas-height device))