Add recommended targets to debian/rules
[kmrcl.git] / docbook.lisp
1 (in-package kmrcl)
2
3 (defpackage docbook
4   (:use #:cl #:cl-who #:kmrcl)
5   (:export
6    #:docbook-file
7    #:docbook-stream
8    #:xml-file->sexp-file
9    ))
10 (in-package docbook)
11
12 (defmacro docbook-stream (stream tree)
13   `(progn
14      (print-prologue ,stream)
15      (write-char #\Newline ,stream)
16      (let (cl-who::*indent* t)
17        (cl-who:with-html-output (,stream) ,tree))))
18
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))
32
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))
39       (values))))
40
41 #+allegro
42 (eval-when (:compile-toplevel :load-toplevel :execute)
43   (require 'pxml)
44   (require 'uri))
45
46 (defun is-whitespace-string (s)
47   (and (stringp s)
48        (kmrcl:is-string-whitespace s)))
49
50 (defun atom-processor (a)
51   (when a
52     (typecase a
53       (symbol
54        (nth-value 0 (kmrcl:ensure-keyword a)))
55       (string
56        (kmrcl:collapse-whitespace a))
57       (t
58        a))))
59
60 (defun entity-callback (var token &optional public)
61   (declare (ignore token public))
62   (cond
63    ((and (net.uri:uri-scheme var)
64          (string= "http" (net.uri:uri-scheme var)))
65     nil)
66    (t
67     (let ((path (net.uri:uri-path var)))
68       (if (probe-file path)
69           (ignore-errors (open path))
70         (make-string-input-stream
71          (let ((*print-circle* nil))
72            (format nil "<!ENTITY ~A '~A'>" path path))))))))
73
74 #+allegro
75 (defun xml-file->sexp-file (file &key (preprocess nil))
76   (let* ((path (etypecase file
77                  (string (parse-namestring file))
78                  (pathname file)))
79          (new-path (make-pathname :defaults path
80                                   :type "sexp"))
81          raw-sexp)
82
83     (if preprocess
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\""
87                                           "catalog-debian.xml"
88                                           (namestring (make-pathname :defaults (if (pathname-directory path)
89                                                                                    path
90                                                                                  *default-pathname-defaults*)
91                                                                      :name nil :type nil))
92                                           (namestring path)))
93           (unless (and (zerop status) (or (null error) (zerop (length error))))
94             (error "Unable to preprocess XML file ~A, status ~D.~%Error: ~A"
95                    path status error))
96           (setq raw-sexp (net.xml.parser:parse-xml
97                           (apply #'concatenate 'string xml)
98                           :content-only nil)))
99       (with-open-file (input path :direction :input)
100         (setq raw-sexp (net.xml.parser:parse-xml input :external-callback #'entity-callback))))
101
102     (with-open-file (output new-path :direction :output
103                      :if-exists :supersede)
104       (let ((filtered (kmrcl:remove-from-tree-if #'is-whitespace-string
105                                                  raw-sexp
106                                                  #'atom-processor)))
107         (write filtered :stream output :pretty t))))
108   (values))
109
110