Added an extension element API
authorDavid Lichteblau <david@lichteblau.com>
Sun, 27 Apr 2008 14:07:22 +0000 (27 16:07 +0200)
committerDavid Lichteblau <david@radon.(none)>
Sun, 27 Apr 2008 14:07:22 +0000 (27 16:07 +0200)
TEST
extensions.lisp [new file with mode: 0644]
instructions.lisp
package.lisp
parser.lisp
xslt.lisp
xuriella.asd

diff --git a/TEST b/TEST
index 5393cb5..37f85af 100644 (file)
--- 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 (file)
index 0000000..f4d86a3
--- /dev/null
@@ -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 <document> 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)))))
index 970eed8..da4ccb9 100644 (file)
@@ -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)
                        (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)
index 004d5f4..dbf23cc 100644 (file)
            #: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."))
index c04184a..0ea4bcd 100644 (file)
              ((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)))
 
 (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.))
                  :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))))
index a6192ba..d074154 100644 (file)
--- a/xslt.lisp
+++ b/xslt.lisp
   `(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
 (defvar *apply-imports-limit*)
 (defvar *import-priority*)
 (defvar *extension-namespaces*)
-(defvar *forwards-compatible-p*)
 
 (defmacro do-toplevel ((var xpath <transform>) &body body)
   `(map-toplevel (lambda (,var) ,@body) ,xpath ,<transform>))
       #'(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*))
index 4bc9e26..e0c89c7 100644 (file)
@@ -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))