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    (media-type :initarg :media-type :accessor sink-media-type)))
  45
  46 (defmethod initialize-instance :after ((handler combi-sink) &key)
  47   (setf (sink-encoding handler)
  48         (or (sink-encoding handler) "UTF-8")))
  49
  50 (defmethod sax:start-document ((handler combi-sink))
  51   nil)
  52
  53 (defmethod sax:start-dtd ((handler combi-sink) name pubid sysid)
  54   (when (or pubid sysid)
  55     (hax:start-document (sink-hax-target handler) name pubid sysid)))
  56
  57 (defun maybe-close-tag (combi-sink)
  58   (cxml::maybe-close-tag (sink-sax-target combi-sink)))
  59
  60 (defmethod sax:start-element ((handler combi-sink) uri lname qname attrs)
  61   (with-slots (hax-target sax-target encoding) handler
  62     (maybe-close-tag handler)
  63     (cond
  64       ((equal uri "")
  65        (sax:start-element hax-target *html* lname qname attrs)
  66        (when (and encoding (equalp lname "head"))
  67          (let* ((content (format nil "~A; charset=~A"
  68                                  (or (sink-media-type handler) "text/html")
  69                                  encoding))
  70                 (attrs
  71                  (list (hax:make-attribute "http-equiv" "Content-Type")
  72                        (hax:make-attribute "content" content))))
  73            (sax:start-element hax-target *html* "meta" "meta" attrs)
  74            (sax:end-element hax-target *html* "meta" "meta"))))
  75       (t
  76        (sax:start-element sax-target uri lname qname attrs)))))
  77
  78 (defmethod sax:end-element ((handler combi-sink) uri lname qname)
  79   (with-slots (hax-target sax-target) handler
  80     (maybe-close-tag handler)
  81     (if (equal uri "")
  82         (sax:end-element hax-target *html* lname qname)
  83         (sax:end-element sax-target uri lname qname))))
  84
  85 (defmethod sax:end-document ((handler combi-sink))
  86   (hax:end-document (sink-hax-target handler)))
  87
  88 (defmethod sax:processing-instruction ((handler combi-sink) target data)
  89   (maybe-close-tag handler)
  90   (sax:processing-instruction (sink-hax-target handler) target data))
  91
  92 (defmethod sax:characters ((handler combi-sink) data)
  93   (maybe-close-tag handler)
  94   (sax:characters (sink-hax-target handler) data))
  95
  96 (defmethod sax:unescaped ((handler combi-sink) data)
  97   (maybe-close-tag handler)
  98   (sax:unescaped (sink-hax-target handler) data))
  99
 100 (defmethod sax:comment ((handler combi-sink) data)
 101   (maybe-close-tag handler)
 102   (sax:comment (sink-hax-target handler) data))
 103
 104
 105
 106
 107 ;;; Handler for the default output method.
 108 ;;;
 109 ;;; Waits for the document element, then decides between combi-sink and
 110 ;;; xml sink.
 111 ;;;
 112 ;;; Also figures out the root element name for the doctype.
 113
 114 (defclass auto-detect-sink (cxml:broadcast-handler)
 115   ((switchedp :initform nil :accessor sink-switched-p)
 116    (detected-method :initarg :detected-method :accessor sink-detected-method)
 117    (sysid :initform nil :accessor sink-sysid)
 118    (pubid :initform nil :accessor sink-pubid)
 119    (buffered-events :initform '() :accessor sink-buffered-events)))
 120
 121 (defun make-auto-detect-sink (combi-sink fixed-method)
 122   (make-instance 'auto-detect-sink
 123                  :handlers (list combi-sink)
 124                  :detected-method fixed-method))
 125
 126 (defmethod sax:start-document ((handler auto-detect-sink))
 127   nil)
 128
 129 (defmethod sax:start-dtd ((handler auto-detect-sink) name pubid sysid)
 130   (setf (sink-sysid handler) sysid)
 131   (setf (sink-pubid handler) pubid))
 132
 133 (defmethod sax:start-element
 134     :before
 135     ((handler auto-detect-sink) uri lname qname attrs)
 136   (unless (sink-switched-p handler)
 137     (if (ecase (sink-detected-method handler)
 138           (:html t)
 139           (:xml nil)
 140           ((nil) (and (equal uri "") (string-equal lname "html"))))
 141         (switch-to-html-output handler qname)
 142         (switch-to-xml-output handler qname))))
 143
 144 (defmethod sax:end-document :before ((handler auto-detect-sink))
 145   (unless (sink-switched-p handler)
 146     (if (eq (sink-detected-method handler) :html)
 147         (switch-to-html-output handler "root")
 148         (switch-to-xml-output handler "root"))))
 149
 150 (defmethod sax:characters ((handler auto-detect-sink) data)
 151   (cond
 152     ((sink-switched-p handler)
 153      (call-next-method))
 154     (t
 155      (unless (or (whitespacep data) (sink-detected-method handler))
 156        (setf (sink-detected-method handler) :xml))
 157      (push (list 'sax:characters data) (sink-buffered-events handler)))))
 158
 159 (defmethod sax:processing-instruction
 160     ((handler auto-detect-sink) target data)
 161   (cond
 162     ((sink-switched-p handler)
 163      (call-next-method))
 164     (t
 165      (push (list 'sax:processing-instruction target data)
 166            (sink-buffered-events handler)))))
 167
 168 (defmethod sax:unescaped ((handler auto-detect-sink) data)
 169   (cond
 170     ((sink-switched-p handler)
 171      (call-next-method))
 172     (t
 173      (push (list 'sax:unescaped data) (sink-buffered-events handler)))))
 174
 175 (defmethod sax:comment ((handler auto-detect-sink) data)
 176   (cond
 177     ((sink-switched-p handler)
 178      (call-next-method))
 179     (t
 180      (push (list 'sax:comment data) (sink-buffered-events handler)))))
 181
 182 (define-condition |hey test suite, this is an HTML document| ()
 183   ())
 184
 185 (defun switch-to-html-output (handler qname)
 186   (signal '|hey test suite, this is an HTML document|)
 187   (setf (sink-switched-p handler) t)
 188   (when (or (sink-sysid handler) (sink-pubid handler))
 189     (hax:start-document (car (cxml:broadcast-handler-handlers handler))
 190                         qname
 191                         (sink-pubid handler)
 192                         (sink-sysid handler)))
 193   (replay-buffered-events handler))
 194
 195 (defun switch-to-xml-output (handler qname)
 196   (setf (sink-switched-p handler) t)
 197   (let ((target
 198          (sink-sax-target (car (cxml:broadcast-handler-handlers handler)))))
 199     (setf (cxml:broadcast-handler-handlers handler) (list target))
 200     (sax:start-document target)
 201     (when (sink-sysid handler)
 202       (sax:start-dtd target qname (sink-pubid handler) (sink-sysid handler))
 203       (sax:end-dtd target)))
 204   (replay-buffered-events handler))
 205
 206 (defun replay-buffered-events (handler)
 207   (loop
 208      for (event . args) in (nreverse (sink-buffered-events handler))
 209      do (apply event handler args)))