xpath.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
   2
   3 ;;; Copyright (c) 2007 Ivan Shvedunov. All rights reserved.
   4 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9 ;;;
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12 ;;;
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17 ;;;
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
  30
  31 (in-package :cxml-stp-impl)
  32
  33 (defun vector->pipe (vector &optional (start 0))
  34   (if (>= start (length vector))
  35       nil
  36       (xpath::make-pipe (elt vector start)
  37                         (vector->pipe vector (1+ start)))))
  38
  39
  40 ;;;; XPath protocol implementation for STP
  41
  42 ;;;; FIXME: xpath-protocol:child-pipe destructively normalizes the STP tree!
  43
  44 (define-default-method xpath-protocol:local-name ((node stp:node))
  45   (local-name node))
  46
  47 (define-default-method xpath-protocol:namespace-prefix ((node stp:node))
  48   (namespace-prefix node))
  49
  50 (define-default-method xpath-protocol:parent-node ((node stp:node))
  51   (stp:parent node))
  52
  53 (define-default-method xpath-protocol:namespace-uri ((node stp:node))
  54   (namespace-uri node))
  55
  56 (define-default-method xpath-protocol:qualified-name ((node stp:node))
  57   (qualified-name node))
  58
  59 (define-default-method xpath-protocol:base-uri ((node stp:element))
  60   (stp:base-uri node))
  61
  62 (define-default-method xpath-protocol:base-uri ((node stp:document))
  63   (stp:base-uri node))
  64
  65 (define-default-method xpath-protocol:base-uri ((node stp:node))
  66   nil)
  67
  68 (define-default-method xpath-protocol:child-pipe ((node stp:node))
  69   nil)
  70
  71 (define-default-method xpath-protocol:child-pipe ((node stp:document))
  72   (filter-children (alexandria:of-type '(not document-type)) node))
  73
  74 (define-default-method xpath-protocol:child-pipe ((node stp:element))
  75   (normalize-text-nodes! node)
  76   (vector->pipe (%children node)))
  77
  78 (define-default-method xpath-protocol:attribute-pipe ((node stp:node))
  79   nil)
  80
  81 (define-default-method xpath-protocol:attribute-pipe ((node stp:element))
  82   (list-attributes node))
  83
  84 (define-default-method xpath-protocol:namespace-pipe ((node stp:node))
  85   (when (stp:parent node)
  86     (xpath-protocol:namespace-pipe (stp:parent node))))
  87
  88 (defstruct (stp-namespace
  89              (:constructor make-stp-namespace (parent prefix uri)))
  90   parent
  91   prefix
  92   uri)
  93
  94 (define-default-method xpath-protocol:node-equal
  95     ((a stp-namespace) (b stp-namespace))
  96   (and (eq (stp-namespace-parent a) (stp-namespace-parent b))
  97        (equal (stp-namespace-prefix a) (stp-namespace-prefix b))))
  98
  99 (define-default-method xpath-protocol:hash-key
 100     ((node stp-namespace))
 101   (cons (stp-namespace-parent node) (stp-namespace-prefix node)))
 102
 103 (define-default-method xpath-protocol:base-uri ((node stp-namespace))
 104   nil)
 105
 106 (define-default-method xpath-protocol:node-p ((node stp-namespace))
 107   t)
 108
 109 (define-default-method xpath-protocol:child-pipe ((node stp-namespace)) nil)
 110 (define-default-method xpath-protocol:attribute-pipe ((node stp-namespace)) nil)
 111 (define-default-method xpath-protocol:namespace-pipe ((node stp-namespace)) nil)
 112
 113 (define-default-method xpath-protocol:parent-node ((node stp-namespace))
 114   (stp-namespace-parent node))
 115 (define-default-method xpath-protocol:local-name ((node stp-namespace))
 116   (stp-namespace-prefix node))
 117 (define-default-method xpath-protocol:qualified-name ((node stp-namespace))
 118   (stp-namespace-prefix node))
 119 (define-default-method xpath-protocol:namespace-uri ((node stp-namespace))
 120   "")
 121
 122 (define-default-method xpath-protocol:namespace-pipe
 123     ((original-node stp:element))
 124   (let ((node original-node)
 125         (table (make-hash-table :test 'equal))
 126         (current '()))
 127     (labels ((yield (prefix uri)
 128                (unless (gethash prefix table)
 129                  (let ((nsnode (make-stp-namespace original-node prefix uri)))
 130                    (setf (gethash prefix table) nsnode)
 131                    (push nsnode current))))
 132              (iterate ()
 133                (if current
 134                    (cons (pop current) #'iterate)
 135                    (recurse)))
 136              (recurse ()
 137                (etypecase node
 138                  (null)
 139                  (stp:element
 140                    (let ((parent (stp:parent node)))
 141                      (map-extra-namespaces #'yield node)
 142                      (unless (and (zerop (length (%namespace-prefix node)))
 143                                   (zerop (length (%namespace-uri node)))
 144                                   (or (typep parent 'stp:document)
 145                                       (zerop
 146                                        (length
 147                                         (stp:find-namespace "" parent)))))
 148                        (yield (%namespace-prefix node)
 149                               (%namespace-uri node)))
 150                      (dolist (a (%attributes node))
 151                        (when (plusp (length (namespace-prefix a)))
 152                          (yield (namespace-prefix a) (namespace-uri a))))
 153                      (setf node parent))
 154                    (iterate))
 155                  (stp:document
 156                   (yield "xml" "http://www.w3.org/XML/1998/namespace")
 157                   #+nil (yield "xmlns" "http://www.w3.org/2000/xmlns/")
 158                   (setf node nil)
 159                   (iterate)))))
 160       (recurse))))
 161
 162 (define-default-method xpath-protocol:node-text ((node node))
 163   (string-value node))
 164
 165 (define-default-method xpath-protocol:node-text ((node stp-namespace))
 166   (stp-namespace-uri node))
 167
 168 (define-default-method xpath-protocol:node-p ((node node))
 169   t)
 170
 171 (define-default-method xpath-protocol:node-type-p ((node node) type)
 172   (declare (ignore type))
 173   nil)
 174
 175 (define-default-method xpath-protocol:node-type-p ((node stp-namespace) type)
 176   (declare (ignore type))
 177   nil)
 178
 179 (macrolet ((deftypemapping (class keyword)
 180              `(define-default-method xpath-protocol:node-type-p
 181                   ((node ,class) (type (eql ,keyword)))
 182                 t)))
 183   (deftypemapping document :document)
 184   (deftypemapping comment :comment)
 185   (deftypemapping processing-instruction :processing-instruction)
 186   (deftypemapping text :text)
 187   (deftypemapping attribute :attribute)
 188   (deftypemapping element :element)
 189   (deftypemapping stp-namespace :namespace))
 190
 191 (defun normalize-text-nodes! (node)
 192   (when (typep node 'stp:parent-node)
 193     (let ((children (%children node)))
 194       (when (and children (loop
 195                              for child across children
 196                              for a = nil then b
 197                              for b = (typep child 'text)
 198                              thereis
 199                                (and b (or a
 200                                           (zerop (length (stp:data child)))))))
 201         (let ((previous nil)
 202               (results '()))
 203           (stp:do-children (child node)
 204             (cond
 205               ((not (typep child 'stp:text))
 206                (when previous
 207                  (push (stp:make-text
 208                         (apply #'concatenate 'string (nreverse previous)))
 209                        results)
 210                  (setf (%parent (car results)) node)
 211                  (setf previous nil))
 212                (push child results))
 213               (previous
 214                (push (stp:data child) previous))
 215               ((zerop (length (stp:data child))))
 216               (t
 217                (setf previous (list (stp:data child))))))
 218           (when previous
 219             (push (stp:make-text
 220                    (apply #'concatenate 'string (nreverse previous)))
 221                   results)
 222             (setf (%parent (car results)) node))
 223           (setf (cxml-stp-impl::%children node)
 224                 (let ((n (length results)))
 225                   (make-array n
 226                               :fill-pointer n
 227                               :initial-contents (nreverse results)))))))))
 228
 229 (define-default-method xpath-protocol:get-element-by-id ((node stp:node) id)
 230   (let* ((document (stp:document node))
 231          (dtd (when (stp:document-type document)
 232                 (stp:dtd (stp:document-type document)))))
 233     (when dtd
 234       (block nil
 235         (flet ((test (node)
 236                  (when (typep node 'stp:element)
 237                    (let ((elmdef
 238                           (cxml::find-element (stp:qualified-name node) dtd)))
 239                      (when elmdef
 240                        (dolist (attdef (cxml::elmdef-attributes elmdef))
 241                          (when (eq :ID (cxml::attdef-type attdef))
 242                            (let* ((name (cxml::attdef-name attdef))
 243                                   (value (stp:attribute-value node name)))
 244                              (when (and value (equal value id))
 245                                (return node))))))))))
 246           (find-recursively-if #'test document))))))
 247
 248 (define-default-method xpath-protocol:unparsed-entity-uri
 249     ((node stp:node) name)
 250   (let ((doctype (stp:document-type (stp:document node))))
 251     (when doctype
 252       (let ((dtd (stp:dtd doctype)))
 253         (when dtd
 254           (let ((entdef (cdr (gethash name (cxml::dtd-gentities dtd)))))
 255             (when (typep entdef 'cxml::external-entdef)
 256               (let ((uri (cxml::extid-system (cxml::entdef-extid entdef))))
 257                 (when uri
 258                   (puri:render-uri uri nil))))))))))
 259
 260 (define-default-method xpath-protocol:local-name ((node stp:text)) "")
 261
 262 (define-default-method xpath-protocol:namespace-prefix ((node stp:text)) "")
 263
 264 (define-default-method xpath-protocol:namespace-uri ((node stp:text)) "")
 265
 266 (define-default-method xpath-protocol:qualified-name ((node stp:text)) "")
 267
 268 (define-default-method xpath-protocol:local-name ((node stp:comment)) "")
 269
 270 (define-default-method xpath-protocol:namespace-prefix ((node stp:comment)) "")
 271
 272 (define-default-method xpath-protocol:namespace-uri ((node stp:comment)) "")
 273
 274 (define-default-method xpath-protocol:qualified-name
 275     ((node stp:comment))
 276   "")
 277
 278 (define-default-method xpath-protocol:namespace-prefix
 279     ((node stp:processing-instruction))
 280   "")
 281
 282 (define-default-method xpath-protocol:local-name
 283     ((node stp:processing-instruction))
 284   (stp:target node))
 285
 286 (define-default-method xpath-protocol:qualified-name
 287     ((node stp:processing-instruction))
 288   (stp:target node))
 289
 290 (define-default-method xpath-protocol:namespace-uri
 291     ((node stp:processing-instruction))
 292   "")
 293
 294 (define-default-method xpath-protocol:namespace-uri
 295     ((node stp:document))
 296   "")
 297
 298 (define-default-method xpath-protocol:namespace-prefix ((node stp:document))
 299   "")
 300
 301 (define-default-method xpath-protocol:qualified-name ((node stp:document)) "")
 302
 303 (define-default-method xpath-protocol:local-name ((node stp:document)) "")
 304
 305 (define-default-method xpath-protocol:processing-instruction-target
 306     ((node stp:node))
 307   node)
 308
 309 (define-default-method xpath-protocol:processing-instruction-target
 310     ((node stp:processing-instruction))
 311   (stp:target node))
 312
 313 (defun run-xpath-tests ()
 314   (let ((xpath::*dom-builder* (stp:make-builder))
 315         (xpath::*document-element* #'stp:document-element))
 316     (xpath::run-all-tests)))