xml-utils.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          xml-utils.lisp
   6 ;;;; Purpose:       XML utilities
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; KMRCL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (in-package #:kmrcl)
  20
  21
  22 ;;; XML Extraction Functions
  23
  24 (defun find-start-tag (tag taglen xmlstr start end)
  25   "Searches for the start of a tag in an xmlstring. Returns STARTPOS ATTRIBUTE-LIST)"
  26   (declare (simple-string tag xmlstr)
  27            (fixnum taglen start end)
  28            (optimize (speed 3) (safety 0) (space 0)))
  29   (do* ((search-str (concatenate 'string "<" tag))
  30         (search-len (1+ taglen))
  31         (bracketpos (fast-string-search search-str xmlstr search-len start end)
  32                     (fast-string-search search-str xmlstr search-len start end)))
  33        ((null bracketpos) nil)
  34     (let* ((endtag (+ bracketpos 1 taglen))
  35            (char-after-tag (schar xmlstr endtag)))
  36       (when (or (char= #\> char-after-tag)
  37                 (char= #\space char-after-tag))
  38         (if (char= #\> char-after-tag)
  39             (return-from find-start-tag (values (1+ endtag) nil))
  40             (let ((endbrack (position-char #\> xmlstr (1+ endtag) end)))
  41               (if endbrack
  42                   (return-from find-start-tag
  43                     (values (1+ endbrack)
  44                             (string-to-list-skip-delimiter
  45                              (subseq xmlstr endtag endbrack))))
  46                   (values nil nil)))))
  47       (setq start endtag))))
  48
  49
  50 (defun find-end-tag (tag taglen xmlstr start end)
  51   (fast-string-search
  52    (concatenate 'string "</" tag ">") xmlstr
  53    (+ taglen 3) start end))
  54
  55 (defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
  56                                        (end-xmlstr (length xmlstr)))
  57   "Returns three values: the start and end positions of contents between
  58  the xml tags and the position following the close of the end tag."
  59   (let* ((taglen (length tag)))
  60     (multiple-value-bind (start attributes)
  61         (find-start-tag tag taglen xmlstr start-xmlstr end-xmlstr)
  62       (unless start
  63         (return-from positions-xml-tag-contents (values nil nil nil nil)))
  64       (let ((end (find-end-tag tag taglen xmlstr start end-xmlstr)))
  65         (unless end
  66           (return-from positions-xml-tag-contents (values nil nil nil nil)))
  67         (values start end (+ end taglen 3) attributes)))))
  68
  69
  70 (defun xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
  71                          (end-xmlstr (length xmlstr)))
  72   "Returns two values: the string between XML start and end tag
  73 and position of character following end tag."
  74   (multiple-value-bind
  75       (startpos endpos nextpos attributes)
  76       (positions-xml-tag-contents tag xmlstr start-xmlstr end-xmlstr)
  77     (if (and startpos endpos)
  78         (values (subseq xmlstr startpos endpos) nextpos attributes)
  79       (values nil nil nil))))
  80
  81 (defun cdata-string (str)
  82   (concatenate 'string "<![CDATA[" str "]]>"))
  83
  84 (defun write-cdata (str s)
  85   (declare (simple-string str) (optimize (speed 3) (safety 0) (space 0)))
  86   (do ((len (length str))
  87        (i 0 (1+ i)))
  88       ((= i len) str)
  89     (declare (fixnum i len))
  90     (let ((c (schar str i)))
  91       (case c
  92         (#\< (write-string "&lt;" s))
  93         (#\& (write-string "&amp;" s))
  94         (t   (write-char c s))))))
  95
  96 (defun xml-declaration-stream (stream &key (version "1.0") standalone encoding)
  97   (format stream "<?xml version=\"~A\"~A~A ?>~%"
  98           version
  99           (if encoding
 100               (format nil " encoding=\"~A\"" encoding)
 101               ""
 102               )
 103           (if standalone
 104               (format nil " standalone=\"~A\"" standalone)
 105               "")))
 106
 107 (defun doctype-stream (stream top-element availability registered organization type
 108                        label language url entities)
 109   (format stream "<!DOCTYPE ~A ~A \"~A//~A//~A ~A//~A\"" top-element
 110           availability (if registered "+" "-") organization type label language)
 111
 112   (when url
 113     (write-char #\space stream)
 114     (write-char #\" stream)
 115     (write-string url stream)
 116     (write-char #\" stream))
 117
 118   (when entities
 119     (format stream " [~%~A~%]" entities))
 120
 121   (write-char #\> stream)
 122   (write-char #\newline stream))
 123
 124 (defun doctype-format (stream format &key top-element (availability "PUBLIC")
 125                        (registered nil) organization (type "DTD") label
 126                        (language "EN") url entities)
 127   (case format
 128     ((:xhtml11 :xhtml)
 129      (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.1" language
 130                      (if url url "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd")
 131                      entities))
 132     (:xhtml10-strict
 133      (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Strict" language
 134                      (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-strict.dtd")
 135                      entities))
 136     (:xhtml10-transitional
 137      (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Transitional" language
 138                      (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-transitional.dtd")
 139                      entities))
 140     (:xhtml-frameset
 141      (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Frameset" language
 142                      (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-frameset.dtd")
 143                      entities))
 144     (:html2
 145      (doctype-stream stream "HTML" availability registered "IETF" type "HTML" language url entities))
 146     (:html3
 147      (doctype-stream stream "HTML" availability registered "IETF" type "HTML 3.0" language url entities))
 148     (:html3.2
 149      (doctype-stream stream "HTML" availability registered "W3C" type "HTML 3.2 Final" language url entities))
 150     ((:html :html4)
 151      (doctype-stream stream "HTML" availability registered "W3C" type "HTML 4.01 Final" language url entities))
 152     ((:docbook :docbook42)
 153      (doctype-stream stream (if top-element top-element "book")
 154                      availability registered "OASIS" type "Docbook XML 4.2" language
 155                      (if url url "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd")
 156                      entities))
 157     (t
 158      (unless top-element (warn "Missing top-element in doctype-format"))
 159      (unless organization (warn "Missing organization in doctype-format"))
 160      (unless label (warn "Missing label in doctype-format"))
 161      (doctype-stream stream top-element availability registered organization type label language url
 162                      entities))))
 163
 164
 165 (defun sgml-header-stream (format stream &key entities (encoding "iso-8859-1") standalone (version "1.0")
 166                           top-element (availability "PUBLIC") registered organization (type "DTD")
 167                            label (language "EN") url)
 168   (when (in format :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional :xhtml10-frameset :xml :docbook)
 169     (xml-declaration-stream stream :version version :encoding encoding :standalone standalone))
 170   (unless (eq :xml format)
 171     (doctype-format stream format :top-element top-element
 172                     :availability availability :registered registered
 173                     :organization organization :type type :label label :language language
 174                     :url url :entities entities))
 175   stream)
 176