4 (:use #:cl #:cl-who #:kmrcl)
12 (defmacro docbook-stream (stream tree)
14 (print-prologue ,stream)
15 (write-char #\Newline ,stream)
16 (let (cl-who::*indent* t)
17 (cl-who:with-html-output (,stream) ,tree))))
19 (defun print-prologue (stream)
20 (write-string "<?xml version='1.0' ?> <!-- -*- DocBook -*- -->" stream)
21 (write-char #\Newline stream)
22 (write-string "<!DOCTYPE book PUBLIC \"-//OASIS//DTD DocBook XML V4.2//EN\"" stream)
23 (write-char #\Newline stream)
24 (write-string " \"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd\" [" stream)
25 (write-char #\Newline stream)
26 (write-string "<!ENTITY % myents SYSTEM \"entities.xml\">" stream)
27 (write-char #\Newline stream)
28 (write-string "%myents;" stream)
29 (write-char #\Newline stream)
30 (write-string "]>" stream)
31 (write-char #\Newline stream))
33 (defmacro docbook-file (name tree)
34 (let ((%name (gensym)))
35 `(let ((,%name ,name))
36 (with-open-file (stream ,%name :direction :output
37 :if-exists :supersede)
38 (docbook-stream stream ,tree))
42 (eval-when (:compile-toplevel :load-toplevel :execute)
46 (defun is-whitespace-string (s)
48 (kmrcl:is-string-whitespace s)))
50 (defun atom-processor (a)
54 (nth-value 0 (kmrcl:ensure-keyword a)))
56 (kmrcl:collapse-whitespace a))
60 (defun entity-callback (var token &optional public)
61 (declare (ignore token public))
63 ((and (net.uri:uri-scheme var)
64 (string= "http" (net.uri:uri-scheme var)))
67 (let ((path (net.uri:uri-path var)))
69 (ignore-errors (open path))
70 (make-string-input-stream
71 (let ((*print-circle* nil))
72 (format nil "<!ENTITY ~A '~A'>" path path))))))))
75 (defun xml-file->sexp-file (file &key (preprocess nil))
76 (let* ((path (etypecase file
77 (string (parse-namestring file))
79 (new-path (make-pathname :defaults path
84 (multiple-value-bind (xml error status)
85 (kmrcl:command-output (format nil
86 "sh -c \"export XML_CATALOG_FILES='~A'; cd ~A; xsltproc --xinclude pprint.xsl ~A\""
88 (namestring (make-pathname :defaults (if (pathname-directory path)
90 *default-pathname-defaults*)
93 (unless (and (zerop status) (or (null error) (zerop (length error))))
94 (error "Unable to preprocess XML file ~A, status ~D.~%Error: ~A"
96 (setq raw-sexp (net.xml.parser:parse-xml
97 (apply #'concatenate 'string xml)
99 (with-open-file (input path :direction :input)
100 (setq raw-sexp (net.xml.parser:parse-xml input :external-callback #'entity-callback))))
102 (with-open-file (output new-path :direction :output
103 :if-exists :supersede)
104 (let ((filtered (kmrcl:remove-from-tree-if #'is-whitespace-string
107 (write filtered :stream output :pretty t))))