From: David Lichteblau Date: Sun, 27 Apr 2008 14:07:22 +0000 (+0200) Subject: Added an extension element API X-Git-Url: https://repo.or.cz/w/xuriella.git/commitdiff_plain/bf7f1a32fc4799946992ccee985777b75308c0f3 Added an extension element API --- diff --git a/TEST b/TEST index 5393cb5..37f85af 100644 --- a/TEST +++ b/TEST @@ -18837,12 +18837,6 @@ PASS XSLTFunctions__84048 [Mixed] Expected output (1): MSFT_Conformance_Tests/XSLTFunctions/XSLTFunctions__84048.saxon Actual output: MSFT_Conformance_Tests/XSLTFunctions/XSLTFunctions__84048.xuriella -FAIL XSLTFunctions__84050 [Mixed]: output doesn't match - Stylesheet: MSFT_Conformance_Tests/XSLTFunctions/84050.noindent-xsl - Data: MSFT_Conformance_Tests/XSLTFunctions/books.xml - Expected output (1): MSFT_Conformance_Tests/XSLTFunctions/XSLTFunctions__84050.saxon - Actual output: MSFT_Conformance_Tests/XSLTFunctions/XSLTFunctions__84050.xuriella - PASS XSLTFunctions__84053 [Mixed] Stylesheet: MSFT_Conformance_Tests/XSLTFunctions/84053.noindent-xsl Data: MSFT_Conformance_Tests/XSLTFunctions/books.xml @@ -19257,4 +19251,4 @@ PASS XSLTFunctions_DocumentFuncWithEmptyArg [Mixed] Expected output (1): MSFT_Conformance_Tests/XSLTFunctions/XSLTFunctions_DocumentFuncWithEmptyArg.saxon Actual output: MSFT_Conformance_Tests/XSLTFunctions/XSLTFunctions_DocumentFuncWithEmptyArg.xuriella -Passed 2983/3069 tests (26 expected failures, 60 unexpected failures). +Passed 2983/3068 tests (26 expected failures, 59 unexpected failures). diff --git a/extensions.lisp b/extensions.lisp new file mode 100644 index 0000000..f4d86a3 --- /dev/null +++ b/extensions.lisp @@ -0,0 +1,167 @@ +;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*- + +;;; Copyright (c) 2007,2008 Ivan Shvedunov. All rights reserved. +;;; Copyright (c) 2007,2008 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 :xuriella) + + +;;;; XSLT extensions + +(defvar *extension-groups* (make-hash-table :test #'equal)) + +(defstruct extension-group + uri + documentation + (elements (make-hash-table :test #'equal))) + +(defstruct extension-element + local-name + (parser (lambda (&rest ignore) + (declare (ignore ignore)) + (xslt-error "extension parser not defined")))) + +(defun %define-extension-group (name uri documentation) + (check-type uri string) + (let* ((current-ext (get name 'extension-group)) + (new-ext + (cond (current-ext + (setf (gethash (extension-group-uri current-ext) + *extension-groups*) + (remove current-ext + (gethash (extension-group-uri current-ext) + *extension-groups*)) + (extension-group-uri current-ext) uri + (extension-group-documentation current-ext) documentation) + current-ext) + (t + (setf (get name 'extension-group) + (make-extension-group :uri uri + :documentation documentation)))))) + (push new-ext (gethash uri *extension-groups*)))) + +(defmacro define-extension-group (name uri &optional documentation) + (check-type name symbol) + `(%define-extension-group ',name ,uri ,documentation)) + +(defun find-extension-element (local-name uri) + (loop for ext in (gethash uri *extension-groups*) + for match = (gethash local-name (extension-group-elements ext)) + when match + do (return match))) + +(defun ensure-extension-element (ext name) + (check-type name string) + (setf (gethash name + (extension-group-elements + (or (get ext 'extension-group) + (error "no such extension: ~s" ext)))) + (make-extension-element :local-name name))) + +(defmacro define-extension-parser (ext name (node-var) &body body) + `(setf (extension-element-parser + (ensure-extension-element ',ext ',name)) + (lambda (,node-var) + ,@body))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun parse-extension-lambda-list (lambda-list) + ;; find &environment + (loop + for (form . rest) on lambda-list + when (eq form '&environment) + do + (destructuring-bind (env-var &rest rest-rest) rest + (check-type env-var (and symbol (not null))) + (when (find '&environment rest-rest) + (error "duplicate &environment in extension lambda list")) + (return + (values env-var (append normal-forms rest-rest)))) + collect form into normal-forms + finally + (return (values 'ignore normal-forms))))) + +(defmacro define-extension-compiler (symbol (&rest lambda-list) &body body) + (when (find (symbol-package symbol) + ;; reserved for built-in instructions: + (list (find-package :common-lisp) + (find-package :xslt) + (find-package :xuriella))) + (error "cannot define XSLT extensions in the ~A package" + (symbol-package symbol))) + (multiple-value-bind (env argument-lambda-list) + (parse-extension-lambda-list lambda-list) + (let ((args (gensym))) + `(setf (get ',symbol 'extension-compiler) + (lambda (,ARGS ,env) + (declare (ignorable ,env)) + (destructuring-bind (,@argument-lambda-list) ,ARGS + ,@body)))))) + + + +;;;; our extension + +(define-extension-group :xuriella "http://common-lisp.net/project/xuriella" + "XSLT extensions provided by Xuriella.") + +(define-extension-parser :xuriella "document" (node) + (only-with-attributes + (href method indent doctype-public doctype-system) node + `(xuriella-extensions:document + (,href :method ,method + :indent ,indent + :doctype-public ,doctype-public + :doctype-system ,doctype-system) + ,@(parse-body node)))) + +(define-extension-compiler xuriella-extensions:document + ((href &key method indent doctype-public doctype-system) + &body body + &environment env) + (declare (ignore doctype-public doctype-system)) ;fixme + (let ((thunk (compile-instruction `(progn ,@body) env)) + (href-thunk (compile-avt href env))) + (lambda (ctx) + (let ((pathname + (uri-to-pathname + (puri:merge-uris (funcall href-thunk ctx) + (xpath-protocol:base-uri + (xpath:context-node ctx)))))) + (ensure-directories-exist pathname) ;really? + (invoke-with-output-sink + (lambda () + (funcall thunk ctx)) + (make-output-specification + :method (cond + ((or (null method) (equalp method "XML")) :xml) + ((equalp method "HTML") :html) + ((equalp method "TEXT") :text) + (t + (xslt-error "invalid output method: ~A" method))) + :indent indent) + pathname))))) diff --git a/instructions.lisp b/instructions.lisp index 970eed8..da4ccb9 100644 --- a/instructions.lisp +++ b/instructions.lisp @@ -35,7 +35,7 @@ ;;;; Instructions -(defparameter *available-instructions* (make-hash-table :test 'equal)) +(defparameter *builtin-instructions* (make-hash-table :test 'equal)) (defmacro define-instruction (name (args-var env-var) &body body) `(setf (get ',name 'xslt-instruction) @@ -747,30 +747,10 @@ (loop for (name nil value-thunk) in param-bindings collect (list name (funcall value-thunk ctx)))))))) -;; fixme: incompatible with XSLT 2.0 -(define-instruction xsl:document (args env) - (destructuring-bind ((href &key method indent doctype-public doctype-system) - &body body) - args - (declare (ignore doctype-public doctype-system)) ;fixme - (let ((thunk (compile-instruction `(progn ,@body) env)) - (href-thunk (compile-avt href env))) - (lambda (ctx) - (let ((pathname - (uri-to-pathname - (puri:merge-uris (funcall href-thunk ctx) - (xpath-protocol:base-uri - (xpath:context-node ctx)))))) - (ensure-directories-exist pathname) ;really? - (invoke-with-output-sink - (lambda () - (funcall thunk ctx)) - (make-output-specification :method (or method "XML") :indent indent) - pathname)))))) - (defun compile-instruction (form env) (xslt-trace-thunk (funcall (or (get (car form) 'xslt-instruction) + (get (car form) 'extension-compiler) (error "undefined instruction: ~A" (car form))) (cdr form) env) diff --git a/package.lisp b/package.lisp index 004d5f4..dbf23cc 100644 --- a/package.lisp +++ b/package.lisp @@ -35,16 +35,21 @@ #:with-extension-namespaces #:with-duplicates-check)) +(defpackage :xuriella-extensions + (:use) + (:export #:document)) + (defpackage :xuriella (:use :cl) (:export #:parse-stylesheet #:apply-stylesheet - #:make-parameter) + #:make-parameter + + #:define-extension-group + #:define-extension-parser + #:define-extension-compiler + #:parse-body + #:compile-instruction) (:import-from :xpath-protocol #:define-default-method) (:documentation - "Empty is an empty example. - - @begin[Empty section]{section} - I am a blind text. - - @end{section}")) + "Xuriella is an implementation of XSLT 1.0.")) diff --git a/parser.lisp b/parser.lisp index c04184a..0ea4bcd 100644 --- a/parser.lisp +++ b/parser.lisp @@ -114,7 +114,12 @@ ((find (stp:namespace-uri node) *extension-namespaces* :test #'equal) - (parse-fallback-children node)) + (let ((extension (find-extension-element + (stp:local-name node) + (stp:namespace-uri node)))) + (if extension + (funcall (extension-element-parser extension) node) + (parse-fallback-children node)))) (t (parse-instruction/literal-element node)))) (parent (stp:parent node))) @@ -195,7 +200,7 @@ (defmacro define-instruction-parser (name (node-var) &body body) `(progn - (setf (gethash ,(symbol-name name) *available-instructions*) t) + (setf (gethash ,(symbol-name name) *builtin-instructions*) t) (defmethod parse-instruction/xsl-element ((.name. (eql ',name)) ,node-var) (declare (ignore .name.)) @@ -376,12 +381,3 @@ :letter-value ,letter-value :grouping-separator ,grouping-separator :grouping-size ,grouping-size))) - -(define-instruction-parser |document| (node) - (only-with-attributes - (href method indent doctype-public doctype-system) node - `(xsl:document (,href :method ,method - :indent ,indent - :doctype-public ,doctype-public - :doctype-system ,doctype-system) - ,@(parse-body node)))) diff --git a/xslt.lisp b/xslt.lisp index a6192ba..d074154 100644 --- a/xslt.lisp +++ b/xslt.lisp @@ -103,6 +103,8 @@ `(invoke-with-forward-compatible-errors (lambda () ,@body) (lambda () ,error-form))) +(defvar *forwards-compatible-p*) + (defun invoke-with-forward-compatible-errors (fn error-fn) (let ((result)) (tagbody @@ -572,7 +574,6 @@ (defvar *apply-imports-limit*) (defvar *import-priority*) (defvar *extension-namespaces*) -(defvar *forwards-compatible-p*) (defmacro do-toplevel ((var xpath ) &body body) `(map-toplevel (lambda (,var) ,@body) ,xpath ,)) @@ -1396,17 +1397,22 @@ #'(lambda (ctx) (%get-node-id (xpath:context-node ctx))))) -(declaim (special *available-instructions*)) +(declaim (special *builtin-instructions*)) (xpath-sys:define-xpath-function/lazy xslt :element-available (qname) - (let ((namespaces *namespaces*)) + (let ((namespaces *namespaces*) + (extensions *extension-namespaces*)) #'(lambda (ctx) (let ((qname (funcall qname ctx))) (multiple-value-bind (local-name uri) (decode-qname/runtime qname namespaces nil) - (and (equal uri *xsl*) - (gethash local-name *available-instructions*) - t)))))) + (cond + ((equal uri *xsl*) + (and (gethash local-name *builtin-instructions*) t)) + ((find uri extensions :test #'equal) + (and (find-extension-element local-name uri) t)) + (t + nil))))))) (xpath-sys:define-xpath-function/lazy xslt :function-available (qname) (let ((namespaces *namespaces*)) diff --git a/xuriella.asd b/xuriella.asd index 4bc9e26..e0c89c7 100644 --- a/xuriella.asd +++ b/xuriella.asd @@ -27,5 +27,6 @@ (:file "format-number") (:file "number") (:file "stpx") + (:file "extensions") (:file "test")) :depends-on (:cxml :cxml-stp :closure-html :xpath :split-sequence))