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.1 2002/10/06 13:21:47 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of Webutils, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; Webutils users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the GNU General Public License.
  16 ;;;; *************************************************************************
  17
  18 (in-package :webutils)
  19
  20 (declaim (optimize (speed 3) (safety 1)))
  21
  22
  23 (defun wrap-with-xml (str entity)
  24   "Returns string of xml header along with entity tag start/end with str contents"
  25   (format nil "<?xml version=\"1.0\" standalone=\"yes\"?>~%~%<~a>~%~a~%</~a>~%"
  26           str entity entity))
  27
  28
  29 ;;; XML Extraction Functions
  30
  31 #+allegro
  32 (defun parse-xml-no-ws (str)
  33   "Return list structure of XML string with removing whitespace strings"
  34   (remove-tree-if #'string-ws? (parse-xml str)))
  35
  36 (defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0) (end-xmlstr nil))
  37   "Returns three values: the start and end positions of contents between
  38  the xml tags and the position following the close of the end tag."
  39   (let ((done nil)
  40         (pos start-xmlstr)
  41         (taglen (length tag))
  42         (startpos nil)
  43         (endpos nil)
  44         (nextpos nil))
  45     (unless end-xmlstr
  46       (setq end-xmlstr (length xmlstr)))
  47     (while (not done)
  48            (let ((bracketpos (position #\< xmlstr :start pos :end end-xmlstr)))
  49              (if bracketpos
  50                  (let* ((starttag (1+ bracketpos))
  51                         (endtag (+ starttag taglen)))
  52                    (if (string= tag xmlstr :start2 starttag :end2 endtag)
  53                        (let* ((char-after-tag (char xmlstr endtag)))
  54                          (declare (character char-after-tag))
  55                          (if (or (char= #\> char-after-tag) (char= #\space char-after-tag))
  56                              (progn
  57                                (if (char= #\> char-after-tag)
  58                                    (setq startpos (1+ endtag))
  59                                  (setq startpos (1+ (position #\> xmlstr :start (1+ endtag)))))
  60                                (setq endpos (search (format nil "</~a>" tag) xmlstr
  61                                                     :start2 startpos :end2 end-xmlstr))
  62                                (setq done t)
  63                                (if (and startpos endpos)
  64                                    (progn
  65                                      (setq nextpos (+ endpos taglen 3))
  66                                      (setq pos nextpos))
  67                                  (setf startpos nil
  68                                        endpos nil)))
  69                            (setq pos (1+ endtag))))
  70                      (setq pos (1+ starttag)))
  71                    (when (> pos end-xmlstr)
  72                      (setq done t)))
  73                (setq done t))))
  74     (values startpos endpos nextpos)))
  75
  76
  77 (defun xml-tag-contents (tag xmlstr &optional (start-xmlstr 0) (end-xmlstr nil))
  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)
  82       (positions-xml-tag-contents tag xmlstr start-xmlstr end-xmlstr)
  83     (if (and startpos endpos)
  84         (values (subseq xmlstr startpos endpos) nextpos)
  85       (values nil nil))))
  86