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:base-uri ((node stp-namespace))
  95   nil)
  96
  97 (define-default-method xpath-protocol:node-p ((node stp-namespace))
  98   t)
  99
 100 (define-default-method xpath-protocol:child-pipe ((node stp-namespace)) nil)
 101 (define-default-method xpath-protocol:attribute-pipe ((node stp-namespace)) nil)
 102 (define-default-method xpath-protocol:namespace-pipe ((node stp-namespace)) nil)
 103
 104 (define-default-method xpath-protocol:parent-node ((node stp-namespace))
 105   (stp-namespace-parent node))
 106 (define-default-method xpath-protocol:local-name ((node stp-namespace))
 107   (stp-namespace-prefix node))
 108 (define-default-method xpath-protocol:qualified-name ((node stp-namespace))
 109   (stp-namespace-prefix node))
 110 (define-default-method xpath-protocol:namespace-uri ((node stp-namespace))
 111   "")
 112
 113 (define-default-method xpath-protocol:namespace-pipe ((node stp:element))
 114   (let ((node node)
 115         (table (make-hash-table :test 'equal))
 116         (current '()))
 117     (labels ((yield (prefix uri)
 118                (unless (gethash prefix table)
 119                  (let ((nsnode (make-stp-namespace node prefix uri)))
 120                    (setf (gethash prefix table) nsnode)
 121                    (push nsnode current))))
 122              (iterate ()
 123                (if current
 124                    (cons (pop current) #'iterate)
 125                    (recurse)))
 126              (recurse ()
 127                (etypecase node
 128                  (null)
 129                  (stp:element
 130                    (let ((parent (stp:parent node)))
 131                      (map-extra-namespaces #'yield node)
 132                      (unless (and (zerop (length (%namespace-prefix node)))
 133                                   (zerop (length (%namespace-uri node)))
 134                                   (or (typep parent 'stp:document)
 135                                       (zerop
 136                                        (length
 137                                         (stp:find-namespace "" parent)))))
 138                        (yield (%namespace-prefix node)
 139                               (%namespace-uri node)))
 140                      (dolist (a (%attributes node))
 141                        (when (plusp (length (namespace-prefix a)))
 142                          (yield (namespace-prefix a) (namespace-uri a))))
 143                      (setf node parent))
 144                    (iterate))
 145                  (stp:document
 146                   (yield "xml" "http://www.w3.org/XML/1998/namespace")
 147                   #+nil (yield "xmlns" "http://www.w3.org/2000/xmlns/")
 148                   (setf node nil)
 149                   (iterate)))))
 150       (recurse))))
 151
 152 (define-default-method xpath-protocol:node-text ((node node))
 153   (string-value node))
 154
 155 (define-default-method xpath-protocol:node-text ((node stp-namespace))
 156   (stp-namespace-uri node))
 157
 158 (define-default-method xpath-protocol:node-p ((node node))
 159   t)
 160
 161 (define-default-method xpath-protocol:node-type-p ((node node) type)
 162   (declare (ignore type))
 163   nil)
 164
 165 (define-default-method xpath-protocol:node-type-p ((node stp-namespace) type)
 166   (declare (ignore type))
 167   nil)
 168
 169 (macrolet ((deftypemapping (class keyword)
 170              `(define-default-method xpath-protocol:node-type-p
 171                   ((node ,class) (type (eql ,keyword)))
 172                 t)))
 173   (deftypemapping document :document)
 174   (deftypemapping comment :comment)
 175   (deftypemapping processing-instruction :processing-instruction)
 176   (deftypemapping text :text)
 177   (deftypemapping attribute :attribute)
 178   (deftypemapping element :element)
 179   (deftypemapping stp-namespace :namespace))
 180
 181 (defun normalize-text-nodes! (node)
 182   (when (typep node 'stp:parent-node)
 183     (let ((children (%children node)))
 184       (when (loop
 185                for child across children
 186                for a = nil then b
 187                for b = (typep child 'text)
 188                thereis (and b (or a (zerop (length (stp:data child))))))
 189         (let ((previous nil)
 190               (results '()))
 191           (stp:do-children (child node)
 192             (cond
 193               ((not (typep child 'stp:text))
 194                (when previous
 195                  (push (stp:make-text
 196                         (apply #'concatenate 'string (nreverse previous)))
 197                        results)
 198                  (setf (%parent (car results)) node)
 199                  (setf previous nil))
 200                (push child results))
 201               (previous
 202                (push (stp:data child) previous))
 203               ((zerop (length (stp:data child))))
 204               (t
 205                (setf previous (list (stp:data child))))))
 206           (when previous
 207             (push (stp:make-text
 208                    (apply #'concatenate 'string (nreverse previous)))
 209                   results)
 210             (setf (%parent (car results)) node))
 211           (setf (cxml-stp-impl::%children node)
 212                 (let ((n (length results)))
 213                   (make-array n
 214                               :fill-pointer n
 215                               :initial-contents (nreverse results)))))))))
 216
 217 (define-default-method xpath-protocol:get-element-by-id ((node stp:node) id)
 218   (let* ((document (stp:document node))
 219          (dtd (when (stp:document-type document)
 220                 (stp:dtd (stp:document-type document)))))
 221     (when dtd
 222       (block nil
 223         (flet ((test (node)
 224                  (when (typep node 'stp:element)
 225                    (let ((elmdef
 226                           (cxml::find-element (stp:qualified-name node) dtd)))
 227                      (when elmdef
 228                        (dolist (attdef (cxml::elmdef-attributes elmdef))
 229                          (when (eq :ID (cxml::attdef-type attdef))
 230                            (let* ((name (cxml::attdef-name attdef))
 231                                   (value (stp:attribute-value node name)))
 232                              (when (and value (equal value id))
 233                                (return node))))))))))
 234           (find-recursively-if #'test document))))))
 235
 236 (define-default-method xpath-protocol:unparsed-entity-uri
 237     ((node stp:node) name)
 238   (let ((doctype (stp:document-type (stp:document node))))
 239     (when doctype
 240       (let ((dtd (stp:dtd doctype)))
 241         (when dtd
 242           (let ((entdef (cdr (gethash name (cxml::dtd-gentities dtd)))))
 243             (when (typep entdef 'cxml::external-entdef)
 244               (let ((uri (cxml::extid-system (cxml::entdef-extid entdef))))
 245                 (when uri
 246                   (puri:render-uri uri nil))))))))))
 247
 248 (define-default-method xpath-protocol:local-name ((node stp:text)) "")
 249
 250 (define-default-method xpath-protocol:namespace-prefix ((node stp:text)) "")
 251
 252 (define-default-method xpath-protocol:namespace-uri ((node stp:text)) "")
 253
 254 (define-default-method xpath-protocol:qualified-name ((node stp:text)) "")
 255
 256 (define-default-method xpath-protocol:local-name ((node stp:comment)) "")
 257
 258 (define-default-method xpath-protocol:namespace-prefix ((node stp:comment)) "")
 259
 260 (define-default-method xpath-protocol:namespace-uri ((node stp:comment)) "")
 261
 262 (define-default-method xpath-protocol:qualified-name
 263     ((node stp:comment))
 264   "")
 265
 266 (define-default-method xpath-protocol:namespace-prefix
 267     ((node stp:processing-instruction))
 268   "")
 269
 270 (define-default-method xpath-protocol:local-name
 271     ((node stp:processing-instruction))
 272   (stp:target node))
 273
 274 (define-default-method xpath-protocol:qualified-name
 275     ((node stp:processing-instruction))
 276   (stp:target node))
 277
 278 (define-default-method xpath-protocol:namespace-uri
 279     ((node stp:processing-instruction))
 280   "")
 281
 282 (define-default-method xpath-protocol:namespace-prefix ((node stp:document))
 283   "")
 284
 285 (define-default-method xpath-protocol:qualified-name ((node stp:document)) "")
 286
 287 (define-default-method xpath-protocol:local-name ((node stp:document)) "")
 288
 289 (define-default-method xpath-protocol:processing-instruction-target
 290     ((node stp:node))
 291   node)
 292
 293 (define-default-method xpath-protocol:processing-instruction-target
 294     ((node stp:processing-instruction))
 295   (stp:target node))
 296
 297 (defun run-xpath-tests ()
 298   (let ((xpath::*dom-builder* (stp:make-builder))
 299         (xpath::*document-element* #'stp:document-element))
 300     (xpath::run-all-tests)))