From: Kevin M. Rosenberg Date: Thu, 13 Nov 2003 10:29:37 +0000 (+0000) Subject: r8183: docbook functions X-Git-Tag: v1.96~109 X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=commitdiff_plain;h=035b66e6fe51559e2db70691ddcae4ab641a4873 r8183: docbook functions --- diff --git a/debian/changelog b/debian/changelog index 579b28c..90276d0 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-kmrcl (1.59-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Wed, 12 Nov 2003 16:25:54 -0700 + cl-kmrcl (1.58-1) unstable; urgency=low * New upstream diff --git a/docbook.lisp b/docbook.lisp new file mode 100644 index 0000000..4f7447a --- /dev/null +++ b/docbook.lisp @@ -0,0 +1,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 " " stream) + (write-char #\Newline stream) + (write-string "" 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 "" 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)) + + diff --git a/lists.lisp b/lists.lisp index 35e74ba..336baa0 100644 --- a/lists.lisp +++ b/lists.lisp @@ -42,13 +42,15 @@ (unless (find elem l1) (setq l1 (append l1 (list elem)))))) -(defun remove-from-tree-if (pred tree) +(defun remove-from-tree-if (pred tree atom-processor) "Strip from tree of atoms that satistify predicate" (if (atom tree) (unless (funcall pred tree) - tree) - (let ((car-strip (remove-from-tree-if pred (car tree))) - (cdr-strip (remove-from-tree-if pred (cdr tree)))) + (if atom-processor + (funcall atom-processor tree) + tree)) + (let ((car-strip (remove-from-tree-if pred (car tree) atom-processor)) + (cdr-strip (remove-from-tree-if pred (cdr tree) atom-processor))) (cond ((and car-strip (atom (cadr tree)) (null cdr-strip)) (list car-strip)) diff --git a/os.lisp b/os.lisp index 9b193ab..b31d4ba 100644 --- a/os.lisp +++ b/os.lisp @@ -13,10 +13,56 @@ (in-package #:kmrcl) +(defun command-output (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, +returns (VALUES string-output error-output exit-status)" + (let ((command (apply #'format nil control-string args))) + #+sbcl + (sb-impl::process-exit-code + (sb-ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output nil)) + + #+(or cmu scl) + (ext:process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output nil)) + + + #+allegro + (multiple-value-bind (output error status) + (excl.osi:command-output command) + (values output error status)) + + #+lispworks + (system:call-system-showing-output + command + :shell-type "/bin/sh" + :output-stream output) + + #+clisp ;XXX not exactly *verbose-out*, I know + (ext:run-shell-command command :output :terminal :wait t) + + #+openmcl + (nth-value 1 + (ccl:external-process-status + (ccl:run-program "/bin/sh" (list "-c" command) + :input nil :output nil + :wait t))) + + #-(or openmcl clisp lispworks allegro scl cmu sbcl) + (error "RUN-SHELL-PROGRAM not implemented for this Lisp") + + )) + (defun run-shell-command (control-string &rest args) "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and synchronously execute the result using a Bourne-compatible shell, -returns (VALUES string-output exit-code)" +returns (VALUES output-string pid)" (let ((command (apply #'format nil control-string args))) #+sbcl (sb-impl::process-exit-code @@ -32,13 +78,14 @@ returns (VALUES string-output exit-code)" (list "-c" command) :input nil :output nil)) + #+allegro - (multiple-value-bind (output dummy exit) + (multiple-value-bind (output dummy pid) (excl:run-shell-command command :input nil :output :stream :wait nil) (declare (ignore dummy)) - (values output exit)) - + (values output pid)) + #+lispworks (system:call-system-showing-output command diff --git a/package.lisp b/package.lisp index eeaf204..033f31e 100644 --- a/package.lisp +++ b/package.lisp @@ -67,7 +67,8 @@ #:string-strip-ending #:string-maybe-shorten #:shrink-vector - + #:collapse-whitespace + ;; io.lisp #:indent-spaces #:indent-html-spaces @@ -245,8 +246,9 @@ #:fformat ;; os.lisp - #:run-shell-command - + #:command-output + #:run-shell-command-output-stream + ;; color.lisp #:rgb->hsv #:rgb255->hsv255 diff --git a/strings.lisp b/strings.lisp index fd2f37c..a97c37b 100644 --- a/strings.lisp +++ b/strings.lisp @@ -603,3 +603,23 @@ for characters in a string" +(defun collapse-whitespace (s) + "Convert multiple whitespace characters to a single space character." + (declare (simple-string s) + (optimize (speed 3) (safety 0))) + (with-output-to-string (stream) + (do ((pos 0 (1+ pos)) + (in-white nil) + (len (length s))) + ((= pos len)) + (declare (fixnum pos len)) + (let ((c (schar s pos))) + (declare (character c)) + (cond + ((kl:is-char-whitespace c) + (unless in-white + (write-char #\space stream)) + (setq in-white t)) + (t + (setq in-white nil) + (write-char c stream)))))))