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 (defmethod xpath-protocol:local-name ((node stp:node))
  45   (local-name node))
  46
  47 (defmethod xpath-protocol:namespace-prefix ((node stp:node))
  48   (namespace-prefix node))
  49
  50 (defmethod xpath-protocol:parent-node ((node stp:node))
  51   (stp:parent node))
  52
  53 (defmethod xpath-protocol:namespace-uri ((node stp:node))
  54   (namespace-uri node))
  55
  56 (defmethod xpath-protocol:qualified-name ((node stp:node))
  57   (qualified-name node))
  58
  59 (defmethod xpath-protocol:child-pipe ((node stp:node))
  60   nil)
  61
  62 (defmethod xpath-protocol:child-pipe ((node stp:parent-node))
  63   (normalize-text-nodes! node)
  64   (vector->pipe (%children node)))
  65
  66 (defmethod xpath-protocol:attribute-pipe ((node stp:node))
  67   nil)
  68
  69 (defmethod xpath-protocol:attribute-pipe ((node stp:element))
  70   (list-attributes node))
  71
  72 (defmethod xpath-protocol:namespace-pipe ((node stp:node))
  73   (when (stp:parent node)
  74     (xpath-protocol:namespace-pipe (stp:parent node))))
  75
  76 (defstruct (stp-namespace
  77              (:constructor make-stp-namespace (parent prefix uri)))
  78   parent
  79   prefix
  80   uri)
  81
  82 (defmethod xpath-protocol:child-pipe ((node stp-namespace)) nil)
  83 (defmethod xpath-protocol:attribute-pipe ((node stp-namespace)) nil)
  84 (defmethod xpath-protocol:namespace-pipe ((node stp-namespace)) nil)
  85
  86 (defmethod xpath-protocol:parent-node ((node stp-namespace))
  87   (stp-namespace-parent node))
  88 (defmethod xpath-protocol:local-name ((node stp-namespace))
  89   (stp-namespace-prefix node))
  90 (defmethod xpath-protocol:qualified-name ((node stp-namespace))
  91   (stp-namespace-prefix node))
  92 (defmethod xpath-protocol:namespace-uri ((node stp-namespace))
  93   (stp-namespace-uri node))
  94
  95 (defmethod xpath-protocol:namespace-pipe ((node stp:element))
  96   (let ((node node)
  97         (table (make-hash-table :test 'equal))
  98         (current '()))
  99     (labels ((yield (prefix uri)
 100                (unless (gethash prefix table)
 101                  (let ((nsnode (make-stp-namespace node prefix uri)))
 102                    (setf (gethash prefix table) nsnode)
 103                    (push nsnode current))))
 104              (iterate ()
 105                (if current
 106                    (cons (pop current) #'iterate)
 107                    (recurse)))
 108              (recurse ()
 109                (etypecase node
 110                  (null)
 111                  (element
 112                      (map-extra-namespaces #'yield node)
 113                    (yield (%namespace-prefix node)
 114                           (%namespace-uri node))
 115                    (dolist (a (%attributes node))
 116                      (when (plusp (length (namespace-prefix a)))
 117                        (yield (namespace-prefix a) (namespace-uri a))))
 118                    (setf node (stp:parent node))
 119                    (iterate))
 120                  (document
 121                   (yield "xml" "http://www.w3.org/XML/1998/namespace")
 122                   (yield "xmlns" "http://www.w3.org/2000/xmlns/")
 123                   (setf node nil)
 124                   (iterate)))))
 125       (recurse))))
 126
 127 (defmethod xpath-protocol:string-value ((node node))
 128   (string-value node))
 129
 130 (defmethod xpath-protocol:node-type-p ((node node) type)
 131   (declare (ignore type))
 132   nil)
 133
 134 (defmethod xpath-protocol:node-type-p ((node stp-namespace) type)
 135   (declare (ignore type))
 136   nil)
 137
 138 (macrolet ((deftypemapping (class keyword)
 139              `(defmethod xpath-protocol:node-type-p
 140                   ((node ,class) (type (eql ,keyword)))
 141                 t)))
 142   (deftypemapping comment :comment)
 143   (deftypemapping processing-instruction :processing-instruction)
 144   (deftypemapping text :text)
 145   (deftypemapping attribute :attribute)
 146   (deftypemapping element :element)
 147   (deftypemapping stp-namespace :namespace))
 148
 149 (defun normalize-text-nodes! (node)
 150   (when (typep node 'stp:parent-node)
 151     (let ((children (%children node)))
 152       (when (loop
 153                for child across children
 154                for a = nil then b
 155                for b = (typep child 'text)
 156                thereis (and b (or a (zerop (length (stp:data child))))))
 157         (let ((previous nil)
 158               (results '()))
 159           (stp:do-children (child node)
 160             (cond
 161               ((not (typep child 'stp:text))
 162                (when previous
 163                  (push (stp:make-text
 164                         (apply #'concatenate 'string (nreverse previous)))
 165                        results)
 166                  (setf (%parent (car results)) node)
 167                  (setf previous nil))
 168                (push child results))
 169               (previous
 170                (push (stp:data child) previous))
 171               ((zerop (length (stp:data child))))
 172               (t
 173                (setf previous (list (stp:data child))))))
 174           (when previous
 175             (push (stp:make-text
 176                    (apply #'concatenate 'string (nreverse previous)))
 177                   results)
 178             (setf (%parent (car results)) node))
 179           (setf (cxml-stp-impl::%children node)
 180                 (let ((n (length results)))
 181                   (make-array n
 182                               :fill-pointer n
 183                               :initial-contents (nreverse results)))))))))