From 12cc606da91b6c42ada94ebef911931ef066bb9a Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 17 May 2017 15:37:59 -0700 Subject: [PATCH] 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. --- src/Makefile.in | 1 + src/etc/plugins.scm | 1 + src/ffi/build.scm | 407 ++++++++++++++++++++++++++++------------ src/ffi/ffi.pkg | 4 +- src/runtime/ffi.scm | 11 +- src/runtime/runtime.pkg | 4 +- 6 files changed, 304 insertions(+), 124 deletions(-) create mode 100644 src/etc/plugins.scm 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\n") out) - (for-each - (lambda (name.title) - (write-string "
  • " out) - (write-string (cdr name.title) out) - (write-string "
    • \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 "None currently installed.\n" out) - '())))) - (lambda (a b) (string" 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" + "\n") out) + + ;; Write new list. + (let ((names.titles (html-names.titles plugins scmhtmldir))) + (for-each + (lambda (name.title) + (write-string "
  • " out) + (write-string (cdr name.title) out) + (write-string "
    • \n" out)) + names.titles) + (if (null? names.titles) + (write-string "None currently installed.\n" out))) + + ;; Skip old list. + (do ((line (read-line in) (read-line in))) + ((or (eof-object? line) + (string-prefix? "" 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 "\\(.*\\)" 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) -- 2.25.1