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