From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Mon, 1 May 2017 05:05:33 +0000 (-0700)
Subject: ffi/build: Fix add/remove-plugin handling of compressed files.
X-Git-Tag: mit-scheme-pucked-9.2.12~146
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c660cccb8fb0fd2622e30e7ed6bd60575b03cf6f;p=mit-scheme.git

ffi/build: Fix add/remove-plugin handling of compressed files.
---

diff --git a/src/ffi/build.scm b/src/ffi/build.scm
index d823c14d5..099d3fcf0 100644
--- a/src/ffi/build.scm
+++ b/src/ffi/build.scm
@@ -34,21 +34,21 @@ USA.
   (update-plugin 'remove name project infodir scmlibdir scmdocdir))
 
 (define (update-plugin operation name project infodir scmlibdir scmdocdir)
-  (let ((scmlibdir (pathname-as-directory scmlibdir))
+  (let ((scmlibdir (->namestring (pathname-as-directory scmlibdir)))
 	(infodir (and (not (string-null? infodir))
-		      (pathname-as-directory infodir)))
+		      (->namestring (pathname-as-directory infodir))))
 	(scmdocdir (and (not (string-null? scmdocdir))
-			(pathname-as-directory scmdocdir))))
+			(->namestring (pathname-as-directory scmdocdir)))))
     (let ((plugins (updated-plugin-list operation name scmlibdir)))
       (update-optiondb plugins scmlibdir)
       (update-info-index project plugins infodir scmdocdir)
       (update-html-index plugins scmdocdir))))
 
 (define (updated-plugin-list operation plugin scmlibdir)
-  (let ((pathname (merge-pathnames "plugins.scm" scmlibdir)))
-    (if (file-exists? pathname)	 ;i.e. NOT in dpkg-buildpackage chroot
+  (let ((filename (string scmlibdir"/plugins.scm")))
+    (if (file-exists? filename)	 ;i.e. NOT in dpkg-buildpackage chroot
 	(rewrite-file
-	 pathname
+	 filename
 	 (lambda (in out)
 	   (cond ((eq? operation 'add)
 		  (let ((new (cons plugin (delete! plugin (read in)))))
@@ -61,14 +61,14 @@ USA.
 		 (else
 		  (error "Unexpected plugin-list operation:" operation)))))
 	(begin
-	  (warn "plugin list not found:" pathname)
+	  (warn "plugin list not found:" filename)
 	  '()))))
 
 (define (update-optiondb plugins scmlibdir)
-  (let ((pathname (merge-pathnames "optiondb.scm" scmlibdir)))
-    (if (file-exists? pathname)		;i.e. NOT in dpkg-buildpackage chroot
+  (let ((filename (string scmlibdir"/optiondb.scm")))
+    (if (file-exists? filename)		;i.e. NOT in dpkg-buildpackage chroot
 	(rewrite-file
-	 pathname
+	 filename
 	 (lambda (in out)
 	   (copy-to+line "(further-load-options" in out)
 	   (write-string (string ";;; DO NOT EDIT the remainder of this file."
@@ -82,23 +82,21 @@ USA.
 	       (write-string name out)
 	       (write-string "\"))\n" out))
 	     (sort plugins string<?))))
-	(warn "optiondb not found:" pathname))))
+	(warn "optiondb not found:" filename))))
 
 (define (update-info-index project plugins infodir scmdocdir)
-  (let ((pathname (and infodir
-		       (merge-pathnames (string project".info") infodir))))
-    (if (and pathname
-	     (file-exists-or-compressed? pathname))
+  (let ((filename (and infodir (string infodir"/"project".info"))))
+    (if (and filename (file-exists-or-compressed? filename))
 	(rewrite-file
-	 pathname
+	 filename
 	 (lambda (in out)
 	   (copy-to+line "Plugin Manuals" in out)
 	   (newline out)
 	   (for-each (lambda (plugin)
 		       (write-direntry project plugin scmdocdir out))
 		     (sort plugins string<?))))
-	(if pathname
-	    (warn "Scheme Info index not found:" pathname)))))
+	(if filename
+	    (warn "Scheme Info index not found:" filename)))))
 
 (define (write-direntry project plugin scmdocdir out)
   (load-option-quietly 'regular-expression)
@@ -121,11 +119,11 @@ USA.
 		      line))))))))))
 
 (define (update-html-index plugins scmdocdir)
-  (let* ((scmhtmldir (merge-pathnames "html/" scmdocdir))
-	 (pathname (merge-pathnames "index.html" scmhtmldir)))
-    (if (file-exists? pathname)
+  (let* ((scmhtmldir (string scmdocdir"/html"))
+	 (filename (string scmhtmldir"/index.html")))
+    (if (file-exists? filename)
 	(rewrite-file
-	 pathname
+	 filename
 	 (lambda (in out)
 	   (copy-to+line "<ul id=\"plugins\"" in out)
 	   (newline out)
@@ -161,26 +159,24 @@ USA.
 	       ((eof-object? line))
 	     (write-string line out)
 	     (newline out))))
-	(warn "Scheme html index not found:" pathname))))
+	(warn "Scheme html index not found:" filename))))
 
 (define (html-names.titles plugins scmhtmldir)
-  (let ((base (pathname-new-type (merge-pathnames scmhtmldir) "html")))
-    (append-map!
-     (lambda (plugin)
-       (let ((pathname (merge-pathnames plugin base)))
-	 (if (file-exists? pathname)
-	     (list (cons plugin (read-html-title pathname)))
-	     '())))
-     plugins)))
-
-(define (read-html-title pathname)
+  (append-map! (lambda (plugin)
+		 (let ((filename (string scmhtmldir"/"plugin".html")))
+		   (if (file-exists? filename)
+		       (list (cons plugin (read-html-title filename)))
+		       '())))
+	       plugins))
+
+(define (read-html-title filename)
   (load-option-quietly 'regular-expression)
-  (call-with-input-file pathname
+  (call-with-input-file filename
     (lambda (in)
       (let loop ()
 	(let ((line (read-line in)))
 	  (if (eof-object? line)
-	      (error "Could not find HTML title:" pathname)
+	      (error "Could not find HTML title:" filename)
 	      (let ((regs (re-string-match "<title>\\(.*\\)</title>" line)))
 		(if (not regs)
 		    (loop)
@@ -273,18 +269,18 @@ USA.
     ("bz2" "bzip2" . "bunzip2")
     ("Z" "compress" . "uncompress")))
 
-(define (file-exists-or-compressed? pathname)
-  (or (file-exists? pathname)
-      (let ((filename (->namestring pathname)))
-	(find (lambda (suffix.progs)
-		(file-exists? (string filename"."(car suffix.progs))))
-	      compressed-file-suffixes.progs))))
+(define (file-exists-or-compressed? filename)
+  (or (file-exists? filename)
+      (find-compressed-suffix.progs filename)))
 
 (define (compressed? filename)
   (and (not (file-exists? filename))
-       (find (lambda (suffix.progs)
-	       (file-exists? (string filename"."(car suffix.progs))))
-	     compressed-file-suffixes.progs)))
+       (find-compressed-suffix.progs filename)))
+
+(define (find-compressed-suffix.progs filename)
+  (find (lambda (suffix.progs)
+	  (file-exists? (string filename"."(car suffix.progs))))
+	compressed-file-suffixes.progs))
 
 (define (un/compress-file program infile outfile)
   (let ((cmdline (string program" < '"infile"' > '"outfile"'")))