feat(third_party/lisp/s-xml): Check in sources & derivation r/438

Checked in the sources for this because it is tracked upstream in CVS
and I can't be bothered to deal with that right now.

1 files changed, 83 insertions, 0 deletions

diff --git a/third_party/lisp/s-xml/src/lxml-dom.lisp b/third_party/lisp/s-xml/src/lxml-dom.lisp
new file mode 100644
index 000000000000..d43df6cf8171
--- /dev/null
+++ b/third_party/lisp/s-xml/src/lxml-dom.lisp
@@ -0,0 +1,83 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: lxml-dom.lisp,v 1.5 2005/09/20 09:57:44 scaekenberghe Exp $
+;;;;
+;;;; LXML implementation of the generic DOM parser and printer.
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+;;; the lxml hooks to generate lxml
+
+(defun lxml-new-element-hook (name attributes seed)
+  (declare (ignore name attributes seed))
+  '())
+
+(defun lxml-finish-element-hook (name attributes parent-seed seed)
+  (let ((xml-element
+	 (cond ((and (null seed) (null attributes))
+		name)
+	       (attributes
+		`((,name ,@(let (list)
+			     (dolist (attribute attributes list)
+			       (push (cdr attribute) list)
+			       (push (car attribute) list))))
+		  ,@(nreverse seed)))
+	       (t
+		`(,name ,@(nreverse seed))))))
+    (cons xml-element parent-seed)))
+
+(defun lxml-text-hook (string seed)
+  (cons string seed))
+
+;;; standard DOM interfaces
+
+(defmethod parse-xml-dom (stream (output-type (eql :lxml)))
+  (car (start-parse-xml stream
+			(make-instance 'xml-parser-state
+				       :new-element-hook #'lxml-new-element-hook
+				       :finish-element-hook #'lxml-finish-element-hook
+				       :text-hook #'lxml-text-hook))))
+
+(defun plist->alist (plist)
+  (when plist 
+    (cons (cons (first plist) (second plist))
+          (plist->alist (rest (rest plist))))))
+
+(defmethod print-xml-dom (dom (input-type (eql :lxml)) stream pretty level)
+  (declare (special *namespaces*))
+  (cond ((symbolp dom) (print-solitary-tag dom stream))
+	((stringp dom) (print-string-xml dom stream))
+	((consp dom)
+	 (let (tag attributes)
+	   (cond ((symbolp (first dom)) (setf tag (first dom)))
+		 ((consp (first dom)) (setf tag (first (first dom)) 
+                                            attributes (plist->alist (rest (first dom)))))
+		 (t (error "Input not recognized as LXML ~s" dom)))
+           (let ((*namespaces* (extend-namespaces attributes *namespaces*)))
+             (write-char #\< stream) 
+             (print-identifier tag stream)
+             (loop :for (name . value) :in attributes 
+                   :do (print-attribute name value stream))
+             (if (rest dom)
+                 (let ((children (rest dom)))
+                   (write-char #\> stream)
+                   (if (and (= (length children) 1) (stringp (first children)))
+                       (print-string-xml (first children) stream)
+                     (progn
+                       (dolist (child children)
+                         (when pretty (print-spaces (* 2 level) stream))
+                         (if (stringp child)
+                             (print-string-xml child stream)
+                           (print-xml-dom child input-type stream pretty (1+ level))))
+                       (when pretty (print-spaces (* 2 (1- level)) stream))))
+                   (print-closing-tag tag stream))
+               (write-string "/>" stream)))))
+	(t (error "Input not recognized as LXML ~s" dom))))
+  
+;;;; eof
\ No newline at end of file