From b71704adf7c55921b68467e1869119b06835e3a5 Mon Sep 17 00:00:00 2001 From: David Lichteblau Date: Sat, 16 Jun 2007 23:29:35 +0200 Subject: [PATCH] PARENT-NODE, DOCUMENT --- cxml-stp.asd | 4 +- document.lisp | 120 ++++++++++++++++++++++++++++++++++++++++++ index.xml | 8 ++- node.lisp | 2 +- package.lisp | 2 + node.lisp => parent-node.lisp | 66 ++++++++--------------- 6 files changed, 154 insertions(+), 48 deletions(-) create mode 100644 document.lisp copy node.lisp => parent-node.lisp (55%) diff --git a/cxml-stp.asd b/cxml-stp.asd index f6d9185..82453d5 100644 --- a/cxml-stp.asd +++ b/cxml-stp.asd @@ -16,5 +16,7 @@ :serial t :components ((:file "package") - (:file "node")) + (:file "node") + (:file "parent-node") + (:file "document")) :depends-on (:cxml)) diff --git a/document.lisp b/document.lisp new file mode 100644 index 0000000..948064d --- /dev/null +++ b/document.lisp @@ -0,0 +1,120 @@ +;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*- + +;;; Copyright (c) 2007 David Lichteblau. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cxml-stp) + +#+sbcl +(declaim (optimize (debug 2))) + +(defclass document (parent-node) ()) + +(defun make-document (document-element) + (check-type document-element element) + (let ((result (make-instance 'document))) + (insert-child result document-element 0) + result)) + +(defmethod copy ((node document)) + (let ((result (make-instance 'document))) + (insert-child result (copy (document-element node)) 0) + ;; fixme, das ist doch nicht schoen so + (let ((i 0)) + (do-children (child node) + (unless (typep child 'element) + (insert-child result i (copy child))) + (incf i))) + (setf (%base-uri result) (%base-uri node)) + result)) + +(defun assert-orphan (node) + (when (parent node) + (stp-error "node already has a parent: ~A" node))) + +(defmethod insertion-allowed ((parent document) child pos) + (assert-orphan child) + (typecase child + ((or comment processing-instruction)) + (document-type + ;; // doctypes nur falls noch keiner da, und nur vor rootelement + (error "FIXME")) + (element + (unless (zerop (length (%children parent))) + (stp-error "attempt to insert multiple document elements"))) + (t (stp-error "not a valid child of a document: ~A" child)))) + +(defun document-type (document) + (find-if (lambda (x) (typep x 'document-type)) (%children document))) + +(defun (setf document-type) (newval document) + (check-type newval document-type) + (let ((old (document-type document))) + (unless (eq newval old) + (assert-orphan newval) + ;; gefaellt mir alles nicht + (if old + (let ((pos (position old (%children document)))) + (remove-child this pos) + (insert-child document newval pos)) + (insert-child document newval 0))))) + +(defun document-element (document) + (find-if (lambda (x) (typep x 'element)) (%children document))) + +(defun (setf document-element) (newval document) + (check-type newval element) + (let ((old (document-element document))) + (unless (eq newval old) + (assert-orphan newval) + ;; gefaellt mir alles nicht + (let ((pos (position old (%children document)))) + (super-remove-child this pos) + (super-insert-child document newval pos))))) + +(defmethod base-uri ((document document)) + (%base-uri document)) + +(defmethod (setf base-uri) (newval (document document)) + (setf (%base-uri document) newval)) + +;; FIXME +;; (defmethod remove-child (())) +;; -- aber nicht das DE + +(defmethod replace-child ((parent document) old new) + (typecase old + (document-type (setf (document-type parent) new)) + (element (setf (document-element parent) new)) + (t (call-next-method)))) + +(defmethod string-value ((node document)) + (string-value (document-element node))) + +(defmethod unparse ((node document) handler) + (sax:start-document handler) + (map nil #'unparse (%children node)) + (sax:end-document handler)) diff --git a/index.xml b/index.xml index 5e3c612..06c54b0 100644 --- a/index.xml +++ b/index.xml @@ -21,7 +21,10 @@ cxml-devel@common-lisp.net (list information).

- +

+ Acknowledgements: + cxml-stp is inspired heavily by XOM. +

Download and Installation

@@ -58,6 +61,7 @@

Documentation

- API documentation is available. + Please refer to the API documentation + for details.

diff --git a/node.lisp b/node.lisp index 73c346f..fabfa45 100644 --- a/node.lisp +++ b/node.lisp @@ -32,7 +32,7 @@ (declaim (optimize (debug 2))) (defclass node () - ((parent :accessor parent))) + ((parent :reader parent :writer (setf %parent)))) (defgeneric string-value (node)) diff --git a/package.lisp b/package.lisp index 6c80a68..1641382 100644 --- a/package.lisp +++ b/package.lisp @@ -13,6 +13,8 @@ #:copy #:unparse ;; #:query + + #:parent-node ) (:documentation "@code{cxml-stp} implements ___. diff --git a/node.lisp b/parent-node.lisp similarity index 55% copy from node.lisp copy to parent-node.lisp index 73c346f..117f780 100644 --- a/node.lisp +++ b/parent-node.lisp @@ -31,53 +31,31 @@ #+sbcl (declaim (optimize (debug 2))) -(defclass node () - ((parent :accessor parent))) +(defclass parent-node (node) + ((%base-uri) + (%children :accessor %children))) -(defgeneric string-value (node)) +(defvar *check-uri-syntax* t) -(defun document (node) - (check-type node node) - (loop - for parent = node then (parent parent) - while (and parent (not (typep parent 'document))) - finally (return parent))) - -(defun root (node) - (check-type node node) - (loop - for p = (parent node) then (parent p) - and q = node then p - while p - finally (return q))) +(defgeneric %base-uri (node)) +(defmethod %base-uri ((node node)) (or (slot-value node '%base-uri) "")) +(defmethod (setf %base-uri) (newval (node node)) + (when (and newval *check-uri-syntax* (not (search "://" newval))) + (warn "base URI does not look like an absolute URL: ~S" newval)) + (setf (slot-value node '%base-uri) (or newval ""))) -(defgeneric base-uri (node)) ;fixme: hier muessen wir wissen, ob specified -(defmethod base-uri ((node node)) - (let ((parent (parent node))) - (if parent - (base-uri parent) - ""))) +(defgeneric insertion-allowed (parent child position)) ;position?! -(defgeneric detach (node)) -(defmethod detach ((node node)) - (when (parent node) - (delete-child node (parent node)))) +(defun fill-in-base-uri (removed-child) + (setf (%base-uri removed-child) + (find-base-uri removed-child))) -;;; kinderkram -;;; das ist noch unvollstaendig -(defgeneric map-children (result-type function node)) -(defmacro do-children ((var node &optional result) &body body) - `(block nil - (map-children (lambda (,var) ,@body) ,node) - ,result)) -(defun list-children (node) - (map-children 'list #'identity node)) - -(defgeneric copy (node)) -(defgeneric unparse (node handler)) - -;; print-object nicht vergessen +(defun find-base-uri (node) + (loop + for n = node then parent + for parent = (parent node) + for uri = (%base-uri n) + while (and (equal uri "") parent) + finally (return uri))) -;;; (defun query (node xpath) -;;; ;; fixme -;;; ) +(defgeneric (setf base-uri) (newval node)) -- 2.11.4.GIT