Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 5954314a8b
Fetching contributors…

Cannot retrieve contributors at this time

121 lines (100 sloc) 4.419 kb
;; @module XML
;; @author Jeff Ober <jeffober@gmail.com>, Kanen Flowers <kanendosei@gmail.com>
;; @version 2.1
;; @location http://static.artfulcode.net/newlisp/xml.lsp
;; @package http://static.artfulcode.net/newlisp/xml.qwerty
;; @description Parsing and serializing of XML data (updated for newlisp 10).
;; Functions to parse XML text (non-validating) and serialize lisp structures to XML.
;; Requires matching and newlisp 10.
;; <h4>Version history</h4>
;; <b>2.1</b>
;; &bull; code clean-up
;; &bull; updated for newlisp 10
;; &bull; some arguments have changed in lisp->xml and xml->lisp
;; &bull; default encoding is now determined by newlisp UTF-8 compile options
;; &bull; added functions to trim whitespace and decode entities
;;
;; <b>2.0</b>
;; &bull; complete rewrite
;; &bull; added XML-compliant entities
;; &bull; automatic serialization of data
;;
;; <b>1.0</b>
;; &bull; initial release
;;;============================================================================
;;; XML context
;;;============================================================================
(context 'XML)
(constant 'trim-ws-re (regex-comp {(^\s*)|(\s*$)} ))
(constant 'xml-entity-decode-re (regex-comp "&#(\\d{1,4});"))
(constant 'xml-entity-encode-re (regex-comp (string "(" (join (map (fn (i) (format {\x%x} i)) '(34 38 39 60 62)) "|") ")")))
(constant 'default-parse-options (+ 1 16))
;; @syntax (XML:trim-whitespace <str>)
;; @param <str> a string
;; <p>Trims all whitespace off both ends of <str>.</p>
(define (trim-whitespace text)
(replace trim-ws-re text "" 0x10000)
text)
;; @syntax (XML:decode <str>)
;; @param <str> a string
;; <p>Decodes XML entities and converts them to characters.</p>
(define (decode str)
(replace xml-entity-decode-re str (char (int $1)) 0x10000))
;; @syntax (XML:encode <str>)
;; @param <str> a string
;; <p>Encodes characters in a string to be valid for XML.</p>
(define (encode str)
(replace xml-entity-encode-re str (string "&#" (char $1) ";") 0x10000))
(define (parse-string text (options default-parse-options) , old-tags parsed)
(setf old-tags (xml-type-tags))
(xml-type-tags nil nil nil nil)
(setf parsed (xml-parse text options))
(apply xml-type-tags old-tags)
parsed)
(define (serialize-attributes attr-list)
(match-let ((attrs) (@ *) attr-list)
(join (map (fn (pair) (format " %s=\"%s\"" (map string pair))) attrs) "")))
(define (opening-tag node)
(match-let ((tag attr _) (? ? *) node)
(string "<" tag (serialize-attributes attr) ">")))
(define (closing-tag node)
(string "</" (first node) ">"))
(define (empty-tag node)
(match-let ((tag attr _) (? ? *) node)
(string "<" tag (serialize-attributes attr) " />")))
(define (serialize-text-node node)
(match-let ((tag attr text) (? ? ?) node)
(string (opening-tag node) (encode (decode text)) (closing-tag node))))
(define (serialize xml indent? (encoding (if utf8 "UTF-8" "ASCII")) (depth 0), buf)
(setf buf "")
(when (zero? depth)
(write-buffer buf (string {<?xml version="1.0" encoding="} encoding {" ?>} "\n"))
(setf xml (first xml)))
(when indent? (write-buffer buf (string "\n" (dup " " depth))))
(write-buffer buf
(cond
((match '(? ?) xml) (empty-tag xml))
((match '(? ? ?) xml) (serialize-text-node xml))
((match '(? ? *) xml)
(string
(opening-tag xml)
(join (map (fn (child) (serialize child indent? nil (+ 1 depth))) (rest (rest xml))))
(if indent? (string "\n" (dup " " depth)) "")
(closing-tag xml)))))
buf)
;; @syntax (XML:lisp->xml <sxml-list> [<indent?> [<str-encoding>]])
;; @param <sxml-list> an SXML list
;; @param <indent?> optional; whether or not to format the resulting XML (default nil)
;; @param <str-encoding> optional; sets the encoding in the declaration
;; <p>Serializes an SXML list (equivalent to parsing an XML document with
;; (xml-type-tags nil nil nil nil) and options 1 and 16). The encoding in the
;; declaration defaults to UTF-8 if newlisp was compiled with UTF-8 support,
;; ASCII otherwise.</p>
(setf lisp->xml serialize)
;; @syntax (XML:xml->lisp <str-xml>)
;; @param <str-xml> an XML string
;; <p>Parses <str-xml> and returns an SXML list. Uses newlisp's built-in parser.</p>
;; <p>Equivalent to:</p>
;; <pre>(begin (xml-type-tags nil nil nil) (xml-parse <str-xml> (+ 1 16)))</pre>
(setf xml->lisp parse-string)
(context 'MAIN)
Jump to Line
Something went wrong with that request. Please try again.