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.10 2003/06/07 05:45:14 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 #|
  31 #+allegro (require :pxml)
  32 #+allegro
  33 (defun parse-xml-no-ws (str)
  34   "Return list structure of XML string with removing whitespace strings"
  35   (remove-tree-if #'string-ws? (parse-xml str)))
  36 |#
  37
  38
  39
  40 (defun find-start-tag (tag taglen xmlstr start-pos end-xmlstr)
  41   "Searches for the start of a tag in an xmlstring. Returns (VALUES STARTPOS ATTRIBUTE-LIST)"
  42   (declare (simple-string tag xmlstr)
  43            (fixnum taglen start-pos end-xmlstr))
  44   (do* ((search-str (concatenate 'string "<" tag))
  45         (bracketpos (fast-string-search search-str xmlstr
  46                                       (1+ taglen) start-pos end-xmlstr)
  47                   (fast-string-search search-str xmlstr
  48                                       (1+ taglen) start-pos end-xmlstr)))
  49        ((null bracketpos) nil)
  50     (let* ((endtag (+ bracketpos 1 taglen))
  51            (char-after-tag (schar xmlstr endtag)))
  52       (when (or (char= #\> char-after-tag)
  53                 (char= #\space char-after-tag))
  54         (if (char= #\> char-after-tag)
  55             (return-from find-start-tag (values (1+ endtag) nil))
  56             (let ((endbrack (position-char #\> xmlstr (1+ endtag) end-xmlstr)))
  57               (if endbrack
  58                   (return-from find-start-tag
  59                     (values (1+ endbrack)
  60                             (string-to-list-skip-delimiter
  61                              (subseq xmlstr endtag endbrack))))
  62                   (values nil nil)))))
  63       (setq start-pos endtag))))
  64
  65
  66 (defun find-end-tag (tag taglen xmlstr start-pos end-xmlstr)
  67   (fast-string-search
  68    (concatenate 'string "</" tag ">") xmlstr
  69    (+ taglen 3) start-pos end-xmlstr))
  70
  71 (defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
  72                                        (end-xmlstr (length xmlstr)))
  73   "Returns three values: the start and end positions of contents between
  74  the xml tags and the position following the close of the end tag."
  75   (let* ((taglen (length tag)))
  76     (multiple-value-bind (start attributes)
  77         (find-start-tag tag taglen xmlstr start-xmlstr end-xmlstr)
  78       (unless start
  79         (return-from positions-xml-tag-contents (values nil nil nil nil)))
  80       (let ((end (find-end-tag tag taglen xmlstr start end-xmlstr)))
  81         (unless end
  82           (return-from positions-xml-tag-contents (values nil nil nil nil)))
  83         (values start end (+ end taglen 3) attributes)))))
  84
  85
  86 (defun xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
  87                          (end-xmlstr (length xmlstr)))
  88   "Returns two values: the string between XML start and end tag
  89 and position of character following end tag."
  90   (multiple-value-bind
  91       (startpos endpos nextpos attributes)
  92       (positions-xml-tag-contents tag xmlstr start-xmlstr end-xmlstr)
  93     (if (and startpos endpos)
  94         (values (subseq xmlstr startpos endpos) nextpos attributes)
  95       (values nil nil nil))))
  96
  97 (defun xml-cdata (str)
  98   (concatenate 'string "<![CDATA[" str "]]>"))
  99
 100 (defun write-xml-cdata (str s)
 101   (declare (simple-string str) (optimize (speed 3) (safety 0) (space 0)))
 102   (do ((len (length str))
 103        (i 0 (1+ i)))
 104       ((= i len) str)
 105     (declare (fixnum i len))
 106     (let ((c (schar str i)))
 107       (case c
 108         (#\< (write-string "&lt;" s))
 109         (#\& (write-string "&amp;" s))
 110         (t   (write-char c s))))))
 111