extensions.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
   2
   3 ;;; Copyright (c) 2007,2008 Ivan Shvedunov. All rights reserved.
   4 ;;; Copyright (c) 2007,2008 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 (in-package :xuriella)
  31
  32
  33 ;;;; XSLT extensions
  34
  35 (defvar *extension-groups* (make-hash-table :test #'equal))
  36
  37 (defstruct extension-group
  38   uri
  39   documentation
  40   (elements (make-hash-table :test #'equal)))
  41
  42 (defstruct extension-element
  43   local-name
  44   (parser (lambda (&rest ignore)
  45             (declare (ignore ignore))
  46             (xslt-error "extension parser not defined"))))
  47
  48 (defun %define-extension-group (name uri documentation)
  49   (check-type uri string)
  50   (let* ((current-ext (get name 'extension-group))
  51          (new-ext
  52           (cond (current-ext
  53                  (setf (gethash (extension-group-uri current-ext)
  54                                 *extension-groups*)
  55                        (remove current-ext
  56                                (gethash (extension-group-uri current-ext)
  57                                         *extension-groups*))
  58                        (extension-group-uri current-ext) uri
  59                        (extension-group-documentation current-ext) documentation)
  60                  current-ext)
  61                 (t
  62                  (setf (get name 'extension-group)
  63                        (make-extension-group :uri uri
  64                                              :documentation documentation))))))
  65     (push new-ext (gethash uri *extension-groups*))))
  66
  67 (defmacro define-extension-group (name uri &optional documentation)
  68   (check-type name symbol)
  69   `(%define-extension-group ',name ,uri ,documentation))
  70
  71 (defun find-extension-element (local-name uri)
  72   (loop for ext in (gethash uri *extension-groups*)
  73         for match = (gethash local-name (extension-group-elements ext))
  74         when match
  75           do (return match)))
  76
  77 (defun ensure-extension-element (ext name)
  78   (check-type name string)
  79   (setf (gethash name
  80                  (extension-group-elements
  81                   (or (get ext 'extension-group)
  82                       (error "no such extension: ~s" ext))))
  83         (make-extension-element :local-name name)))
  84
  85 (defmacro define-extension-parser (ext name (node-var) &body body)
  86   `(setf (extension-element-parser
  87           (ensure-extension-element ',ext ',name))
  88          (lambda (,node-var)
  89            ,@body)))
  90
  91 (eval-when (:compile-toplevel :load-toplevel :execute)
  92   (defun parse-extension-lambda-list (lambda-list)
  93     ;; find &environment
  94     (loop
  95        for (form . rest) on lambda-list
  96        when (eq form '&environment)
  97        do
  98          (destructuring-bind (env-var &rest rest-rest) rest
  99            (check-type env-var (and symbol (not null)))
 100            (when (find '&environment rest-rest)
 101              (error "duplicate &environment in extension lambda list"))
 102            (return
 103              (values env-var (append normal-forms rest-rest))))
 104        collect form into normal-forms
 105        finally
 106          (return (values 'ignore normal-forms)))))
 107
 108 (defmacro define-extension-compiler (symbol (&rest lambda-list) &body body)
 109   (when (find (symbol-package symbol)
 110               ;; reserved for built-in instructions:
 111               (list (find-package :common-lisp)
 112                     (find-package :xslt)
 113                     (find-package :xuriella)))
 114     (error "cannot define XSLT extensions in the ~A package"
 115            (symbol-package symbol)))
 116   (multiple-value-bind (env argument-lambda-list)
 117       (parse-extension-lambda-list lambda-list)
 118     (let ((args (gensym)))
 119       `(setf (get ',symbol 'extension-compiler)
 120              (lambda (,ARGS ,env)
 121                (declare (ignorable ,env))
 122                (destructuring-bind (,@argument-lambda-list) ,ARGS
 123                  ,@body))))))
 124
 125
 126
 127 ;;;; our <document> extension
 128
 129 (define-extension-group :xuriella "http://common-lisp.net/project/xuriella"
 130   "XSLT extensions provided by Xuriella.")
 131
 132 (define-extension-parser :xuriella "document" (node)
 133   (only-with-attributes
 134    (href method indent doctype-public doctype-system) node
 135     `(xuriella-extensions:document
 136       (,href :method ,method
 137              :indent ,indent
 138              :doctype-public ,doctype-public
 139              :doctype-system ,doctype-system)
 140       ,@(parse-body node))))
 141
 142 (define-extension-compiler xuriella-extensions:document
 143     ((href &key method indent doctype-public doctype-system)
 144      &body body
 145      &environment env)
 146   (let ((thunk (compile-instruction `(progn ,@body) env))
 147         (href-thunk (compile-avt href env)))
 148     (lambda (ctx)
 149       (let ((pathname
 150              (uri-to-pathname
 151               (puri:merge-uris (funcall href-thunk ctx)
 152                                (xpath-protocol:base-uri
 153                                 (xpath:context-node ctx))))))
 154         (ensure-directories-exist pathname) ;really?
 155         (invoke-with-output-sink
 156          (lambda ()
 157            (funcall thunk ctx))
 158          (make-output-specification
 159           :method (cond
 160                     ((or (null method) (equalp method "XML")) :xml)
 161                     ((equalp method "HTML") :html)
 162                     ((equalp method "TEXT") :text)
 163                     (t
 164                      (xslt-error "invalid output method: ~A" method)))
 165           :indent indent
 166           :doctype-public doctype-public
 167           :doctype-system doctype-system)
 168          pathname)))))