From 8f5bd5e1126f1866921eb247ef55ed5b32c966f9 Mon Sep 17 00:00:00 2001
From: Ludovic Court`es
Date: Tue, 14 Feb 2006 14:26:42 +0000
Subject: Implemented `lout-illustration' for non-Lout engines.

* src/guile/skribilo/engine/lout.scm (lout-illustration): Implemented for
  Guile and non-Lout engines.

git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-43
---
 src/guile/skribilo/engine/lout.scm | 72 ++++++++++++++++++--------------------
 1 file changed, 35 insertions(+), 37 deletions(-)

(limited to 'src/guile')

diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm
index c2339ca..de6fb3e 100644
--- a/src/guile/skribilo/engine/lout.scm
+++ b/src/guile/skribilo/engine/lout.scm
@@ -1,6 +1,6 @@
 ;;; lout.scm  --  A Lout engine.
 ;;;
-;;; Copyright 2004, 2005  Ludovic Courtès <ludovic.courtes@laas.fr>
+;;; Copyright 2004, 2005, 2006  Ludovic Courtès <ludovic.courtes@laas.fr>
 ;;;
 ;;;
 ;;; This program is free software; you can redistribute it and/or modify
@@ -24,6 +24,7 @@
 
 
 (define-skribe-module (skribilo engine lout)
+  :autoload (ice-9 popen)   (open-output-pipe)
   :autoload (ice-9 rdelim)  (read-line))
 
 
@@ -2780,6 +2781,8 @@
 ;*    Illustrations                                                    */
 ;*---------------------------------------------------------------------*/
 (define-public (lout-illustration . args)
+  ;; FIXME: This should be a markup.
+
   ;; Introduce a Lout illustration (such as a diagram) whose code is either
   ;; the body of `lout-illustration' or the contents of `file'.  For engines
   ;; other than Lout, an EPS file is produced and then converted if needed.
@@ -2833,46 +2836,41 @@
 			(file-contents file))))
       (if (engine-format? "lout")
 	  (! contents) ;; simply inline the illustration
-	  (cond-expand
-	   (bigloo
-	    (let* ((lout (find-engine 'lout))
-		   (output (string-append (or ident
-					      (symbol->string
-					       (gensym 'lout-illustration)))
-					  ".eps"))
-		   (proc (run-process (or (engine-custom lout
-							 'lout-program-name)
-					  "lout")
-				      "-o" output
-				      "-EPS"
-				      input: pipe:))
-		   (port (process-input-port proc)))
-
-	      ;; send the illustration to Lout's standard input
-	      (display (illustration-header) port)
-	      (display contents port)
-	      (display (illustration-ending) port)
-	      (close-output-port port)
-
-	      (process-wait proc)
-	      (if (not (= 0 (process-exit-status proc)))
+	  (let* ((lout (find-engine 'lout))
+		 (output (string-append (or ident
+					    (symbol->string
+					     (gensym 'lout-illustration)))
+					".eps"))
+		 (port (open-output-pipe
+			(string-append (or (engine-custom lout
+							  'lout-program-name)
+					   "lout")
+				       " -o " output
+				       " -EPS"))))
+
+	    ;; send the illustration to Lout's standard input
+	    (display (illustration-header) port)
+	    (display contents port)
+	    (display (illustration-ending) port)
+
+	    (let ((exit-val (status:exit-val (close-pipe port))))
+	      (if (not (eqv? 0 exit-val))
 		  (skribe-error 'lout-illustration
-				"lout exited with error code"
-				(process-exit-status proc)))
-	      (if (not (file-exists? output))
-		  (skribe-error 'lout-illustration "file not created"
-				output))
-	      (if (= 0 (file-size output))
+				"lout exited with error code" exit-val)))
+
+	    (if (not (file-exists? output))
+		(skribe-error 'lout-illustration "file not created"
+			      output))
+
+	    (let ((file-info (false-if-exception (stat output))))
+	      (if (or (not file-info)
+		      (= 0 (stat:size file-info)))
 		  (skribe-error 'lout-illustration
-				"empty output file" output))
+				"empty output file" output)))
 
-	      ;; the image
-	      (image :file output alt)))
+	    ;; the image (FIXME: Should set its location)
+	    (image :file output alt))))))
 
-	   (else ;; Unfortunately, chances are low that STklos has the same
-	         ;; process API as the one Bigloo has.
-	    (skribe-error 'lout
-			  "lout-illustration: Not implemented" file)))))))
 
 
 ;*---------------------------------------------------------------------*/
-- 
cgit v1.2.3