;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          xml-utils.lisp
;;;; Purpose:       XML utilities
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Apr 2000
;;;;
;;;; $Id$
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************

(in-package #:kmrcl)


(defun wrap-with-xml (str entity)
  "Returns string of xml header along with entity tag start/end with str contents"
  (format nil "<?xml version=\"1.0\" standalone=\"yes\"?>~%~%<~a>~%~a~%</~a>~%" 
	  str entity entity))


;;; XML Extraction Functions

(defun find-start-tag (tag taglen xmlstr start end)
  "Searches for the start of a tag in an xmlstring. Returns STARTPOS ATTRIBUTE-LIST)"
  (declare (simple-string tag xmlstr)
	   (fixnum taglen start end)
	   (optimize (speed 3) (safety 0) (space 0)))
  (do* ((search-str (concatenate 'string "<" tag))
	(search-len (1+ taglen))
	(bracketpos (fast-string-search search-str xmlstr search-len start end)
		    (fast-string-search search-str xmlstr search-len start end)))
       ((null bracketpos) nil)
    (let* ((endtag (+ bracketpos 1 taglen))
	   (char-after-tag (schar xmlstr endtag)))
      (when (or (char= #\> char-after-tag)
		(char= #\space char-after-tag))
	(if (char= #\> char-after-tag) 
	    (return-from find-start-tag (values (1+ endtag) nil))
	    (let ((endbrack (position-char #\> xmlstr (1+ endtag) end)))
	      (if endbrack
		  (return-from find-start-tag
		    (values (1+ endbrack)
			    (string-to-list-skip-delimiter
			     (subseq xmlstr endtag endbrack))))
		  (values nil nil)))))
      (setq start endtag))))


(defun find-end-tag (tag taglen xmlstr start end)
  (fast-string-search
   (concatenate 'string "</" tag ">") xmlstr
   (+ taglen 3) start end))
  
(defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
				       (end-xmlstr (length xmlstr)))
  "Returns three values: the start and end positions of contents between
 the xml tags and the position following the close of the end tag."
  (let* ((taglen (length tag)))
    (multiple-value-bind (start attributes)
	(find-start-tag tag taglen xmlstr start-xmlstr end-xmlstr)
      (unless start
	(return-from positions-xml-tag-contents (values nil nil nil nil)))
      (let ((end (find-end-tag tag taglen xmlstr start end-xmlstr)))
	(unless end
	  (return-from positions-xml-tag-contents (values nil nil nil nil)))
	(values start end (+ end taglen 3) attributes)))))


(defun xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
			 (end-xmlstr (length xmlstr)))
  "Returns two values: the string between XML start and end tag 
and position of character following end tag."
  (multiple-value-bind 
      (startpos endpos nextpos attributes) 
      (positions-xml-tag-contents tag xmlstr start-xmlstr end-xmlstr)
    (if (and startpos endpos)
	(values (subseq xmlstr startpos endpos) nextpos attributes)
      (values nil nil nil))))

(defun xml-cdata (str)
  (concatenate 'string "<![CDATA[" str "]]>"))

(defun write-xml-cdata (str s)
  (declare (simple-string str) (optimize (speed 3) (safety 0) (space 0)))
  (do ((len (length str))
       (i 0 (1+ i)))
      ((= i len) str)
    (declare (fixnum i len))
    (let ((c (schar str i)))
      (case c
	(#\< (write-string "&lt;" s))
	(#\& (write-string "&amp;" s))
	(t   (write-char c s))))))