parent-node.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
   2
   3 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
   4
   5 ;;; Redistribution and use in source and binary forms, with or without
   6 ;;; modification, are permitted provided that the following conditions
   7 ;;; are met:
   8 ;;;
   9 ;;;   * Redistributions of source code must retain the above copyright
  10 ;;;     notice, this list of conditions and the following disclaimer.
  11 ;;;
  12 ;;;   * Redistributions in binary form must reproduce the above
  13 ;;;     copyright notice, this list of conditions and the following
  14 ;;;     disclaimer in the documentation and/or other materials
  15 ;;;     provided with the distribution.
  16 ;;;
  17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  20 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28
  29 (in-package :cxml-stp-impl)
  30
  31 #+sbcl
  32 (declaim (optimize (debug 2)))
  33
  34
  35 ;;;; Class PARENT-NODE
  36
  37 ;;; base URI
  38
  39 (defgeneric (setf base-uri) (newval node)
  40   (:documentation
  41    "@arg[newval]{string, the new base URI}
  42     @arg[node]{an @class{parent-node}}
  43     @return{the new base URI}
  44     @short{Sets the node's base URI.}"))
  45
  46 (defgeneric %base-uri (node))
  47 (defmethod %base-uri ((node node)) (or (slot-value node '%base-uri) ""))
  48 (defmethod (setf %base-uri) (newval (node node))
  49   #+(or)
  50   (when (and (plusp (length newval))
  51              *check-uri-syntax*
  52              (not (search "://" newval)))
  53     (warn "base URI does not look like an absolute URL: ~S" newval))
  54   (setf (slot-value node '%base-uri) (or newval "")))
  55
  56 (defun maybe-fill-in-base-uri (removed-child)
  57   (when (typep removed-child 'element)
  58     (fill-in-base-uri removed-child)))
  59
  60 (defun fill-in-base-uri (removed-child)
  61   (setf (%base-uri removed-child)
  62         (find-base-uri removed-child)))
  63
  64 (defun find-base-uri (node)
  65   (loop
  66      for n = node then parent
  67      for parent = (parent n)
  68      for uri = (%base-uri n)
  69      while (and (equal uri "") parent)
  70      finally (return uri)))
  71
  72 (defgeneric (setf base-uri) (newval node))
  73
  74
  75 ;;;; Children
  76
  77
  78 ;;; CHILDREN-related methods on NODE
  79
  80 (defmethod map-children (result-type fn (node parent-node))
  81   (map result-type fn (%children node)))
  82
  83
  84 ;;; CHILDREN-related convenience functions
  85
  86 (defun prepend-child (parent child)
  87   "@arg[parent]{a @class{parent-node}}
  88    @arg[child]{a @class{node}}
  89    @short{Adds @code{child} as the first child of @code{parent}, if allowed.}
  90
  91    Signals an error if the child already has a parent."
  92   (insert-child parent child 0))
  93
  94 (defun append-child (parent child)
  95   "@arg[child]{a @class{node}}
  96    @arg[parent]{a @class{parent-node}}
  97    Adds @code{child} as the last child of @code{parent}, if allowed.
  98
  99    Signals an error if the child already has a parent."
 100   (insert-child parent child (length (%children parent))))
 101
 102 (defun delete-nth-child (idx parent)
 103   "@arg[idx]{a non-negative integer}
 104    @arg[parent]{a @class{parent-node}}
 105    Removes child @code{idx} of @code{parent}, if allowed."
 106   (let ((old (%children parent)))
 107     (prog1
 108         (elt old idx)
 109       (delete-child-if (constantly t) parent :start idx :count 1))))
 110
 111 (defun delete-child (child parent &key from-end test start end count key)
 112   "@arg[child]{an object}
 113    @arg[parent]{a @class{node}}
 114    @arg[from-end]{a generalized boolead}
 115    @arg[start, end]{bounding index designators for @code{parent}'s child list}
 116    @arg[key]{a designator for a function of one argument, or nil}
 117    @arg[test]{a designator for a function of two arguments, or nil}
 118    @return{a @class{node} or nil}
 119    Searches for a child node of @code{parent} that satisfies the @code{test}
 120    and removes it, if allowed."
 121   (setf test (or test #'eql))
 122   (delete-child-if (lambda (c) (funcall test child c))
 123                    parent
 124                    :from-end from-end
 125                    :start start
 126                    :end end
 127                    :count count
 128                    :key key))
 129
 130 (defun insert-child-before (parent new-child ref-child)
 131   "@arg[parent]{a @class{parent-node}}
 132    @arg[new-child]{a @class{node}}
 133    @arg[ref-child]{a @class{node}}
 134    @short{Adds @code{new-child} before @code{ref-child} as a child node of
 135    @code{parent}, if allowed.}
 136
 137    Signals an error if the child already has a parent.
 138
 139    Also signals an error if @code{ref-child} is not a child of @code{parent}."
 140   (let ((idx (child-position ref-child parent)))
 141     (unless idx
 142       (stp-error "referenced child not found: ~A" ref-child))
 143     (insert-child parent new-child idx)))
 144
 145 (defun insert-child-after (parent new-child ref-child)
 146   "@arg[parent]{a @class{parent-node}}
 147    @arg[new-child]{a @class{node}}
 148    @arg[ref-child]{a @class{node}}
 149    @short{Adds @code{new-child} after @code{ref-child} as a child node of
 150    @code{parent}, if allowed.}
 151
 152    Signals an error if the child already has a parent.
 153
 154    Also signals an error if @code{ref-child} is not a child of @code{parent}."
 155   (let ((idx (child-position ref-child parent)))
 156     (unless idx
 157       (stp-error "referenced child not found: ~A" ref-child))
 158     (insert-child parent new-child (1+ idx))))
 159
 160 ;;; CHILDREN-related functions we define
 161
 162 (defgeneric insert-child (parent child position)
 163   (:documentation
 164    "@arg[parent]{a @class{parent-node}}
 165     @arg[child]{a @class{node}}
 166     @arg[position]{a non-negative integer}
 167     @short{Adds @code{child} as a child node of @code{parent} at position
 168       @code{position} if allowed.}
 169
 170    Signals an error if the new child already has a parent.
 171
 172    Also signals an error if @code{position} is greater than the number
 173    @code{parent}'s child nodes."))
 174
 175 (defgeneric delete-child-if
 176     (predicate parent &rest args &key from-end start end count key)
 177   (:documentation
 178    "@arg[predicate]{a designator for a function of one argument that returns
 179      a generalized boolean}
 180     @arg[parent]{a @class{node}}
 181     @arg[from-end]{a generalized boolead}
 182     @arg[start, end]{bounding index designators for @code{parent}'s child list}
 183     @arg[key]{a designator for a function of one argument, or nil}
 184     @arg[test]{a designator for a function of two arguments, or nil}
 185     @return{a @class{node} or nil}
 186     Searches for an child node of @code{parent} that satisfies @code{predicate}
 187     and removes it, if allowed."))
 188
 189 (defgeneric replace-child (parent old-child new-child)
 190   (:documentation
 191    "@arg[parent]{a @class{parent-node}}
 192     @arg[old-child]{a @class{node}}
 193     @arg[new-child]{a @class{node}}
 194     @short{Adds @code{new-child} instead of @code{old-child} as a child node of
 195     @code{parent}, if allowed.}
 196
 197     Signals an error if the new child already has a parent.
 198
 199     Also signals an error if @code{old-child} is not a child of
 200     @code{parent}."))
 201
 202 (defgeneric check-insertion-allowed (parent child position))
 203 (defgeneric check-deletion-allowed (parent child position))
 204
 205 (defmethod insert-child ((parent parent-node) (child node) i)
 206   (check-insertion-allowed parent child i)
 207   (%unchecked-insert-child parent child i)
 208   (setf (%parent child) parent))
 209
 210 (defmethod replace-child ((parent parent-node) old-child new-child)
 211   (check-type old-child node)
 212   (check-type new-child node)
 213   (let ((idx (child-position old-child parent)))
 214     (unless idx
 215       (stp-error "old child not found: ~A" old-child))
 216     (unless (eql old-child new-child)
 217       (check-insertion-allowed parent new-child idx)
 218       (delete-nth-child idx parent)
 219       (%unchecked-insert-child parent new-child idx))))
 220
 221 (defun %unchecked-insert-child (parent child i)
 222   (unless (%children parent)
 223     (setf (%children parent) (make-array 1 :fill-pointer 0 :adjustable t)))
 224   (let ((children (%children parent)))
 225     (cxml-dom::make-space children 1)
 226     (cxml-dom::move children children i (1+ i) (- (length children) i))
 227     (incf (fill-pointer children))
 228     (setf (elt children i) child))
 229   (setf (%parent child) parent))
 230
 231 (defun %nuke-nth-child (parent i)
 232   (let* ((c (%children parent))
 233          (loser (elt c i)))
 234     (maybe-fill-in-base-uri loser)
 235     (cxml-dom::move c c (1+ i) i (- (length c) i 1))
 236     (decf (fill-pointer c))
 237     (setf (%parent loser) nil)))
 238
 239 (defmethod delete-child-if
 240     (predicate (parent parent-node) &key from-end start end count key)
 241   (let ((c (%children parent))
 242         (result nil))
 243     (setf start (or start 0))
 244     (setf key (or key #'identity))
 245     (setf count (or count (length c)))
 246     (setf end (or end (length c)))
 247     (unless (and (<= 0 start (length c))
 248                  (<= end (length c))
 249                  (<= start end))
 250       (stp-error "invalid bounding index designators"))
 251     (when c                       ;nothing to delete if not a vector yet
 252       (if from-end
 253           (let ((i (1- end)))
 254             (cxml::while (and (>= i start) (plusp count))
 255               (let ((loser (elt c i)))
 256                 (when (funcall predicate (funcall key loser))
 257                   (check-deletion-allowed parent loser i)
 258                   (maybe-fill-in-base-uri loser)
 259                   (cxml-dom::move c c (1+ i) i (- (length c) i 1))
 260                   (decf (fill-pointer c))
 261                   (setf (%parent loser) nil)
 262                   (decf count)
 263                   (setf result t)))
 264               (decf i)))
 265           (let ((tbd (- end start))
 266                 (i start))
 267             (cxml::while (and (plusp tbd) (plusp count))
 268               (let ((loser (elt c i)))
 269                 (cond
 270                   ((funcall predicate (funcall key loser))
 271                    (check-deletion-allowed parent loser i)
 272                    (maybe-fill-in-base-uri loser)
 273                    (cxml-dom::move c c (1+ i) i (- (length c) i 1))
 274                    (decf (fill-pointer c))
 275                    (setf (%parent loser) nil)
 276                    (decf count)
 277                    (setf result t))
 278                   (t
 279                    (incf i))))
 280               (decf tbd)))))
 281     result))
 282
 283 (defreader parent-node ((base-uri "") (children nil))
 284   (setf (%base-uri this) base-uri)
 285   (dolist (child children)
 286     (append-child this child)))