From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Wed, 17 May 2017 22:37:59 +0000 (-0700)
Subject: Add add-plugin and remove-plugin; maintain an Info index.
X-Git-Tag: mit-scheme-pucked-9.2.12~14^2~52
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=12cc606da91b6c42ada94ebef911931ef066bb9a;p=mit-scheme.git

Add add-plugin and remove-plugin; maintain an Info index.

The postrm Debian installation scripts do not work if they are run
after the core package is removed.  And prerm scripts do not work if
they update indexes based on what is installed.  (The package being
removed is still installed.)  Replace update-html-index and update-
optiondb-index with add-plugin and remove-plugin, procedures that
add/remove names to/from a list.  These work in prerm scripts.
---

diff --git a/src/Makefile.in b/src/Makefile.in
index 21b8a1829..6091dca86 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -934,6 +934,7 @@ install-standard: install-auxdir-top
 install-auxdir-top:
 	$(mkinstalldirs) $(DESTDIR)$(AUXDIR)
 	$(INSTALL_DATA) $(top_srcdir)/etc/optiondb.scm $(DESTDIR)$(AUXDIR)/.
+	$(INSTALL_DATA) $(top_srcdir)/etc/plugins.scm $(DESTDIR)$(AUXDIR)/.
 	$(INSTALL_DATA) lib/*.com $(DESTDIR)$(AUXDIR)/.
 
 .PHONY: default-target all all-native all-liarc macosx-app
diff --git a/src/etc/plugins.scm b/src/etc/plugins.scm
new file mode 100644
index 000000000..dd626a0f3
--- /dev/null
+++ b/src/etc/plugins.scm
@@ -0,0 +1 @@
+()
\ No newline at end of file
diff --git a/src/ffi/build.scm b/src/ffi/build.scm
index e5fe314aa..776a68bf4 100644
--- a/src/ffi/build.scm
+++ b/src/ffi/build.scm
@@ -27,125 +27,302 @@ USA.
 ;;;; Build Utilities
 ;;; package: (ffi build)
 
-(define (write-file name writer)
-  (let ((tmp (pathname-new-type name "tmp")))
-    (call-with-exclusive-output-file tmp writer)
-    (rename-file tmp name)))
-
-(define (rewrite-file name rewriter)
-  (write-file
-   name
-   (lambda (out)
-     (call-with-input-file name
-       (lambda (in)
-	 (rewriter in out))))))
-
-(define (update-optiondb directory)
-  (rewrite-file
-   (merge-pathnames "optiondb.scm" directory)
-   (lambda (in out)
-     (do ((line (read-line in) (read-line in)))
-	 ((or (eof-object? line)
-	      (string-prefix? "(further-load-options" line))
-	  (if (not (eof-object? line))
-	      (begin
-		(write-string line out)
-		(newline out))))
-       (write-string line out)
-       (newline out))
-     (write-string
-      (string-append ";;; DO NOT EDIT the remainder of this file."
-		     "  Any edits will be clobbered."
-		     "\n") out)
-     (for-each
-       (lambda (name)
-	 (write-string "\n(define-load-option '" out)
-	 (write-string name out)
-	 (write-string "\n  (standard-system-loader \"" out)
-	 (write-string name out)
-	 (write-string "\"))\n" out))
-       ;; plugin-names
-       (sort
-	(let loop ((files (directory-read directory))
-		   (names '()))
-	  (if (pair? files)
-	      (loop (cdr files)
-		    (if (and (file-directory? (car files))
-			     ;; The only core subsystem with a make.scm:
-			     (not (string=? "ffi" (pathname-name (car files))))
-			     (file-exists?
-			      (merge-pathnames "make.scm"
-					       (pathname-as-directory
-						(car files)))))
-			(cons (pathname-name (car files)) names)
-			names))
-	      names))
-	string<?)))))
-
-(define (update-html-index directory)
-  (rewrite-file
-   (merge-pathnames "index.html" directory)
-   (lambda (in out)
-     (do ((line (read-line in) (read-line in)))
-	 ((or (eof-object? line)
-	      (string-prefix? "<ul id=\"plugins\"" line))
-	  (if (not (eof-object? line))
-	      (begin
-		(write-string line out)
-		(newline out))))
-       (write-string line out)
-       (newline out))
-     (write-string (string-append "<!-- DO NOT EDIT this list."
-				  "  Any edits will be clobbered. -->\n") out)
-     (for-each
-       (lambda (name.title)
-	 (write-string "<li><a href=\"" out)
-	 (write-string (car name.title) out)
-	 (write-string ".html\">" out)
-	 (write-string (cdr name.title) out)
-	 (write-string "</a></li>\n" out))
-       (sort
-	(let loop ((files (directory-read directory))
-		   (names.titles '()))
-	  (if (pair? files)
-	      (loop (cdr files)
-		    (if (and (pathname-type (car files))
-			     (string=? "html" (pathname-type (car files)))
-			     (string-prefix? "mit-scheme-"
-					     (pathname-name (car files))))
-			(let ((name (pathname-name (car files)))
-			      (title (read-html-title (car files))))
-			  (cons (cons name title) names.titles))
-			names.titles))
-	      (if (pair? names.titles)
-		  names.titles
-		  (begin
-		    (write-string "<i>None currently installed.</i>\n" out)
-		    '()))))
-	(lambda (a b) (string<? (car a) (car b)))))
-     ;; Skip old list.
-     (do ((line (read-line in) (read-line in)))
-	 ((or (eof-object? line)
-	      (string-prefix? "</ul>" line))
-	  (if (eof-object? line)
-	      (error "Premature end of HTML index.")
-	      (begin
-		(write-string line out)
-		(newline out)))))
-     ;; Copy the rest.
-     (do ((line (read-line in) (read-line in)))
-	 ((eof-object? line))
-       (write-string line out)
-       (newline out)))))
-
-(define (read-html-title pathname)
-  (call-with-input-file pathname
+(define (add-plugin name project infodir scmlibdir scmdocdir)
+  (update-plugin 'add name project infodir scmlibdir scmdocdir))
+
+(define (remove-plugin name project infodir scmlibdir scmdocdir)
+  (update-plugin 'remove name project infodir scmlibdir scmdocdir))
+
+(define (update-plugin operation name project infodir scmlibdir scmdocdir)
+  (let ((scmlibdir (->namestring (pathname-as-directory scmlibdir)))
+	(infodir (and (not (string-null? infodir))
+		      (->namestring (pathname-as-directory infodir))))
+	(scmdocdir (and (not (string-null? 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 ((filename (string scmlibdir"plugins.scm")))
+    (if (file-exists? filename)	 ;i.e. NOT in dpkg-buildpackage chroot
+	(rewrite-file
+	 filename
+	 (lambda (in out)
+	   (cond ((eq? operation 'add)
+		  (let ((new (cons plugin (delete! plugin (read in)))))
+		    (write new out)
+		    new))
+		 ((eq? operation 'remove)
+		  (let ((new (delete! plugin (read in))))
+		    (write new out)
+		    new))
+		 (else
+		  (error "Unexpected plugin-list operation:" operation)))))
+	(begin
+	  (warn "plugin list not found:" filename)
+	  '()))))
+
+(define (update-optiondb plugins scmlibdir)
+  (let ((filename (string scmlibdir"optiondb.scm")))
+    (if (file-exists? filename)		;i.e. NOT in dpkg-buildpackage chroot
+	(rewrite-file
+	 filename
+	 (lambda (in out)
+	   (copy-to+line "(further-load-options" in out)
+	   (write-string (string ";;; DO NOT EDIT the remainder of this file."
+				 "  Any edits will be clobbered."
+				 "\n") out)
+	   (for-each
+	     (lambda (name)
+	       (write-string "\n(define-load-option '" out)
+	       (write-string name out)
+	       (write-string "\n  (standard-system-loader \"" out)
+	       (write-string name out)
+	       (write-string "\"))\n" out))
+	     (sort plugins string<?))))
+	(warn "optiondb not found:" filename))))
+
+(define (update-info-index project plugins infodir scmdocdir)
+  (if infodir
+      (let ((filename (string infodir project".info")))
+	(if (file-exists-or-compressed? filename)
+	    (rewrite-file
+	     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<?))))
+	    (warn "Scheme Info index not found:" filename)))))
+
+(define (write-direntry project plugin scmdocdir out)
+  (load-option-quietly 'regular-expression)
+  (let ((filename (string scmdocdir"info/"plugin".info")))
+    (if (file-exists-or-compressed? filename)
+	(call-with-input-file-uncompressed
+	 filename
+	 (lambda (in)
+	   (skip-to-line "START-INFO-DIR-ENTRY" in)
+	   (transform-to-line
+	    "END-INFO-DIR-ENTRY" in out #f
+	    (let ((project-dir-patt (string "("project"/")))
+	      (lambda (line)
+		(let ((regs (re-string-search-forward project-dir-patt line)))
+		  (if regs
+		      (string (substring line 0 (re-match-start-index 0 regs))
+			      "("scmdocdir"info/"
+			      (substring line (re-match-end-index 0 regs)))
+		      line))))))))))
+
+(define (update-html-index plugins scmdocdir)
+  (let* ((scmhtmldir (if (file-exists? (string scmdocdir"html/index.html"))
+			 (string scmdocdir"html/")
+			 scmdocdir))
+	 (filename (string scmhtmldir"index.html")))
+    (if (file-exists? filename)
+	(rewrite-file
+	 filename
+	 (lambda (in out)
+	   (copy-to+line "<ul id=\"plugins\"" in out)
+	   (newline out)
+	   (write-string (string-append "<!-- DO NOT EDIT this list."
+					"  Any edits will be clobbered. -->"
+					"\n") out)
+
+	   ;; Write new list.
+	   (let ((names.titles (html-names.titles plugins scmhtmldir)))
+	     (for-each
+	       (lambda (name.title)
+		 (write-string "<li><a href=\"" out)
+		 (write-string (car name.title) out)
+		 (write-string ".html\">" out)
+		 (write-string (cdr name.title) out)
+		 (write-string "</a></li>\n" out))
+	       names.titles)
+	     (if (null? names.titles)
+		 (write-string "<i>None currently installed.</i>\n" out)))
+
+	   ;; Skip old list.
+	   (do ((line (read-line in) (read-line in)))
+	       ((or (eof-object? line)
+		    (string-prefix? "</ul>" line))
+		(if (eof-object? line)
+		    (error "Premature end of HTML index.")
+		    (begin
+		      (write-string line out)
+		      (newline out)))))
+
+	   ;; Copy the rest.
+	   (do ((line (read-line in) (read-line in)))
+	       ((eof-object? line))
+	     (write-string line out)
+	     (newline out))))
+	(warn "Scheme html index not found:" filename))))
+
+(define (html-names.titles plugins scmhtmldir)
+  (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 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)
-		    (re-match-extract line regs 1)))))))))
\ No newline at end of file
+		    (re-match-extract line regs 1)))))))))
+
+(define (copy-to+line prefix in out)
+  (transform-to-line prefix in out #t #f))
+
+(define (copy-to-line prefix in out)
+  (transform-to-line prefix in out #f #f))
+
+(define (transform-to-line prefix in out inclusive? transform)
+  (do ((line (read-line in) (read-line in)))
+      ((or (eof-object? line)
+	   (string-prefix? prefix line))
+       (if (eof-object? line)
+	   (error "Copied to eof without seeing line:" prefix))
+       (if inclusive?
+	   (let ((line* (if transform (transform line) line)))
+	     (write-string line* out)
+	     (newline out))))
+    (write-string (if transform (transform line) line) out)
+    (newline out)))
+
+(define (skip-to-line prefix in)
+  (do ((line (read-line in) (read-line in)))
+      ((or (eof-object? line)
+	   (string-prefix? prefix line))
+       (if (eof-object? line)
+	   (error "Skipped to eof without seeing line:" prefix)))))
+
+(define (rewrite-file filename rewriter)
+  (let ((suffix.progs (compressed? filename)))
+    (if suffix.progs
+	(rewrite-compressed-file filename suffix.progs rewriter)
+	(rewrite-simple-file filename rewriter))))
+
+(define (rewrite-simple-file filename rewriter)
+  (let ((replacement (replacement-filename filename)))
+    (if (file-exists? replacement)
+	(delete-file replacement))
+    (with-temporary-file
+     replacement
+     (lambda ()
+       (let ((value (call-with-exclusive-output-file
+		     replacement
+		     (lambda (out)
+		       (call-with-input-file filename
+			 (lambda (in)
+			   (rewriter in out)))))))
+	 (rename-file replacement filename)
+	 value)))))
+
+(define (rewrite-compressed-file filename suffix.progs rewriter)
+  (load-option-quietly 'synchronous-subprocess)
+  (let ((compressed (string filename"."(car suffix.progs))))
+    (call-with-temporary-file-pathname
+     (lambda (uncompressed)
+       (un/compress-file (cddr suffix.progs)
+			 compressed
+			 (->namestring uncompressed))
+       (call-with-temporary-file-pathname
+	(lambda (transformed)
+	  (let ((value
+		 (call-with-input-file uncompressed
+		   (lambda (in)
+		     (call-with-output-file transformed
+		       (lambda (out)
+			 (rewriter in out)))))))
+	    (let ((replacement (replacement-filename filename)))
+	      (if (file-exists? replacement)
+		  (delete-file replacement))
+	      (with-temporary-file
+	       replacement
+	       (lambda ()
+		 (un/compress-file (cadr suffix.progs)
+				   (->namestring transformed)
+				   replacement)
+		 (rename-file replacement compressed))))
+	    value)))))))
+
+(define (call-with-input-file-uncompressed filename receiver)
+  (let ((suffix.progs (compressed? filename)))
+    (if suffix.progs
+	(let ((compressed (string filename"."(car suffix.progs))))
+	  (call-with-temporary-file-pathname
+	   (lambda (uncompressed)
+	     (un/compress-file (cddr suffix.progs)
+			       compressed
+			       (->namestring uncompressed))
+	     (call-with-input-file uncompressed receiver))))
+	(call-with-input-file filename receiver))))
+
+(define compressed-file-suffixes.progs
+  '(("gz" "gzip" . "gunzip")
+    ("bz2" "bzip2" . "bunzip2")
+    ("Z" "compress" . "uncompress")))
+
+(define (file-exists-or-compressed? filename)
+  (or (file-exists? filename)
+      (find-compressed-suffix.progs filename)))
+
+(define (compressed? filename)
+  (and (not (file-exists? filename))
+       (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)
+  (load-option 'synchronous-subprocess)
+  (let ((cmdline (string program" < "infile" > "outfile)))
+    (if (not (zero? (run-shell-command cmdline)))
+	(error "File un/compress failed:" cmdline))))
+
+(define (replacement-filename filename)
+  (let ((pathname (->pathname filename)))
+    (string (directory-namestring pathname)
+	    "."(file-namestring pathname)"."(random-alphanumeric-string 6))))
+
+(define (random-alphanumeric-string length)
+  (list->string (map (lambda (i) i (random-alphanumeric-character))
+		     (iota length))))
+
+(define (random-alphanumeric-character)
+  (integer->char
+   (let ((n (random 62)))
+    (cond ((< n 26) (+ (char->integer #\a) n))
+	  ((< n 52) (+ (char->integer #\A) (- n 26)))
+	  (else     (+ (char->integer #\0) (- n 52)))))))
+
+(define (load-option-quietly name)
+  (if (not (option-loaded? name))
+      (let ((kernel
+	     (lambda ()
+	       (parameterize* (list (cons param:suppress-loading-message? #t))
+		 (lambda ()
+		   (load-option name))))))
+	(if (nearest-cmdl/batch-mode?)
+	    (kernel)
+	    (with-notification
+	     (lambda (port)
+	       (write-string "Loading " port)
+	       (write-string (symbol->string name) port)
+	       (write-string " option" port))
+	     kernel)))))
\ No newline at end of file
diff --git a/src/ffi/ffi.pkg b/src/ffi/ffi.pkg
index b3943fd73..c8c246cde 100644
--- a/src/ffi/ffi.pkg
+++ b/src/ffi/ffi.pkg
@@ -41,5 +41,5 @@ FFI System Packaging |#
   (parent ())
   (files "build")
   (export (ffi)
-	  update-optiondb
-	  update-html-index))
\ No newline at end of file
+	  add-plugin
+	  remove-plugin))
\ No newline at end of file
diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index f835a2afa..ef9017668 100644
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -593,14 +593,15 @@ USA.
   (load-option-quietly 'ffi)
   ((environment-lookup (->environment '(ffi)) 'c-generate) library prefix))
 
-(define (update-optiondb directory)
+(define (add-plugin name project infodir scmlibdir scmdocdir)
   (load-option-quietly 'ffi)
-  ((environment-lookup (->environment '(ffi)) 'update-optiondb) directory))
+  ((environment-lookup (->environment '(ffi)) 'add-plugin)
+   name project infodir scmlibdir scmdocdir))
 
-(define (update-html-index directory)
+(define (remove-plugin name project infodir scmlibdir scmdocdir)
   (load-option-quietly 'ffi)
-  (load-option-quietly 'regular-expression)
-  ((environment-lookup (->environment '(ffi)) 'update-html-index) directory))
+  ((environment-lookup (->environment '(ffi)) 'remove-plugin)
+   name project infodir scmlibdir scmdocdir))
 
 (define (load-option-quietly name)
   (if (not (option-loaded? name))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 13ffdb6be..dfe7e87d0 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3650,8 +3650,8 @@ USA.
 	  plugin-available?
 	  register-c-callback
 	  set-alien/ctype!
-	  update-html-index
-	  update-optiondb)
+	  add-plugin
+	  remove-plugin)
   (initialization (initialize-package!)))
 
 (define-package (runtime program-copier)