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: xml-utils.lisp,v 1.11 2003/06/07 22:34:16 kevin Exp $
  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 (defun wrap-with-xml (str entity)
  23   "Returns string of xml header along with entity tag start/end with str contents"
  24   (format nil "<?xml version=\"1.0\" standalone=\"yes\"?>~%~%<~a>~%~a~%</~a>~%"
  25           str entity entity))
  26
  27
  28 ;;; XML Extraction Functions
  29
  30 (defun find-start-tag (tag taglen xmlstr start end)
  31   "Searches for the start of a tag in an xmlstring. Returns STARTPOS ATTRIBUTE-LIST)"
  32   (declare (simple-string tag xmlstr)
  33            (fixnum taglen start end)
  34            (optimize (speed 3) (safety 0) (space 0)))
  35   (do* ((search-str (concatenate 'string "<" tag))
  36         (search-len (1+ taglen))
  37         (bracketpos (fast-string-search search-str xmlstr search-len start end)
  38                     (fast-string-search search-str xmlstr search-len start end)))
  39        ((null bracketpos) nil)
  40     (let* ((endtag (+ bracketpos 1 taglen))
  41            (char-after-tag (schar xmlstr endtag)))
  42       (when (or (char= #\> char-after-tag)
  43                 (char= #\space char-after-tag))
  44         (if (char= #\> char-after-tag)
  45             (return-from find-start-tag (values (1+ endtag) nil))
  46             (let ((endbrack (position-char #\> xmlstr (1+ endtag) end)))
  47               (if endbrack
  48                   (return-from find-start-tag
  49                     (values (1+ endbrack)
  50                             (string-to-list-skip-delimiter
  51                              (subseq xmlstr endtag endbrack))))
  52                   (values nil nil)))))
  53       (setq start endtag))))
  54
  55
  56 (defun find-end-tag (tag taglen xmlstr start end)
  57   (fast-string-search
  58    (concatenate 'string "</" tag ">") xmlstr
  59    (+ taglen 3) start end))
  60
  61 (defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
  62                                        (end-xmlstr (length xmlstr)))
  63   "Returns three values: the start and end positions of contents between
  64  the xml tags and the position following the close of the end tag."
  65   (let* ((taglen (length tag)))
  66     (multiple-value-bind (start attributes)
  67         (find-start-tag tag taglen xmlstr start-xmlstr end-xmlstr)
  68       (unless start
  69         (return-from positions-xml-tag-contents (values nil nil nil nil)))
  70       (let ((end (find-end-tag tag taglen xmlstr start end-xmlstr)))
  71         (unless end
  72           (return-from positions-xml-tag-contents (values nil nil nil nil)))
  73         (values start end (+ end taglen 3) attributes)))))
  74
  75
  76 (defun xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
  77                          (end-xmlstr (length xmlstr)))
  78   "Returns two values: the string between XML start and end tag
  79 and position of character following end tag."
  80   (multiple-value-bind
  81       (startpos endpos nextpos attributes)
  82       (positions-xml-tag-contents tag xmlstr start-xmlstr end-xmlstr)
  83     (if (and startpos endpos)
  84         (values (subseq xmlstr startpos endpos) nextpos attributes)
  85       (values nil nil nil))))
  86
  87 (defun xml-cdata (str)
  88   (concatenate 'string "<![CDATA[" str "]]>"))
  89
  90 (defun write-xml-cdata (str s)
  91   (declare (simple-string str) (optimize (speed 3) (safety 0) (space 0)))
  92   (do ((len (length str))
  93        (i 0 (1+ i)))
  94       ((= i len) str)
  95     (declare (fixnum i len))
  96     (let ((c (schar str i)))
  97       (case c
  98         (#\< (write-string "&lt;" s))
  99         (#\& (write-string "&amp;" s))
 100         (t   (write-char c s))))))
 101