[bknr-cvs] r1938 - branches/xml-class-rework/projects/bos/m2

[bknr at bknr.net]

Author: hhubner
Date: 2006-03-17 14:20:46 -0500 (Fri, 17 Mar 2006)
New Revision: 1938

Modified:
   branches/xml-class-rework/projects/bos/m2/cert-daemon.lisp
Log:
Properly close pipes generated by the cert generator.


Modified: branches/xml-class-rework/projects/bos/m2/cert-daemon.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/cert-daemon.lisp	2006-03-17 19:20:10 UTC (rev 1937)
+++ branches/xml-class-rework/projects/bos/m2/cert-daemon.lisp	2006-03-17 19:20:46 UTC (rev 1938)
@@ -1,13 +1,15 @@
 (in-package :bos.m2.cert-generator)
 
 (defun run-tool (program &optional program-args &rest args)
-  (let ((process (apply #'run-program program program-args :output :stream args)))
+  (let* ((process (apply #'run-program program program-args :output :stream args))
+         (error-message (unless (zerop (process-exit-code process))
+                          (with-output-to-string (*standard-output*)
+                            (with-open-stream (output-stream (process-output process))
+                              (princ (read-line output-stream)))))))
+    (process-close process)
     (unless (zerop (process-exit-code process))
-      (let ((error-message (with-output-to-string (*standard-output*)
-			     (with-open-stream (output-stream (process-output process))
-			       (princ (read-line output-stream))))))
-	(error "Error executing ~A - Exit code ~D~%Error message: ~A"
-	       (format nil "\"~A~{ ~A~}\"" program program-args) (process-exit-code process) error-message)))))
+      (error "Error executing ~A - Exit code ~D~%Error message: ~A"
+             (format nil "\"~A~{ ~A~}\"" program program-args) (process-exit-code process) error-message))))
 
 (defun fill-form (fdf-pathname pdf-pathname output-pathname)
   (handler-case