html.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
   2
   3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
   4 ;;; 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 ;;; Handler for the HTML output method.
  34 ;;;
  35 ;;; Dispatches requests to either an HTML sink or an XML sink, depending
  36 ;;; on the namespace of the event.
  37 ;;;
  38 ;;; Inserts the http-equiv meta tag.
  39
  40 (defclass combi-sink (sax:content-handler)
  41   ((hax-target :initarg :hax-target :accessor sink-hax-target)
  42    (sax-target :initarg :sax-target :accessor sink-sax-target)
  43    (encoding :initarg :encoding :accessor sink-encoding)))
  44
  45 (defmethod initialize-instance :after ((handler combi-sink) &key)
  46   (setf (sink-encoding handler)
  47         (or (sink-encoding handler) "utf-8")))
  48
  49 (defmethod sax:start-document ((handler combi-sink))
  50   nil)
  51
  52 (defmethod sax:start-dtd ((handler combi-sink) name pubid systemid)
  53   (hax:start-document (sink-hax-target handler) name pubid systemid))
  54
  55 (defun maybe-close-tag (combi-sink)
  56   (cxml::maybe-close-tag (sink-sax-target combi-sink)))
  57
  58 (defmethod sax:start-element ((handler combi-sink) uri lname qname attrs)
  59   (with-slots (hax-target sax-target encoding) handler
  60     (maybe-close-tag handler)
  61     (cond
  62       ((equal uri "")
  63        (sax:start-element hax-target *html* lname qname attrs)
  64        (when (and encoding (equalp lname "head"))
  65          (let* ((content (format nil "text/html; charset=~A" encoding))
  66                 (attrs
  67                  (list (hax:make-attribute "http-equiv" "Content-Type")
  68                        (hax:make-attribute "content" content))))
  69            (sax:start-element hax-target *html* "meta" "meta" attrs)
  70            (sax:end-element hax-target *html* "meta" "meta"))))
  71       (t
  72        (sax:start-element sax-target uri lname qname attrs)))))
  73
  74 (defmethod sax:end-element ((handler combi-sink) uri lname qname)
  75   (with-slots (hax-target sax-target) handler
  76     (maybe-close-tag handler)
  77     (if (equal uri "")
  78         (sax:end-element hax-target *html* lname qname)
  79         (sax:end-element sax-target uri lname qname))))
  80
  81 (defmethod sax:end-document ((handler combi-sink))
  82   (hax:end-document (sink-hax-target handler)))
  83
  84 (defmethod sax:processing-instruction ((handler combi-sink) target data)
  85   (maybe-close-tag handler)
  86   (sax:processing-instruction (sink-hax-target handler) target data))
  87
  88 (defmethod sax:characters ((handler combi-sink) data)
  89   (maybe-close-tag handler)
  90   (sax:characters (sink-hax-target handler) data))
  91
  92 (defmethod sax:unescaped ((handler combi-sink) data)
  93   (maybe-close-tag handler)
  94   (sax:unescaped (sink-hax-target handler) data))
  95
  96 (defmethod sax:comment ((handler combi-sink) data)
  97   (maybe-close-tag handler)
  98   (sax:comment (sink-hax-target handler) data))
  99
 100
 101
 102
 103 ;;; Handler for the default output method.
 104 ;;;
 105 ;;; Waits for the document element, then decides between combi-sink and
 106 ;;; xml sink.
 107
 108 (defclass auto-detect-sink (cxml:broadcast-handler)
 109   ((switchedp :initform nil :accessor sink-switched-p)
 110    (buffered-events :initform '() :accessor sink-buffered-events)))
 111
 112 (defun make-auto-detect-sink (combi-sink)
 113   (make-instance 'auto-detect-sink :handlers (list combi-sink)))
 114
 115 (defmethod sax:start-document ((handler auto-detect-sink))
 116   nil)
 117
 118 (defmethod sax:start-dtd ((handler auto-detect-sink) name pubid systemid)
 119   (assert nil))
 120
 121 (defmethod sax:start-element
 122     :before
 123     ((handler auto-detect-sink) uri lname qname attrs)
 124   (unless (sink-switched-p handler)
 125     (if (and (equal uri "") (string-equal lname "html"))
 126         (switch-to-html-output handler)
 127         (switch-to-xml-output handler))))
 128
 129 (defmethod sax:end-document :before ((handler auto-detect-sink))
 130   (unless (sink-switched-p handler)
 131     (switch-to-xml-output handler)))
 132
 133 (defmethod sax:characters ((handler auto-detect-sink) data)
 134   (cond
 135     ((sink-switched-p handler)
 136      (call-next-method))
 137     ((not (whitespacep data))
 138      (switch-to-xml-output handler)
 139      (call-next-method))
 140     (t
 141      (push (list 'sax:characters data) (sink-buffered-events handler)))))
 142
 143 (defmethod sax:processing-instruction
 144     ((handler auto-detect-sink) target data)
 145   (cond
 146     ((sink-switched-p handler)
 147      (call-next-method))
 148     (t
 149      (push (list 'sax:processing-instruction target data)
 150            (sink-buffered-events handler)))))
 151
 152 (defmethod sax:unescaped ((handler auto-detect-sink) data)
 153   (cond
 154     ((sink-switched-p handler)
 155      (call-next-method))
 156     (t
 157      (push (list 'sax:unescaped data) (sink-buffered-events handler)))))
 158
 159 (defmethod sax:comment ((handler auto-detect-sink) data)
 160   (cond
 161     ((sink-switched-p handler)
 162      (call-next-method))
 163     (t
 164      (push (list 'sax:comment data) (sink-buffered-events handler)))))
 165
 166 (define-condition |hey test suite, this is an HTML document| ()
 167   ())
 168
 169 (defun switch-to-html-output (handler)
 170   (signal '|hey test suite, this is an HTML document|)
 171   (setf (sink-switched-p handler) t)
 172   (replay-buffered-events handler))
 173
 174 (defun switch-to-xml-output (handler)
 175   (setf (sink-switched-p handler) t)
 176   (setf (cxml:broadcast-handler-handlers handler)
 177         (list (sink-sax-target
 178                (car (cxml:broadcast-handler-handlers handler)))))
 179   (replay-buffered-events handler))
 180
 181 (defun replay-buffered-events (handler)
 182   (sax:start-document (car (cxml:broadcast-handler-handlers handler)))
 183   (loop
 184      for (event . args) in (nreverse (sink-buffered-events handler))
 185      do (apply event handler args)))