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