1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
(in-package kmrcl)
(defpackage docbook
(:use #:cl #:cl-who #:kmrcl)
(:export
#:docbook-file
#:docbook-stream
#:xml-file->sexp-file
))
(in-package docbook)
(defmacro docbook-stream (stream tree)
`(progn
(print-prologue ,stream)
(write-char #\Newline ,stream)
(let (cl-who::*indent* t)
(cl-who:with-html-output (,stream) ,tree))))
(defun print-prologue (stream)
(write-string "<?xml version='1.0' ?> <!-- -*- DocBook -*- -->" stream)
(write-char #\Newline stream)
(write-string "<!DOCTYPE book PUBLIC \"-//OASIS//DTD DocBook XML V4.2//EN\"" stream)
(write-char #\Newline stream)
(write-string " \"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd\" [" stream)
(write-char #\Newline stream)
(write-string "<!ENTITY % myents SYSTEM \"entities.xml\">" stream)
(write-char #\Newline stream)
(write-string "%myents;" stream)
(write-char #\Newline stream)
(write-string "]>" stream)
(write-char #\Newline stream))
(defmacro docbook-file (name tree)
(let ((%name (gensym)))
`(let ((,%name ,name))
(with-open-file (stream ,%name :direction :output
:if-exists :supersede)
(docbook-stream stream ,tree))
(values))))
#+allegro
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'pxml)
(require 'uri))
(defun is-whitespace-string (s)
(and (stringp s)
(kmrcl:is-string-whitespace s)))
(defun atom-processor (a)
(when a
(typecase a
(symbol
(nth-value 0 (kmrcl:ensure-keyword a)))
(string
(kmrcl:collapse-whitespace a))
(t
a))))
(defun entity-callback (var token &optional public)
(declare (ignore token public))
(cond
((and (net.uri:uri-scheme var)
(string= "http" (net.uri:uri-scheme var)))
nil)
(t
(let ((path (net.uri:uri-path var)))
(if (probe-file path)
(ignore-errors (open path))
(make-string-input-stream
(let ((*print-circle* nil))
(format nil "<!ENTITY ~A '~A'>" path path))))))))
#+allegro
(defun xml-file->sexp-file (file &key (preprocess nil))
(let* ((path (etypecase file
(string (parse-namestring file))
(pathname file)))
(new-path (make-pathname :defaults path
:type "sexp"))
raw-sexp)
(if preprocess
(multiple-value-bind (xml error status)
(kmrcl:command-output (format nil
"sh -c \"export XML_CATALOG_FILES='~A'; cd ~A; xsltproc --xinclude pprint.xsl ~A\""
"catalog-debian.xml"
(namestring (make-pathname :defaults (if (pathname-directory path)
path
*default-pathname-defaults*)
:name nil :type nil))
(namestring path)))
(unless (and (zerop status) (or (null error) (zerop (length error))))
(error "Unable to preprocess XML file ~A, status ~D.~%Error: ~A"
path status error))
(setq raw-sexp (net.xml.parser:parse-xml
(apply #'concatenate 'string xml)
:content-only nil)))
(with-open-file (input path :direction :input)
(setq raw-sexp (net.xml.parser:parse-xml input :external-callback #'entity-callback))))
(with-open-file (output new-path :direction :output
:if-exists :supersede)
(let ((filtered (kmrcl:remove-from-tree-if #'is-whitespace-string
raw-sexp
#'atom-processor)))
(write filtered :stream output :pretty t))))
(values))
|