xml/space-normalizer.lisp

   1 ;;;; space-normalizer.lisp -- whitespace removal
   2 ;;;;
   3 ;;;; This file is part of the CXML parser, released under Lisp-LGPL.
   4 ;;;; See file COPYING for details.
   5 ;;;;
   6 ;;;; Copyright (c) 2005 David Lichteblau
   7
   8 (in-package :cxml)
   9
  10 (defclass whitespace-normalizer (sax-proxy)
  11     ((attributes :initform '(t) :accessor xml-space-attributes)
  12      (models :initform nil :accessor xml-space-models)
  13      (dtd :initarg :dtd :accessor xml-space-dtd)))
  14
  15 (defun make-whitespace-normalizer (chained-handler &optional dtd)
  16   (make-instance 'whitespace-normalizer
  17     :dtd dtd
  18     :chained-handler chained-handler))
  19
  20 (defmethod sax::dtd ((handler whitespace-normalizer) dtd)
  21   (unless (xml-space-dtd handler)
  22     (setf (xml-space-dtd handler) dtd)))
  23
  24 (defmethod sax:start-element
  25     ((handler whitespace-normalizer) uri lname qname attrs)
  26   (declare (ignore uri lname))
  27   (let ((dtd (xml-space-dtd handler)))
  28     (when dtd
  29       (let ((xml-space
  30              (sax:find-attribute (if (stringp qname) "xml:space" #"xml:space")
  31                                  attrs)))
  32         (push (if xml-space
  33                   (rod= (rod (sax:attribute-value xml-space)) #"default")
  34                   (car (xml-space-attributes handler)))
  35               (xml-space-attributes handler)))
  36       (let* ((e (cxml::find-element (rod qname) dtd))
  37              (cspec (when e (cxml::elmdef-content e))))
  38         (push (and (consp cspec)
  39                    (not (and (eq (car cspec) '*)
  40                              (let ((subspec (second cspec)))
  41                                (and (eq (car subspec) 'or)
  42                                     (eq (cadr subspec) :PCDATA))))))
  43               (xml-space-models handler)))))
  44   (call-next-method))
  45
  46 (defmethod sax:characters ((handler whitespace-normalizer) data)
  47   (cond
  48     ((and (xml-space-dtd handler)
  49           (car (xml-space-attributes handler))
  50           (car (xml-space-models handler)))
  51       (unless (every #'white-space-rune-p (rod data))
  52         (warn "non-whitespace character data in element content")
  53         (call-next-method)))
  54     (t
  55       (call-next-method))))
  56
  57 (defmethod sax:end-element ((handler whitespace-normalizer) uri lname qname)
  58   (declare (ignore uri lname qname))
  59   (when (xml-space-dtd handler)
  60     (pop (xml-space-attributes handler))
  61     (pop (xml-space-models handler)))
  62   (call-next-method))