From 882f36bccf9cdbbe46747480a4c50eaa15bb41cc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 21 Apr 2015 18:02:19 +0900 Subject: [PATCH] Adding proper program installation for chicken, plus tests. --- lib/chibi/snow/commands.scm | 131 +++++++++++++++++++++----- lib/chibi/snow/package.scm | 20 +++- lib/chibi/snow/package.sld | 1 + tests/snow/repo3/pingala/triangle.scm | 16 ++++ tests/snow/snow-tests.scm | 33 ++++++- tools/snow-chibi | 6 +- 6 files changed, 175 insertions(+), 32 deletions(-) create mode 100644 tests/snow/repo3/pingala/triangle.scm diff --git a/lib/chibi/snow/commands.scm b/lib/chibi/snow/commands.scm index 3999f8ea..5901d87e 100644 --- a/lib/chibi/snow/commands.scm +++ b/lib/chibi/snow/commands.scm @@ -62,6 +62,13 @@ (warn "ignoring unknown implementation: " (car ls)) (lp (cdr ls) res)))))) +(define (conf-program-implementation? impl cfg) + (cond ((conf-get cfg 'program-implementation) + => (lambda (x) (eq? impl x))) + (else + (let ((ls (conf-selected-implementations cfg))) + (or (null? ls) (eq? impl (car ls))))))) + (define (conf-for-implementation cfg impl) (conf-specialize cfg 'implementation impl)) @@ -248,8 +255,9 @@ (append (if (pair? deps) (list (cons depends (reverse deps))) '()) (if (pair? cond-deps) (reverse cond-deps) '()))))))) -(define (make-package-name cfg libs . o) - (let ((name (any (lambda (x) (or (library-name x) (program-name x))) libs)) +(define (make-package-name cfg pkg libs . o) + (let ((name (or (assoc-get pkg 'name) + (any (lambda (x) (or (library-name x) (program-name x))) libs))) (version (and (pair? o) (car o)))) (cond ((not (and (pair? name) (list? name))) @@ -384,6 +392,7 @@ (conf-get cfg '(command package output-dir) ".") (make-package-name cfg + package-spec (filter (lambda (x) (and (pair? x) (memq (car x) '(library program)))) package-spec) (package-output-version cfg))))) @@ -436,6 +445,7 @@ (define (package-spec+files cfg spec libs) (let* ((recursive? (conf-get cfg '(command package recursive?))) (programs (conf-get-list cfg '(command package programs))) + (name (conf-get cfg '(command package name))) (authors (conf-get-list cfg '(command package authors))) (test (package-test cfg)) (version (package-output-version cfg)) @@ -447,7 +457,8 @@ `(,@(if license `((license ,license)) '()) ,@(if version `((version ,version)) '()) ,@(if (pair? authors) `((authors ,@authors)) '()) - ,@(if (pair? maintainers) `((maintainers ,@maintainers)) '()))) + ,@(if (pair? maintainers) `((maintainers ,@maintainers)) '()) + ,@(if name `((name ,name)) '()))) (files '()) (lib-dirs '()) (test test) @@ -838,11 +849,13 @@ (for-each warn-delete-file (package-installed-files pkg)) (warn-delete-file (make-path (get-install-source-dir impl cfg) (get-package-meta-file cfg pkg))) - (let ((dir (make-path (get-install-source-dir impl cfg) - (package->path cfg pkg)))) - (if (and (file-directory? dir) - (= 2 (length (directory-files dir)))) - (delete-directory dir)))) + (cond + ((package->path cfg pkg) + => (lambda (path) + (let ((dir (make-path (get-install-source-dir impl cfg) path))) + (if (and (file-directory? dir) + (= 2 (length (directory-files dir)))) + (delete-directory dir))))))) (define (command/remove cfg spec . args) (let* ((impls (conf-selected-implementations cfg)) @@ -1077,6 +1090,20 @@ (else (list (make-path "/usr/local/share/snow" impl))))) +(define (scheme-script-command impl cfg) + (or (and (eq? impl 'chibi) (conf-get cfg 'chibi-path)) + (let* ((prog (cond ((assq impl known-implementations) => cadr) + (else "scheme-script"))) + (path (or (find-in-path prog) prog)) + (arg (case impl + ((chicken) "-s") + ((gauche) "-b") + ((larceny) "-program") + (else #f)))) + (if (and path arg) + (string-append path " " arg) + path)))) + (define (scheme-program-command impl cfg file . o) (let ((lib-path (and (pair? o) (car o))) (install-dir (get-install-source-dir impl cfg))) @@ -1130,8 +1157,11 @@ dirs (lambda (x) (and (package? x) - (any (lambda (y) (equal? name (library-name y))) - (package-libraries x))))) + (or (equal? name (package-name x)) + (any (lambda (y) (equal? name (library-name y))) + (package-libraries x)) + (any (lambda (y) (equal? name (program-name y))) + (package-programs x)))))) (and (pair? (cdr subname)) (lp (drop-right subname 1))))))) @@ -1250,7 +1280,7 @@ (define (install-file cfg source dest) (if (install-with-sudo? cfg dest) (system "sudo" "cp" source dest) - (copy-file source dest))) + (system "cp" source dest))) (define (install-sexp-file cfg obj dest) (if (install-with-sudo? cfg dest) @@ -1334,14 +1364,6 @@ (install-file cfg (make-path dir imp-path) dest-imp-path) (list dest-so-path dest-imp-path))) -(define (default-program-installer impl cfg prog dir) - (let* ((program-file (get-program-file cfg prog)) - (dest-program-file (program-install-name prog)) - (install-dir (get-install-binary-dir impl cfg))) - (let ((path (make-path install-dir dest-program-file))) - (install-directory cfg (path-directory path)) - (install-file cfg (make-path dir program-file) path)))) - ;; installers should return the list of installed files (define (lookup-installer installer) (case installer @@ -1443,8 +1465,65 @@ (builder-for-implementation impl cfg))))) (builder impl cfg library dir))) +;; strip extension, add #! if needed, copy and chmod +(define (default-program-builder impl cfg prog dir) + (let* ((path (make-path dir (get-program-file cfg prog))) + (dest (path-strip-extension path)) + (src-lines (call-with-input-file path port->string-list)) + (script (scheme-script-command impl cfg))) + (if (equal? path dest) + (system "cp" path (string-append path ".bak"))) + (call-with-output-file dest + (lambda (out) + (when script + (display "#! " out) + (display script out) + (newline out)) + (for-each + (lambda (line) (display line out) (newline out)) + (if (and (pair? src-lines) (string-prefix? "#!" (car src-lines))) + (cdr src-lines) + src-lines)))) + (chmod dest #o755) + (system 'ls '-l dest) + prog)) + +(define (chicken-program-builder impl cfg prog dir) + (let ((path (get-program-file cfg prog))) + (with-directory + dir + (lambda () + (let ((res (system 'csc '-R 'r7rs '-X 'r7rs + '-I (path-directory path) path))) + (and (or (and (pair? res) (zero? (cadr res))) + (yes-or-no? cfg "chicken failed to build: " + path " - install anyway?")) + prog)))))) + +(define (lookup-program-builder builder) + (case builder + ((chicken) chicken-program-builder) + (else default-program-builder))) + +(define (program-builder-for-implementation impl cfg) + (case impl + ((chicken) 'chicken) + (else 'default))) + (define (build-program impl cfg prog dir) - #t) + (let ((builder (lookup-program-builder + (or (conf-get cfg 'program-builder) + (program-builder-for-implementation impl cfg))))) + (builder impl cfg prog dir))) + +(define (default-program-installer impl cfg prog dir) + (let* ((program-file (path-strip-extension (get-program-file cfg prog))) + (dest-program-file (program-install-name prog)) + (install-dir (get-install-binary-dir impl cfg))) + (let ((path (make-path install-dir dest-program-file))) + (install-directory cfg (path-directory path)) + (install-file cfg (make-path dir program-file) path) + (list path)))) (define (lookup-program-installer installer) (case installer @@ -1516,11 +1595,13 @@ (lambda (lib) (install-library impl cfg lib dir)) libs) - (append-map - (lambda (prog) - (build-program impl cfg prog dir) - (install-program impl cfg prog dir)) - (package-programs pkg))))) + (if (conf-program-implementation? impl cfg) + (append-map + (lambda (prog) + (build-program impl cfg prog dir) + (install-program impl cfg prog dir)) + (package-programs pkg)) + '())))) (install-package-meta-info impl cfg `(,@(remove (lambda (x) diff --git a/lib/chibi/snow/package.scm b/lib/chibi/snow/package.scm index 272016e5..8f5e92aa 100644 --- a/lib/chibi/snow/package.scm +++ b/lib/chibi/snow/package.scm @@ -167,6 +167,16 @@ (define (valid-library? lib) (not (invalid-library-reason lib))) +(define (invalid-program-reason prog) + (cond + ((not (list? prog)) "program must be a list") + ((not (or (assoc-get prog 'path) (assoc-get prog 'name))) + "program must have a path") + (else #f))) + +(define (valid-program? prog) + (not (invalid-program-reason prog))) + (define (invalid-package-reason pkg) (cond ((not (list? pkg)) @@ -174,10 +184,13 @@ ((not (string? (package-version pkg))) (failure "package-version is not a string" (package-version pkg))) (else - (let ((libs (package-libraries pkg))) + (let ((libs (package-libraries pkg)) + (progs (package-programs pkg))) (cond - ((not (pair? libs)) "package must contain at least one library") + ((and (not (pair? libs)) (not (pair? progs))) + "package must contain at least one library or program") ((any invalid-library-reason libs)) + ((any invalid-program-reason progs)) (else #f)))))) (define (valid-package? pkg) @@ -213,7 +226,8 @@ (define (package-dependencies impl cfg package) (append-map (lambda (lib) (library-dependencies cfg impl lib)) - (package-libraries package))) + (append (package-libraries package) + (package-programs package)))) (define (package-test-dependencies impl cfg package) (let ((pkg (package-for-impl impl cfg package))) diff --git a/lib/chibi/snow/package.sld b/lib/chibi/snow/package.sld index 5ed3d09b..7b38165f 100644 --- a/lib/chibi/snow/package.sld +++ b/lib/chibi/snow/package.sld @@ -18,6 +18,7 @@ get-program-file program-name program-install-name invalid-package-reason valid-package? invalid-library-reason valid-library? + invalid-program-reason valid-program? repo-find-publisher lookup-digest rsa-identity=? extract-rsa-private-key extract-rsa-public-key) (import (scheme base) diff --git a/tests/snow/repo3/pingala/triangle.scm b/tests/snow/repo3/pingala/triangle.scm new file mode 100644 index 00000000..c2ea67b9 --- /dev/null +++ b/tests/snow/repo3/pingala/triangle.scm @@ -0,0 +1,16 @@ +(import (scheme base) + (scheme write) + (scheme process-context) + (pingala binomial)) + +(let* ((args (command-line)) + (rows (or (and (pair? args) (pair? (cdr args)) + (string->number (cadr args))) + 5))) + (do ((i 0 (+ i 1))) + ((> i rows)) + (do ((j 0 (+ j 1))) + ((> j i) (newline)) + (if (not (zero? j)) + (write-char #\space)) + (write (binomial i j))))) diff --git a/tests/snow/snow-tests.scm b/tests/snow/snow-tests.scm index 67547101..b194a257 100644 --- a/tests/snow/snow-tests.scm +++ b/tests/snow/snow-tests.scm @@ -43,7 +43,7 @@ `(,chibi-path -A ,install-libdir "tools/snow-chibi" --always-no --implementations "chibi" - --chibi-path ,(string-append chibi-path " -A " install-libdir) + --chibi-path ,(string-append chibi-path " -A" install-libdir) --install-prefix ,install-prefix --local-user-repository "tests/snow/repo-cache" ,@args)) @@ -163,6 +163,10 @@ --version 1.0 --authors "Pingala" --description "Pingala's test framework" tests/snow/repo3/pingala/test-map.scm) +(snow package --output-dir tests/snow/repo3/ + --version 1.0 --authors "Pingala" --name "(pingala triangle)" + --description "Program to print a Sierpinski Triangle" + --programs tests/snow/repo3/pingala/triangle.scm) (snow index ,(cadr repo3)) (snow ,@repo3 update) (snow ,@repo3 install pingala.binomial) @@ -170,14 +174,37 @@ (test-assert (installed-version status '(pingala binomial))) (test-assert (installed-version status '(pingala factorial)))) +(snow ,@repo3 install pingala.triangle) +(test-assert (file-exists? "tests/snow/tmp-root/bin/triangle")) +(test "1 +1 1 +1 2 1 +1 3 3 1 +1 4 6 4 1 +1 5 10 10 5 1 +" + (process->string "tests/snow/tmp-root/bin/triangle")) +(test "1 +1 1 +1 2 1 +1 3 3 1 +" + (process->string '("tests/snow/tmp-root/bin/triangle" "3"))) + +(snow ,@repo3 remove pingala.triangle) +(test-not (file-exists? "tests/snow/tmp-root/bin/triangle")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; other implementations (snow ,@repo3 update) -(snow ,@repo3 --implementations "chicken" install pingala.binomial) +(snow ,@repo3 --implementations "chicken" --program-implementation "chicken" + install pingala.triangle) (let ((status (snow-status --implementations "chicken"))) (test-assert (installed-version status '(pingala binomial) 'chicken)) - (test-assert (installed-version status '(pingala factorial) 'chicken))) + (test-assert (installed-version status '(pingala factorial) 'chicken)) + (test "1\n1 1\n1 2 1\n1 3 3 1\n" + (process->string '("tests/snow/tmp-root/bin/triangle" "3")))) (snow ,@repo3 update) (snow ,@repo3 --implementations "foment" install pingala.binomial) diff --git a/tools/snow-chibi b/tools/snow-chibi index cb0e7676..cb301dec 100755 --- a/tools/snow-chibi +++ b/tools/snow-chibi @@ -74,7 +74,10 @@ (library-separator string "the separator to use for library components") (library-path (list string) "the path to search for local libraries") (installer symbol "name of installer to use") + (builder symbol "name of builder to use") + (program-builder symbol "name of program builder to use") (implementations (list symbol) "impls to install for, or 'all'") + (program-implementation symbol "impl to install programs for") (chibi-path filename "path to chibi-scheme executable") (sexp? boolean ("sexp") "output information in sexp format") )) @@ -110,7 +113,8 @@ (define verify-spec '()) (define package-spec - '((programs (list existing-filename)) + '((name sexp) + (programs (list existing-filename)) (authors (list string)) (maintainers (list string)) (recursive? boolean (#\r "recursive") "...")