~ chicken-core (chicken-5) d4c09fd4be6da1da702142d5bde35f70d18ddc8f
commit d4c09fd4be6da1da702142d5bde35f70d18ddc8f
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Sep 4 22:27:02 2016 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Nov 13 11:32:58 2016 +0100
dropped old files
diff --git a/new-install.scm b/new-install.scm
deleted file mode 100644
index d7cfdcce..00000000
--- a/new-install.scm
+++ /dev/null
@@ -1,720 +0,0 @@
-;;;;
-
-(module main ()
-
-(import (scheme))
-(import (chicken))
-(import (chicken foreign))
-(import (chicken data-structures))
-(import (chicken keyword))
-(import (chicken files))
-(import (chicken format))
-(import (chicken irregex))
-(import (chicken tcp))
-(import (chicken ports))
-(import (chicken posix))
-(import (chicken io))
-(import (chicken time))
-(import (chicken pretty-print))
-
-(define +defaults-version+ 2)
-(define +module-db+ "modules.db")
-(define +defaults-file+ "setup.defaults")
-(define +short-options+ '(#\r #\h))
-(define +one-hour+ (* 60 60))
-(define +timestamp-file+ "TIMESTAMP")
-(define +status-file+ "STATUS")
-(define +egg-extension+ "egg")
-(define +egg-info-extension+ "egg.info")
-
-(include "mini-srfi-1.scm")
-(include "egg-environment.scm")
-(include "egg-compile.scm")
-(include "egg-download.scm")
-
-(define user-defaults #f)
-(define quiet #t)
-(define default-servers '())
-(define default-locations '())
-(define mappings '())
-(define aliases '())
-(define override '())
-(define hacks '())
-(define proxy-host #f)
-(define proxy-port #f)
-(define proxy-user-pass #f)
-(define retrieve-only #f)
-(define do-not-build #f)
-(define list-versions-only #f)
-(define canonical-eggs '())
-(define dependencies '())
-(define checked-eggs '())
-(define run-tests #f)
-(define force-install #f)
-(define host-extension cross-chicken)
-(define target-extension cross-chicken)
-
-(define platform
- (if (eq? 'mingw (build-platform))
- 'windows
- 'unix))
-
-(define current-status
- (list (get-environment-variable "CSC_OPTIONS")
- (get-environment-variable "LD_LIBRARY_PATH")
- (get-environment-variable "CHICKEN_INCLUDE_PATH")
- (get-environment-variable "CHICKEN_REPOSITORY")
- (get-environment-variable "DYLD_LIBRARY_PATH"))) ;XXX more?
-
-(define (probe-dir dir)
- (and dir (file-exists? dir) (directory? dir) dir))
-
-(define cache-directory
- (make-pathname (or (probe-dir (get-environment-variable "HOME"))
- (probe-dir (get-environment-variable "USERPROFILE"))
- (probe-dir "/tmp")
- (probe-dir "/Temp")
- ".")
- ".chicken-install.cache"))
-
-(define (repo-path)
- (destination-repository
- (if (and cross-chicken (not host-extension))
- 'target
- 'host)))
-
-(define (build-script-extension mode platform)
- (string-append "build"
- (if (eq? mode 'target) ".target" "")
- (if (eq? platform 'windows) ".bat" ".sh")))
-
-(define (install-script-extension mode platform)
- (string-append "install"
- (if (eq? mode 'target) ".target" "")
- (if (eq? platform 'windows) ".bat" ".sh")))
-
-
-;; usage information
-
-(define (usage code)
- (print "usage: chicken-install [OPTION | EXTENSION[:VERSION]] ...")
- ;;XXX
- (exit code))
-
-
-;; utilities
-
-;; Simpler replacement for SRFI-13's string-suffix?
-(define (string-suffix? suffix s)
- (let ((len-s (string-length s))
- (len-suffix (string-length suffix)))
- (and (not (< len-s len-suffix))
- (string=? suffix
- (substring s (- len-s len-suffix))))))
-
-(define (d fstr . args)
- (unless quiet
- (let ((port (current-error-port)))
- (apply fprintf port fstr args)
- (flush-output port) ) ))
-
-(define (version>=? v1 v2)
- (define (version->list v)
- (map (lambda (x) (or (string->number x) x))
- (irregex-split "[-\\._]" (->string v))))
- (let loop ((p1 (version->list v1))
- (p2 (version->list v2)))
- (cond ((null? p1) (null? p2))
- ((null? p2))
- ((number? (car p1))
- (and (number? (car p2))
- (or (> (car p1) (car p2))
- (and (= (car p1) (car p2))
- (loop (cdr p1) (cdr p2))))))
- ((number? (car p2)))
- ((string>? (car p1) (car p2)))
- (else
- (and (string=? (car p1) (car p2))
- (loop (cdr p1) (cdr p2)))))))
-
-
-;; load defaults file ("setup.defaults")
-
-(define (load-defaults)
- (let ((deff (or user-defaults
- (make-pathname host-sharedir +defaults-file+))))
- (define (broken x)
- (error "invalid entry in defaults file" deff x))
- (cond ((not (file-exists? deff)) '())
- (else
- (for-each
- (lambda (x)
- (unless (and (list? x) (positive? (length x)))
- (broken x))
- (case (car x)
- ((version)
- (cond ((not (pair? (cdr x))) (broken x))
- ((not (= (cadr x) +defaults-version+))
- (error
- (sprintf
- "version of installed `~a' does not match chicken-install version (~a)"
- +defaults-file+
- +defaults-version+)
- (cadr x)))
- ;; others are ignored
- ))
- ((server)
- (set! default-servers
- (append default-servers (cdr x))))
- ((map)
- (set! mappings
- (append
- mappings
- (map (lambda (m)
- (let ((p (list-index (cut eq? '-> <>) m)))
- (unless p (broken x))
- (let-values (((from to) (split-at m p)))
- (cons from (cdr to)))))
- (cdr x)))))
- ((alias)
- (set! aliases
- (append
- aliases
- (map (lambda (a)
- (if (and (list? a) (= 2 (length a)) (every string? a))
- (cons (car a) (cadr a))
- (broken x)))
- (cdr x)))))
- ((override)
- (set! override
- (if (and (pair? (cdr x)) (string? (cadr x)))
- (call-with-input-file (cadr x) read-all)
- (cdr x))))
- ((location)
- (set! default-locations
- (append default-locations (list (cdr x)))))
- ((hack)
- (set! hacks (append hacks (list (eval (cadr x))))))
- (else (broken x))))
- (call-with-input-file deff read-all))))))
-
-
-;; set variables with HTTP proxy information
-
-(define (setup-proxy uri)
- (and-let* (((string? uri))
- (m (irregex-match "(http://)?([^:]+):?([0-9]*)" uri))
- (port (irregex-match-substring m 3)))
- (set! proxy-user-pass (get-environment-variable "proxy_auth"))
- (set! proxy-host (irregex-match-substring m 2))
- (set! proxy-port (or (string->number port) 80))))
-
-
-;; apply egg->egg mappings loaded from defaults
-
-(define (apply-mappings eggs)
- (define (canonical x)
- (cond ((symbol? x) (cons (symbol->string x) #f))
- ((string? x) (cons x #f))
- ((pair? x) x)
- (else (error "internal error - bad egg spec" x))))
- (define (same? e1 e2)
- (equal? (car (canonical e1)) (car (canonical e2))))
- (let ((eggs2
- (delete-duplicates
- (append-map
- (lambda (egg)
- (cond ((find (lambda (m) (find (cut same? egg <>) (car m)))
- mappings) =>
- (lambda (m) (map ->string (cdr m))))
- (else (list egg))))
- eggs)
- same?)))
- (unless (and (= (length eggs) (length eggs2))
- (every (lambda (egg) (find (cut same? <> egg) eggs2)) eggs))
- (d "mapped ~s to ~s~%" eggs eggs2))
- eggs2))
-
-
-;; override versions, if specified in "overrides" file
-
-(define (override-version egg)
- (let ((name (string->symbol (if (pair? egg) (car egg) egg))))
- (cond ((assq name override) =>
- (lambda (a)
- (cond ((and (pair? egg) (not (equal? (cadr a) (cdr egg))))
- (warning
- (sprintf
- "version `~a' of extension `~a' overrides explicitly given version `~a'"
- (cadr a) name (cdr egg))))
- (else (d "overriding: ~a~%" a)))
- (cadr a)))
- ((pair? egg) (cdr egg))
- (else #f))))
-
-
-;; "locate" egg: either perform HTTP download or copy from a file-system
-;; location, also make sure it is up to date
-
-(define (locate-egg name version)
- (let* ((cached (make-pathname cache-directory name))
- (now (current-seconds))
- (timestamp (make-pathname cached +timestamp-file+))
- (status (make-pathname cached +status-file+))
- (eggfile (make-pathname cached name +egg-extension+)))
- (define (fetch)
- (when (file-exists? cached)
- (delete-directory cached #t))
- (create-directory cached)
- (fetch-egg-sources name version cached)
- (with-output-to-file status (cut write current-status)))
- (unless (file-exists? cache-directory)
- (create-directory cache-directory))
- (cond ((not (probe-dir cached)) (fetch))
- ((and (file-exists? status)
- (not (equal? current-status
- (with-input-from-file status read))))
- (fetch)))
- (let* ((info (load-egg-info eggfile))
- (lversion (get-egg-property info 'version)))
- (cond ((and (file-exists? timestamp)
- (> (- now (with-input-from-file timestamp read)) +one-hour+)
- (not (check-remote-version name version lversion)))
- (fetch)
- (let ((info (load-egg-info eggfile))) ; new egg info (fetched)
- (values cached (get-egg-property info 'version))))
- (else (values cached version))))))
-
-(define (resolve-location name)
- (cond ((assoc name aliases) =>
- (lambda (a)
- (let ((new (cdr a)))
- (d "resolving alias `~a' to: ~a~%" name new)
- (resolve-location new))))
- (else name)))
-
-(define (fetch-egg-sources name version dest)
- (let loop ((locs default-locations))
- (cond ((null? locs)
- (let ((tmpdir (create-temporary-directory)))
- (let loop ((srvs default-servers))
- (receive (dir ver)
- (try-download name (resolve-location (car srvs))
- version: version
- destination: tmpdir
- tests: run-tests
- proxy-host: proxy-host
- proxy-port: proxy-port
- proxy-user-pass: proxy-user-pass)
- (cond (dir
- (rename-file tmpdir dest)
- (with-output-to-file
- (make-pathname dest +timestamp-file+)
- (lambda () (write (current-seconds)))))
- ((null? srvs) (error "extension or version not found"))
- (else (loop (cdr srvs))))))))
- ((probe-dir (make-pathname (car locs) name))
- => (lambda (dir)
- (let* ((eggfile (make-pathname dir name +egg-extension+))
- (info (load-egg-info eggfile))
- (rversion (get-egg-property info 'version)))
- (if (or (not rversion)
- (version>=? rversion version))
- (copy-egg-sources dir dest)
- (loop (cdr locs))))))
- (else (loop (cdr locs))))))
-
-(define (copy-egg-sources from to)
- ;;XXX should probably be done manually, instead of calling tool
- (let ((cmd (quote-all
- (string-append
- (copy-directory-command platform)
- " " (quotearg from) " " (quotearg to))
- platform)))
- (system cmd)))
-
-(define (check-remote-version name version lversion)
- (let loop ((locs default-locations))
- (cond ((null? locs)
- (let loop ((srvs default-servers))
- (and (pair? srvs)
- (let ((versions (try-list-versions name (car srvs))))
- (or (and versions
- (any (cut version>=? <> version) versions))
- (loop (cdr srvs)))))))
- ((probe-dir (make-pathname (car locs) name))
- => (lambda (dir)
- (let* ((eggfile (make-pathname dir name +egg-extension+))
- (info (load-egg-info eggfile))
- (rversion (get-egg-property info 'version)))
- (or (and rversion
- (version>=? rversion version))
- (loop (cdr locs))))))
- (else (loop (cdr locs))))))
-
-
-;; retrieve eggs, recursively (if needed)
-
-(define (retrieve-eggs eggs)
- (for-each
- (lambda (egg)
- (cond ((assoc egg canonical-eggs) =>
- (lambda (a)
- ;; push to front
- (set! canonical-eggs (cons a (delete a canonical-eggs eq?)))))
- (else
- (let ((name (if (pair? egg) (car egg) egg))
- (version (override-version egg)))
- (let-values (((dir ver) (locate-egg name version)))
- (when (or (not dir)
- (null? (directory dir)))
- (error "extension or version not found"))
- (d " ~a located at ~a~%")
- (set! canonical-eggs
- (cons (list name dir ver) canonical-eggs)))))))
- eggs)
- (unless retrieve-only
- (for-each
- (lambda (e+d+v)
- (unless (member (car e+d+v) checked-eggs)
- (d "checking ~a ...~%" (car e+d+v))
- (set! checked-eggs (cons (car e+d+v) checked-eggs))
- (let* ((fname (make-pathname (cadr e+d+v) (car e+d+v) +egg-extension+))
- (info (load-egg-info fname)))
- (d "checking platform for `~a'~%" (car e+d+v))
- (check-platform (car e+d+v) info)
- (d "checking dependencies for `~a'~%" (car e+d+v))
- (let-values (((missing upgrade)
- (outdated-dependencies (car e+d+v) info)))
- (set! missing (apply-mappings missing))
- (set! dependencies
- (cons (cons (car e+d+v)
- (map (lambda (mu)
- (if (pair? mu)
- (car mu)
- mu))
- (append missing upgrade)))
- dependencies))
- (when (pair? missing)
- (print " missing: " (string-intersperse missing ", "))
- (retrieve-eggs missing))
- (when (and (pair? upgrade)
- (or force-install
- (replace-extension-question e+d+v upgrade)))
- (let ((ueggs (unzip1 upgrade)))
- (d " upgrade: ~a~%" (string-intersperse ueggs ", "))
- ;; XXX think about this...
- #;(for-each
- (lambda (e)
- (d "removing previously installed extension `~a'" e)
- (remove-extension e) ) ; - not implemented yet
- ueggs)
- (retrieve-eggs ueggs) ) ) ) ) ) )
- canonical-eggs)))
-
-(define (outdated-dependencies egg info)
- (let ((ds (get-egg-dependencies info)))
- (for-each
- (lambda (h) (set! ds (h egg ds)))
- hacks)
- (let loop ((deps ds) (missing '()) (upgrade '()))
- (if (null? deps)
- (values (reverse missing) (reverse upgrade))
- (let ((dep (car deps))
- (rest (cdr deps)))
- (let-values (((m u) (check-dependency dep)))
- (loop rest
- (if m (cons m missing) missing)
- (if u (cons u upgrade) upgrade))))))))
-
-(define (get-egg-dependencies info)
- (append (get-egg-property info 'dependencies '())
- (if run-tests (get-egg-property info 'test-dependencies '()) '())))
-
-(define (check-dependency dep)
- (cond ((or (symbol? dep) (string? dep))
- (values (and (not (ext-version dep)) (->string dep))
- #f))
- ((and (list? dep) (eq? 'or (car dep)))
- (let scan ((ordeps (cdr dep)) (bestm #f) (bestu #f))
- (if (null? ordeps)
- (values (cond (bestu #f) ; upgrade overrides new
- (bestm bestm)
- (else #f))
- bestu)
- (let-values (((m u) (check-dependency (car ordeps))))
- (if (and (not m) (not u))
- (values #f #f)
- (scan (cdr ordeps)
- (if (and m (not bestm))
- m
- bestm)
- (if (and u (not bestu))
- u
- bestu)))))))
- ((and (list? dep) (= 2 (length dep))
- (or (string? (car dep)) (symbol? (car dep))))
- (let ((v (ext-version (car dep))))
- (cond ((not v)
- (values (->string (car dep)) #f))
- ((not (version>=? v (->string (cadr dep))))
- (cond ((string=? "chicken" (->string (car dep)))
- (if force-install
- (values #f #f)
- (error
- (string-append
- "Your CHICKEN version is not recent enough to use this extension - version "
- (cadr dep)
- " or newer is required"))))
- (else
- (values #f
- (cons (->string (car dep)) (->string (cadr dep)))))))
- (else (values #f #f)))))
- (else
- (warning "invalid dependency syntax in extension meta information"
- dep)
- (values #f #f))))
-
-(define (ext-version x)
- (cond ((or (eq? x 'chicken) (equal? x "chicken"))
- (chicken-version))
- ((let* ((ep (##sys#canonicalize-extension-path x 'ext-version))
- (sf (make-pathname (repo-path) ep +egg-info-extension+)))
- (and (file-exists? sf)
- (load-egg-info sf #f))) =>
- (lambda (info)
- (let ((a (assq 'version info)))
- (if a
- (->string (cadr a))
- "0.0.0"))))
- (else #f)))
-
-(define (check-platform name info)
- (define (fail)
- (error "extension is not targeted for this system" name))
- (unless cross-chicken
- (and-let* ((platform (get-egg-property info 'platform)))
- (let loop ((p platform))
- (cond ((symbol? p)
- (or (feature? p) (fail)))
- ((not (list? p))
- (error "invalid `platform' property" name platform))
- ((and (eq? 'not (car p)) (pair? (cdr p)))
- (and (not (loop (cadr p))) (fail)))
- ((eq? 'and (car p))
- (and (every loop (cdr p)) (fail)))
- ((eq? 'or (car p))
- (and (not (any loop (cdr p))) (fail)))
- (else (error "invalid `platform' property" name platform)))))))
-
-(define (replace-extension-question e+d+v upgrade)
- (print (string-intersperse
- (append
- (list "The following installed extensions are outdated, because `"
- (car e+d+v)
- "' requires later versions:\n")
- (filter-map
- (lambda (e)
- (cond ((assq (string->symbol (car e)) override) =>
- (lambda (a)
- (unless (equal? (cadr a) (cdr e))
- (warning
- (sprintf "version `~a' of extension `~a' overrides required version `~a'"
- (cadr a) (car a) (cdr e))))
- #f))
- (else
- (conc
- " " (car e)
- " (" (let ((v (assq 'version (extension-information (car e)))))
- (if v (cadr v) "???"))
- " -> " (cdr e) ")"
- #\newline) )))
- upgrade)
- '("\nDo you want to replace the existing extensions ? (yes/no/abort) "))
- ""))
- (flush-output)
- (let loop ()
- (let ((r (trim (read-line))))
- (cond ((string=? r "yes"))
- ((string=? r "no") #f)
- ((string=? r "abort") (exit 1))
- (else (loop))))))
-
-(define (trim str)
- (define (left lst)
- (cond ((null? lst) '())
- ((char-whitespace? (car lst)) (left (cdr lst)))
- (else (cons (car lst) (left (cdr lst))))))
- (list->string (reverse (left (reverse (left (string->list str)))))))
-
-
-;; list available egg versions
-
-(define (list-egg-versions eggs)
- (let ((srvs (map resolve-location default-servers)))
- (let loop1 ((eggs eggs))
- (unless (null? eggs)
- (let* ((egg (car eggs))
- (name (if (pair? egg) (car egg) egg)))
- (let loop2 ((srvs srvs))
- (and (pair? srvs)
- (let ((versions (try-list-versions name (car srvs))))
- (or (and versions
- (begin
- (printf "~a:" name)
- (for-each (cut printf " ~a" <>) versions)))
- (loop2 (cdr srvs))))))
- (loop1 (cdr eggs)))))))
-
-
-;; perform installation of retrieved eggs
-
-(define (install-eggs)
- (for-each
- (lambda (egg)
- (let* ((name (car egg))
- (dir (cadr egg))
- (eggfile (make-pathname dir name +egg-extension+))
- (info (load-egg-info eggfile #f)))
- (when (or host-extension
- (and (not target-extension)
- (not host-extension)))
- (let-values (((build install info) (compile-egg-info info platform 'host)))
- (let ((bscript (make-pathname dir name
- (build-script-extension 'host platform)))
- (iscript (make-pathname dir name
- (install-script-extension 'host
- platform))))
- (generate-shell-commands platform build bscript dir
- (build-prefix 'host name info)
- (build-suffix 'host name info))
- (generate-shell-commands platform install iscript dir
- (install-prefix 'host name info)
- (install-suffix 'host name info))
- (run-script dir bscript platform)
- (run-script dir iscript platform))))
- (when target-extension
- (let-values (((build install info) (compile-egg-info info platform 'target)))
- (let ((bscript (make-pathname dir name
- (build-script-extension 'target platform)))
- (iscript (make-pathname dir name
- (install-script-extension 'target
- platform))))
- (generate-shell-commands platform build bscript dir
- (build-prefix 'target name info)
- (build-suffix 'target name info))
- (generate-shell-commands platform install iscript dir
- (install-prefix 'target name info)
- (install-suffix 'target name info))
- (run-script dir bscript platform)
- (run-script dir iscript platform))))))
- canonical-eggs))
-
-(define (run-script dir script platform)
- (if do-not-build
- (print script)
- (let ((old (current-directory)))
- (change-directory dir)
- (d "running script ~a~%" script)
- (if (eq? platform 'windows)
- (exec script)
- (exec (string-append "sh " script)))
- (change-directory old))))
-
-(define (write-info name info mode)
- (d "writing info for egg ~a~%" name info)
- (let ((infofile (make-pathname name (destination-repository mode))))
- (when (eq? platform 'unix)
- (exec (string-append "chmod a+r " (quotearg infofile))))))
-
-(define (exec cmd)
- (d "executing: ~s~%" cmd)
- (let ((r (system cmd)))
- (unless (zero? r)
- (error "shell command terminated with nonzero exit code" r cmd))))
-
-
-;; command line parsing and selection of operations
-
-(define (perform-actions eggs)
- (load-defaults)
- (cond ((null? eggs)
- (set! canonical-eggs
- (map (lambda (fname)
- (list (pathname-file fname) (current-directory) #f))
- (glob "*.egg")))
- (retrieve-eggs '())
- (install-eggs))
- (else
- (let ((eggs (apply-mappings eggs)))
- (cond (list-versions-only (list-egg-versions eggs))
- ;;XXX other actions...
- (else
- (retrieve-eggs eggs)
- (install-eggs)))))))
-
-(define (main args)
- (setup-proxy (get-environment-variable "http_proxy"))
- (let ((eggs '())
- (rx (irregex "([^:]+):(.+)")))
- (let loop ((args args))
- (if (null? args)
- (perform-actions (reverse eggs))
- (let ((arg (car args)))
- (cond ((member arg '("-h" "-help" "--help"))
- (usage 0))
- ((equal? arg "-test")
- (set! run-tests #t)
- (loop (cdr args)))
- ((member arg '("-r" "-retrieve"))
- (set! retrieve-only #t)
- (loop (cdr args)))
- ((equal? arg "-list-versions")
- (set! list-versions-only #t)
- (loop (cdr args)))
- ((equal? arg "-defaults")
- (set! user-defaults (cadr args))
- (loop (cddr args)))
- ((equal? arg "-force")
- (set! force-install #t)
- (loop (cdr args)))
- ((equal? arg "-host")
- (set! target-extension #f)
- (loop (cdr args)))
- ((equal? arg "-target")
- (set! host-extension #f)
- (loop (cdr args)))
- ((equal? arg "-n")
- (set! do-not-build #t)
- (loop (cdr args)))
- ((equal? arg "-v")
- (set! quiet #f)
- (loop (cdr args)))
-
- ;;XXX
-
- ((and (positive? (string-length arg))
- (char=? #\- (string-ref arg 0)))
- (if (> (string-length arg) 2)
- (let ((sos (string->list (substring arg 1))))
- (if (every (cut memq <> +short-options+) sos)
- (loop (append
- (map (cut string #\- <>) sos)
- (cdr args)))
- (usage 1)))
- (usage 1)))
- ((irregex-match rx arg) =>
- (lambda (m)
- (set! eggs
- (alist-cons
- (irregex-match-substring m 1)
- (irregex-match-substring m 2)
- eggs))
- (loop (cdr args))))
- (else
- (set! eggs (cons arg eggs))
- (loop (cdr args)))))))))
-
-(main (command-line-arguments))
-
-)
diff --git a/setup-api.scm b/setup-api.scm
deleted file mode 100644
index 8dc73f8a..00000000
--- a/setup-api.scm
+++ /dev/null
@@ -1,751 +0,0 @@
-;;;; setup-api.scm - build + installation API for eggs
-;
-; Copyright (c) 2008-2016, The CHICKEN Team
-; All rights reserved.
-;
-; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
-; conditions are met:
-;
-; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
-; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
-; disclaimer in the documentation and/or other materials provided with the distribution.
-; Neither the name of the author nor the names of its contributors may be used to endorse or promote
-; products derived from this software without specific prior written permission.
-;
-; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
-; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
-; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
-; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-; POSSIBILITY OF SUCH DAMAGE.
-
-; This code is partially quite messy and the API is not overly consistent,
-; mainly because it has grown "organically" while the old chicken-setup program
-; evolved. The code was extracted and put into this module, without much
-; cleaning up.
-;
-; *windows-shell* and, to a lesser extent, 'sudo' processing knowledge is
-; scattered in the code.
-
-(module setup-api
-
- ((run execute)
- compile
- standard-extension
- host-extension
- install-extension install-program install-script
- setup-verbose-mode setup-install-mode deployment-mode
- installation-prefix
- destination-prefix
- runtime-prefix
- chicken-prefix
- find-library find-header
- program-path remove-file*
- patch abort-setup
- setup-root-directory create-directory/parents
- test-compile try-compile run-verbose
- extra-features extra-nonfeatures
- copy-file move-file
- sudo-install keep-intermediates
- version>=?
- extension-name-and-version
- extension-name
- extension-version
- remove-directory
- remove-extension
- read-info
- register-program find-program
- shellpath
- setup-error-handling
- yes-or-no?)
-
- (import scheme chicken
- chicken.data-structures
- chicken.files
- chicken.foreign
- chicken.format
- chicken.io
- chicken.irregex
- chicken.pathname
- chicken.posix
- chicken.pretty-print
- chicken.utils)
-
-(include "mini-srfi-1.scm")
-
-;;; Constants, variables and parameters
-
-(define-constant setup-file-extension "setup-info")
-
-(define *cc* (foreign-value "C_TARGET_CC" c-string))
-(define *cxx* (foreign-value "C_TARGET_CXX" c-string))
-(define *target-cflags* (foreign-value "C_TARGET_CFLAGS" c-string))
-(define *target-libs* (foreign-value "C_TARGET_MORE_LIBS" c-string))
-(define *target-lib-home* (foreign-value "C_TARGET_LIB_HOME" c-string))
-(define *sudo* #f)
-(define *windows-shell* (foreign-value "C_WINDOWS_SHELL" bool))
-(define *binary-version* (foreign-value "C_BINARY_VERSION" int))
-(define *registered-programs* '())
-
-(define *windows*
- (and (eq? (software-type) 'windows)
- (build-platform) ) )
-
-(register-feature! 'chicken-setup)
-
-(define host-extension (make-parameter #f))
-
-(define *chicken-bin-path*
- (or (and-let* ((p (get-environment-variable "CHICKEN_PREFIX")))
- (make-pathname p "bin") )
- (foreign-value "C_INSTALL_BIN_HOME" c-string) ) )
-
-(define chicken-prefix
- (or (get-environment-variable "CHICKEN_PREFIX")
- (foreign-value "C_INSTALL_PREFIX" c-string)))
-
-(define (shellpath str)
- (qs (normalize-pathname str)))
-
-(define *csc-options* '())
-(define *base-directory* (current-directory))
-
-(define setup-root-directory (make-parameter *base-directory*))
-(define setup-verbose-mode (make-parameter #f))
-(define setup-install-mode (make-parameter #t))
-(define deployment-mode (make-parameter #f))
-(define program-path (make-parameter *chicken-bin-path*))
-(define keep-intermediates (make-parameter #f))
-
-(define extra-features
- (let ((xfs '()))
- (lambda (#!optional fs)
- (cond (fs (apply register-feature! fs)
- (set! xfs fs))
- (else xfs)))))
-
-(define extra-nonfeatures
- (let ((xfs '()))
- (lambda (#!optional fs)
- (cond (fs (apply unregister-feature! fs)
- (set! xfs fs))
- (else xfs)))))
-
-; Setup shell commands
-
-(define *copy-command*)
-(define *remove-command*)
-(define *move-command*)
-(define *chmod-command*)
-(define *ranlib-command*)
-(define *mkdir-command*)
-
-(define (windows-user-install-setup)
- (set! *copy-command* "copy")
- (set! *remove-command* "del /Q /S")
- (set! *move-command* "move")
- (set! *chmod-command* "chmod")
- (set! *ranlib-command* "ranlib") )
-
-(define (unix-user-install-setup)
- (set! *copy-command* "cp -r")
- (set! *remove-command* "rm -fr")
- (set! *move-command* "mv")
- (set! *chmod-command* "chmod")
- (set! *ranlib-command* "ranlib")
- (set! *mkdir-command* "mkdir") )
-
-(define (windows-sudo-install-setup)
- (set! *sudo* #f)
- (print "Warning: cannot install as superuser with Windows") )
-
-(define (unix-sudo-install-setup)
- (let ((sudo-cmd (qs (or (get-environment-variable "SUDO") "sudo"))))
- (set! *copy-command* (sprintf "~a cp -r" sudo-cmd))
- (set! *remove-command* (sprintf "~a rm -rf" sudo-cmd))
- (set! *move-command* (sprintf "~a mv" sudo-cmd))
- (set! *chmod-command* (sprintf "~a chmod" sudo-cmd))
- (set! *ranlib-command* (sprintf "~a ranlib" sudo-cmd))
- (set! *mkdir-command* (sprintf "~a mkdir" sudo-cmd))))
-
-(define (user-install-setup)
- (set! *sudo* #f)
- (if *windows-shell*
- (windows-user-install-setup)
- (unix-user-install-setup) ) )
-
-(define (sudo-install-setup)
- (set! *sudo* #t)
- (if *windows-shell*
- (windows-sudo-install-setup)
- (unix-sudo-install-setup) ) )
-
-(define (sudo-install . args)
- (cond ((null? args) *sudo*)
- ((car args) (sudo-install-setup))
- (else (user-install-setup)) ) )
-
-(define abort-setup (make-parameter (cut exit 1)))
-
-(define-syntax ignore-errors
- (syntax-rules ()
- ((_ body ...)
- (handle-exceptions ex #f body ...))))
-
-(define (patch which rx subst)
- (when (setup-verbose-mode) (printf "patching ~A ...~%" which))
- (if (list? which)
- (with-output-to-file (cadr which)
- (lambda ()
- (with-input-from-file (car which)
- (lambda ()
- (let loop ()
- (let ((ln (read-line)))
- (unless (eof-object? ln)
- (write-line (irregex-replace/all rx ln subst))
- (loop) ) ) ) ) ) ) )
- (let ((tmp (create-temporary-file)))
- (patch (list tmp tmp) rx subst)
- ($system
- (sprintf "~A ~A ~A" *move-command* (shellpath tmp)
- (shellpath which))))))
-
-(define run-verbose (make-parameter #t))
-
-(define (register-program name #!optional
- (path (make-pathname *chicken-bin-path* (->string name))))
- (set! *registered-programs*
- (alist-cons (->string name) path *registered-programs*)))
-
-(define (find-program name)
- (let* ((name (->string name))
- (a (assoc name *registered-programs*)))
- (if a
- (shellpath (cdr a))
- name)))
-
-(let ()
- (define (reg name rname)
- (register-program name (make-pathname *chicken-bin-path* rname)))
- (reg "chicken" (foreign-value "C_CHICKEN_PROGRAM" c-string))
- (reg "csi" (foreign-value "C_CSI_PROGRAM" c-string))
- (reg "csc" (foreign-value "C_CSC_PROGRAM" c-string))
- (reg "chicken-install" (foreign-value "C_CHICKEN_INSTALL_PROGRAM" c-string))
- (reg "chicken-uninstall" (foreign-value "C_CHICKEN_UNINSTALL_PROGRAM" c-string))
- (reg "chicken-status" (foreign-value "C_CHICKEN_STATUS_PROGRAM" c-string))
- (reg "chicken-bug" (foreign-value "C_CHICKEN_BUG_PROGRAM" c-string)))
-
-(define (target-prefix fname)
- (and-let* ((tp (runtime-prefix)))
- (make-pathname tp fname)))
-
-;; Simpler replacement for SRFI-13's string-prefix?
-(define (string-prefix? prefix s)
- (let ((pos (substring-index prefix s)))
- (and pos (zero? pos))))
-
-(define (fixpath prg)
- (cond ((string=? prg "csc")
- (string-intersperse
- (cons*
- (find-program "csc")
- "-feature" "compiling-extension"
- (if (or (deployment-mode)
- (and (feature? #:cross-chicken)
- (not (host-extension))))
- "" "-setup-mode")
- (if (keep-intermediates) "-k" "")
- (if (host-extension) "-host" "")
- (if (deployment-mode) "-deployed" "")
- (append
- (map (lambda (f)
- (string-append "-feature " (symbol->string f)))
- (extra-features))
- (map (lambda (f)
- (string-append "-no-feature " (symbol->string f)))
- (extra-nonfeatures))
- *csc-options*) )
- " ") )
- ((and (string-prefix? "./" prg) *windows-shell*)
- (shellpath (substring prg 2)))
- (else (find-program prg))))
-
-(define (execute explist)
- (define (smooth lst)
- (let ((slst (map ->string lst)))
- (string-intersperse (cons (fixpath (car slst)) (cdr slst)) " ") ) )
- (for-each
- (lambda (cmd)
- (when (run-verbose) (printf " ~A~%~!" cmd))
- ($system cmd))
- (map smooth explist) ) )
-
-(define-syntax run
- (syntax-rules ()
- ((_ exp ...)
- (execute (list `exp ...)))))
-
-(define-syntax compile
- (syntax-rules ()
- ((_ exp ...)
- (run (csc exp ...)))))
-
-
-;;; Processing setup scripts
-
-(define (make-setup-info-pathname fn #!optional (rpath (repository-path)))
- (make-pathname rpath fn setup-file-extension) )
-
-(define destination-prefix (make-parameter #f))
-(define runtime-prefix (make-parameter #f))
-
-(define installation-prefix
- (let ((prefix (get-environment-variable "CHICKEN_INSTALL_PREFIX")))
- (lambda ()
- (or (destination-prefix)
- prefix
- chicken-prefix))))
-
-(define create-directory/parents
- (let ()
- (define (verb dir)
- (when (setup-verbose-mode)
- (printf " mkdir ~a~%~!" dir)) )
- (if *windows*
- (lambda (dir)
- (verb dir)
- (create-directory dir #t) )
- (lambda (dir)
- (verb dir)
- (run (,*mkdir-command* -p ,(shellpath dir)) ) ) ) ) )
-
-(define (write-info id files info)
- (let ((info `((files ,@files)
- ,@info)) )
- (when (setup-verbose-mode) (printf "writing info ~A -> ~S ...~%" id info))
- (let* ((sid (->string id))
- (setup-file (make-setup-info-pathname sid (repo-path #t))))
- (ensure-directory setup-file)
- (cond (*sudo*
- (let ((tmp (create-temporary-file)))
- (with-output-to-file tmp (cut pp info))
- (run (,*move-command* ,(shellpath tmp) ,(shellpath setup-file)))))
- (else (with-output-to-file setup-file (cut pp info))))
- (unless *windows-shell* (run (,*chmod-command* a+r ,(shellpath setup-file)))))))
-
-(define (copy-file from to #!optional (err #t) (prefix (installation-prefix)))
- ;;XXX the prefix handling is completely bogus
- (let ((from (if (pair? from) (car from) from))
- (to (let ((to-path (if (pair? from) (make-pathname to (cadr from)) to)))
- (if (not (path-prefix? prefix to-path))
- (if (absolute-pathname? to-path)
- to-path
- (make-pathname prefix to-path) )
- to-path))))
- (let walk ((from from) (to to))
- (cond ((directory? from)
- (for-each
- (lambda (f)
- (walk (make-pathname from f) (make-pathname to f)))
- (directory from)))
- (else
- (ensure-directory to)
- (run (,*copy-command*
- ,(shellpath from)
- ,(shellpath to))))))
- to))
-
-(define (path-prefix? pref path)
- (string-prefix?
- (normalize-pathname pref)
- (normalize-pathname path)))
-
-(define (move-file from to)
- (let ((from (if (pair? from) (car from) from))
- (to (if (pair? from) (make-pathname to (cadr from)) to)))
- (ensure-directory to)
- (run (,*move-command* ,(shellpath from) ,(shellpath to)) ) ) )
-
-(define (remove-file* dir)
- (run (,*remove-command* ,(shellpath dir)) ) )
-
-(define (make-dest-pathname path file)
- (if (list? file)
- (make-dest-pathname path (cadr file))
- (if (absolute-pathname? file)
- file
- (make-pathname path file) ) ) )
-
-(define (check-filelist flist)
- (map (lambda (f)
- (cond ((string? f) f)
- ((and (list? f) (every string? f)) f)
- ((and (pair? f) (list (car f) (cdr f))))
- (else (error "invalid file-specification" f)) ) )
- flist) )
-
-(define (translate-extension f #!optional default)
- (pathname-replace-extension f
- (let ((ext (pathname-extension f)))
- (cond ((not ext) default)
- ((equal? "so" ext) ##sys#load-dynamic-extension)
- ((equal? "a" ext) (if *windows-shell* "lib" "a"))
- (else ext)))))
-
-(define (what-version version)
- (or version
- (let ((n+v (extension-name-and-version)))
- (if (and n+v (pair? n+v) (not (equal? "" (cadr n+v))))
- (cadr n+v)
- "unknown"))))
-
-(define (supply-version info version)
- (cond ((assq 'version info) =>
- (lambda (a)
- (cons
- `(egg-name ,(extension-name))
- info)))
- (else
- (let ((v (what-version version)))
- (cons*
- `(version ,v)
- `(egg-name ,(extension-name))
- info)))))
-
-
-;;; Convenience function
-
-(define (standard-extension name #!optional version #!key static (info '()))
- ;; `static' is ignored
- (let* ((sname (->string name))
- (fname (make-pathname #f sname "scm"))
- (iname (make-pathname #f sname "import.scm"))
- (ilname (make-pathname #f sname "inline")))
- (compile -dynamic -optimize-level 3 -debug-level 1 ,fname -emit-import-library ,name)
- (compile -dynamic -optimize-level 3 -debug-level 0 ,iname)
- (install-extension
- name
- `(,(pathname-replace-extension fname "so")
- ,(pathname-replace-extension iname "so")
- ,@(if (file-exists? ilname)
- (list ilname)
- '()))
- `(,@(supply-version info version)))))
-
-
-;;; Installation
-
-(define (install-extension id files #!optional (info '()))
- (when (setup-install-mode)
- (let* ((files (check-filelist (if (list? files) files (list files))))
- (rpath (repo-path))
- (rpathd (repo-path #t))
- (dests (map (lambda (f)
- (let ((from (if (pair? f) (car f) f))
- (to (make-dest-pathname rpathd f)) )
- (copy-file from to)
- (unless *windows-shell*
- (run (,*chmod-command* a+r ,(shellpath to))))
- (and-let* ((static (assq 'static info)))
- (when (and (eq? (software-version) 'macosx)
- (equal? (cadr static) from)
- (equal? (pathname-extension to) "a"))
- (run (,*ranlib-command* ,(shellpath to)) ) ))
- (cond ((deployment-mode) f)
- ((not (equal? (destination-prefix) (runtime-prefix)))
- ;; we did not append a prefix already
- (target-prefix to))
- ;; There's been destination-prefix added before
- (else to))))
- files) ) )
- (write-info id dests (supply-version info #f)) ) ) )
-
-(define (install-program id files #!optional (info '()))
- (define (exify f)
- (translate-extension
- f
- (if *windows-shell* "exe" #f) ) )
- (when (setup-install-mode)
- (let* ((files (check-filelist (if (list? files) files (list files))))
- (pre (installation-prefix))
- (ppath (ensure-directory (make-pathname pre "bin") #t))
- (files (if *windows*
- (map (lambda (f)
- (if (list? f)
- (list (exify (car f)) (exify (cadr f)))
- (exify f) ) )
- files)
- files) )
- (dests (map (lambda (f)
- (let ((from (if (pair? f) (car f) f))
- (to (make-dest-pathname ppath f)) )
- (copy-file from to)
- (unless *windows-shell*
- (run (,*chmod-command* a+r ,(shellpath to))))
- to) )
- files) ) )
- (write-info id dests (supply-version info #f)) ) ) )
-
-(define (install-script id files #!optional (info '()))
- (when (setup-install-mode)
- (let* ((files (check-filelist (if (list? files) files (list files))))
- (pre (installation-prefix))
- (ppath (ensure-directory (make-pathname pre "bin") #t))
- (pfiles (map (lambda (f)
- (let ((from (if (pair? f) (car f) f))
- (to (make-dest-pathname ppath f)) )
- (copy-file from to)
- (unless *windows-shell*
- (run (,*chmod-command* a+r ,(shellpath to))))
- to) )
- files) ) )
- (unless *windows-shell*
- (run (,*chmod-command* a+rx ,(string-intersperse pfiles " "))) )
- (write-info id pfiles (supply-version info #f)) ) ) )
-
-
-;;; More helper stuff
-
-(define (repo-path #!optional ddir?)
- (let ((p (if ddir?
- (if (deployment-mode)
- (installation-prefix) ; deploy: copy directly into destdir
- (let ((p (destination-prefix)))
- (if p ; installation-prefix changed: use it
- (make-pathname
- p
- (sprintf "lib/chicken/~a" *binary-version*))
- (repository-path)))) ; otherwise use repo-path
- (repository-path))) )
- (ensure-directory p #t)
- p) )
-
-(define (ensure-directory path #!optional full)
- (and-let* ((dir (if full path (pathname-directory path))))
- (if (file-exists? dir)
- (unless (directory? dir)
- (error "cannot create directory: a file with the same name already exists") )
- (begin
- (create-directory/parents dir)
- (unless *windows-shell*
- (run (,*chmod-command* a+x ,(shellpath dir)))))))
- path)
-
-(define (try-compile code #!key c++ (cc (if c++ *cxx* *cc*)) (cflags "") (ldflags "")
- (verb (setup-verbose-mode)) (compile-only #f))
- (let* ((fname (create-temporary-file "c"))
- (oname (pathname-replace-extension fname "o"))
- (r (begin
- (with-output-to-file fname (cut display code))
- (system
- (let ((cmd (conc
- cc " "
- (if compile-only "-c" "") " "
- cflags " " *target-cflags* " "
- (shellpath fname) " -o " (shellpath oname) " "
- (if compile-only
- ""
- (conc "-L" *target-lib-home* " " ldflags " " *target-libs*) )
- (if *windows* " >nul: " " >/dev/null ")
- (if verb "" "2>&1") ) ) )
- (when verb (print cmd " ..."))
- cmd) ) ) ) )
- (when verb (print (if (zero? r) "succeeded." "failed.")))
- (ignore-errors ($system (sprintf "~A ~A" *remove-command* (shellpath fname))))
- (ignore-errors ($system (sprintf "~A ~A" *remove-command* (shellpath oname))))
- (zero? r) ) )
-
-(define test-compile try-compile)
-
-(define (find-library name proc)
- (test-compile
- (sprintf "#ifdef __cplusplus~%extern \"C\"~%#endif~%char ~a();~%int main() { ~a(); return 0; }~%" proc proc)
- ldflags: (conc "-l" name) ) )
-
-(define (find-header name)
- (test-compile
- (sprintf "#include <~a>\nint main() { return 0; }\n" name)
- compile-only: #t) )
-
-(define (version>=? v1 v2)
- (define (version->list v)
- (map (lambda (x) (or (string->number x) x))
- (irregex-split "[-\\._]" (->string v))))
- (let loop ((p1 (version->list v1))
- (p2 (version->list v2)))
- (cond ((null? p1) (null? p2))
- ((null? p2))
- ((number? (car p1))
- (and (number? (car p2))
- (or (> (car p1) (car p2))
- (and (= (car p1) (car p2))
- (loop (cdr p1) (cdr p2))))))
- ((number? (car p2)))
- ((string>? (car p1) (car p2)))
- (else
- (and (string=? (car p1) (car p2))
- (loop (cdr p1) (cdr p2)))))))
-
-(define extension-name-and-version
- (make-parameter '("" "")
- (lambda (x)
- (cond [(or (not x) (null? x))
- '("" "") ]
- [(and (list? x) (= 2 (length x)))
- (let ([nam (car x)]
- [ver (cadr x)]
- [ensure-string (lambda (x) (if (or (not x) (null? x)) "" (->string x)))])
- (list (ensure-string nam) (ensure-string ver)) ) ]
- [else
- (error "invalid extension-name-and-version" x)]))))
-
-(define (extension-name)
- (car (extension-name-and-version)) )
-
-(define (extension-version #!optional defver)
- (let ([ver (cadr (extension-name-and-version))])
- (if (equal? ver "")
- (and defver (->string defver))
- ver ) ) )
-
-(define (read-info egg #!optional (repo (repository-path)))
- (with-input-from-file
- (make-pathname repo egg setup-file-extension)
- read))
-
-(define (remove-directory dir #!optional (strict #t))
- (cond ((not (file-exists? dir))
- (if strict
- (error 'remove-directory "cannot remove - directory not found" dir)
- #f))
- (*sudo*
- (ignore-errors
- (let ((sudo-cmd (or (get-environment-variable "SUDO") "sudo")))
- ($system (sprintf "~a rm -fr ~a" (qs sudo-cmd) (shellpath dir))))))
- (else
- (let walk ((dir dir))
- (let ((files (directory dir #t)))
- (for-each
- (lambda (f)
- (unless (or (string=? "." f) (string=? ".." f))
- (let ((p (make-pathname dir f)))
- (if (directory? p)
- (walk p)
- (delete-file p)))))
- files)
- (delete-directory dir)))) ))
-
-(define (remove-extension egg #!optional (repo (repository-path)))
- (and-let* ((files (assq 'files (read-info egg repo))))
- (for-each
- (lambda (f)
- (let ((p (if (absolute-pathname? f) f (make-pathname repo f))))
- (remove-file* p)))
- (cdr files)))
- (remove-file* (make-pathname repo egg setup-file-extension)))
-
-(define ($system str)
- (let ((str (cond (*windows-shell*
- (string-append "\"" str "\""))
- ((and (eq? (software-version) 'macosx)
- (get-environment-variable "DYLD_LIBRARY_PATH"))
- => (lambda (path)
- (string-append "/usr/bin/env DYLD_LIBRARY_PATH="
- (qs path) " " str)))
- (else str))))
- (let ((r (system str)))
- (unless (zero? r)
- (error
- (sprintf "shell command failed with nonzero exit status ~a:~%~% ~a" r str))))))
-
-(define (setup-error-handling)
- (current-exception-handler
- (lambda (c)
- (print-error-message c (current-error-port))
- (reset))))
-
-;;; Confirmation dialog
-
-#>
-#if defined(_WIN32) && !defined(__CYGWIN__)
-# include <windows.h>
-# define C_HAS_MESSAGE_BOX 1
-static int
-C_confirmation_dialog(char *msg, char *caption, int def, int abort)
-{
- int d = 0, r;
- int t = abort ? MB_YESNOCANCEL : MB_YESNO;
-
- switch(def) {
- case 0: d = MB_DEFBUTTON1; break;
- case 1: d = MB_DEFBUTTON2; break;
- case 2: d = MB_DEFBUTTON3;
- }
-
- r = MessageBox(NULL, msg, caption, t | MB_ICONQUESTION | d);
-
- switch(r) {
- case IDYES: return 1;
- case IDNO: return 0;
- default: return -1;
- }
-}
-#else
-# define C_HAS_MESSAGE_BOX 0
-static int
-C_confirmation_dialog(char *msg, char *caption, int def, int abort) { return -1; }
-#endif
-<#
-
-;; Note: for Mac OS X, "CFUserNotificationDisplayAlert" could be used,
-;; unless that requires linking any libraries. This would also
-;; be useful for runtime error messages.
-
-(define yes-or-no?
- (let ((dialog (foreign-lambda int "C_confirmation_dialog" c-string c-string int bool))
- (C_HAS_MESSAGE_BOX (foreign-value "C_HAS_MESSAGE_BOX" bool))
- (C_gui_mode (foreign-value "C_gui_mode" bool)))
- (lambda (str #!key default title (abort reset))
- (let ((gui (and C_HAS_MESSAGE_BOX C_gui_mode)))
- (define (get-input)
- (if gui
- (let ((r (dialog
- str
- (or title "CHICKEN Runtime")
- (cond ((not default) 3)
- ((string-ci=? default "yes") 0)
- ((string-ci=? default "no") 1)
- (else 2))
- abort)))
- (case r
- ((0) "no")
- ((1) "yes")
- (else "abort")))
- (read-line)))
- (let loop ()
- (unless gui
- (printf "~%~A (yes/no~a) " str (if abort "/abort" ""))
- (when default (printf "[~A] " default))
- (flush-output))
- (let ((ln (get-input)))
- (cond ((eof-object? ln) (set! ln "abort"))
- ((and default (string=? "" ln)) (set! ln default)) )
- (cond ((string-ci=? "yes" ln) #t)
- ((string-ci=? "no" ln) #f)
- ((and abort (string-ci=? "abort" ln)) (abort))
- (else
- (if abort
- (printf "~%Please enter \"yes\", \"no\" or \"abort\".~%")
- (printf "~%Please enter \"yes\" or \"no\".~%"))
- (loop)))))))))
-
-;;; Module Setup
-
-; User setup by default
-(user-install-setup)
-
-)
diff --git a/setup-download.scm b/setup-download.scm
deleted file mode 100644
index 9eaa8f09..00000000
--- a/setup-download.scm
+++ /dev/null
@@ -1,425 +0,0 @@
-;;;; setup-download.scm
-;
-; Copyright (c) 2008-2016, The CHICKEN Team
-; All rights reserved.
-;
-; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
-; conditions are met:
-;
-; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
-; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
-; disclaimer in the documentation and/or other materials provided with the distribution.
-; Neither the name of the author nor the names of its contributors may be used to endorse or promote
-; products derived from this software without specific prior written permission.
-;
-; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
-; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
-; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
-; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-; POSSIBILITY OF SUCH DAMAGE.
-
-(module setup-download (retrieve-extension
- locate-egg/local
- locate-egg/http
- gather-egg-information
- list-extensions
- list-extension-versions
- temporary-directory)
-
- (import scheme chicken)
- (import setup-api
- chicken.data-structures
- chicken.files
- chicken.foreign
- chicken.format
- chicken.io
- chicken.irregex
- chicken.pathname
- chicken.posix
- chicken.tcp
- chicken.utils)
-
- (include "mini-srfi-1.scm")
-
- (define-constant +default-tcp-connect-timeout+ 30000) ; 30 seconds
- (define-constant +default-tcp-read/write-timeout+ 30000) ; 30 seconds
-
- (define-constant +url-regex+ "(http://)?([^/:]+)(:([^:/]+))?(/.*)?")
-
- (tcp-connect-timeout +default-tcp-connect-timeout+)
- (tcp-read-timeout +default-tcp-read/write-timeout+)
- (tcp-write-timeout +default-tcp-read/write-timeout+)
-
- (define *quiet* #f)
- (define *chicken-install-user-agent* (conc "chicken-install " (chicken-version)))
- (define *trunk* #f)
- (define *mode* 'default)
- (define *windows-shell* (foreign-value "C_WINDOWS_SHELL" bool))
- (define *chicken-release* (foreign-value "C_MAJOR_VERSION" int))
-
- (define (d fstr . args)
- (let ([port (if *quiet* (current-error-port) (current-output-port))])
- (apply fprintf port fstr args)
- (flush-output port) ) )
-
- (define temporary-directory (make-parameter #f))
-
- (define (get-temporary-directory)
- (or (temporary-directory)
- (let ([dir (create-temporary-directory)])
- (temporary-directory dir)
- dir ) ) )
-
- (define (existing-version egg version vs)
- (if version
- (if (member version vs)
- version
- (error "version not found" egg version) )
- (let ([vs (sort vs version>=?)])
- (and (pair? vs)
- (car vs) ) ) ) )
-
- (define (when-no-such-version-warning egg version)
- (when version (warning "extension has no such version - using default" egg version)) )
-
- (define (list-eggs/local dir)
- (string-intersperse (map (cut string-append <> "\n") (directory dir)) "") )
-
- (define (list-egg-versions/local name dir)
- (let ((eggdir (make-pathname dir (string-append name "/tags"))))
- (cond ((directory-exists? eggdir)
- (string-intersperse
- (map (cut string-append <> "\n") (directory eggdir))
- ""))
- (else "unknown\n"))))
-
- ;; Simpler replacement for SRFI-13's string-suffix?
- (define (string-suffix? suffix s)
- (let ((len-s (string-length s))
- (len-suffix (string-length suffix)))
- (and (not (< len-s len-suffix))
- (string=? suffix
- (substring s (fx- len-s len-suffix))))))
-
- (define (locate-egg/local egg dir #!optional version destination clean)
- (let* ((eggdir (make-pathname dir egg))
- (tagdir (make-pathname eggdir "tags"))
- (tagver (and (not *trunk*)
- (file-exists? tagdir) (directory? tagdir)
- (existing-version egg version (directory tagdir)) ) )
- (dest (and destination (make-pathname destination egg))))
- (let-values (((src ver)
- (if tagver
- (values (make-pathname tagdir tagver) tagver)
- (let ((trunkdir (make-pathname eggdir "trunk")))
- (when-no-such-version-warning egg version)
- (if (and (file-exists? trunkdir) (directory? trunkdir))
- (values trunkdir "trunk")
- (values eggdir "") ) ) ) ) )
- (cond ((or (not (file-exists? eggdir)) (not (directory? eggdir)))
- (values #f ""))
- (dest
- (create-directory dest)
- (let ((qdest (qs (normalize-pathname dest)))
- (qsrc (qs (normalize-pathname src)))
- (cmd (if *windows-shell*
- (sprintf "xcopy ~a ~a" src dest)
- (sprintf "cp -r ~a/* ~a" src dest))))
- (d " ~a~%" cmd)
- (if (zero? (system cmd))
- (values dest ver)
- (values #f ""))))
- (else
- ;; remove *.so files in toplevel dir, just for being careful
- (when clean
- (let ((sos (filter (cut string-suffix? ".so" <>) (directory src))))
- (for-each
- (lambda (f)
- (d " deleting stale file `~a' from local build directory~%" f)
- (delete-file* f))
- sos)))
- (values src ver))))))
-
- (define (gather-egg-information dir) ; used by salmonella (among others)
- (let ((ls (directory dir)))
- (filter-map
- (lambda (egg)
- (let-values (((loc version) (locate-egg/local egg dir)))
- (let ((meta (make-pathname loc egg "meta")))
- (and (file-exists? meta)
- (call/cc
- (lambda (return)
- (cons (string->symbol egg)
- (cons (list 'version version)
- (handle-exceptions ex
- (begin
- (warning
- "extension has syntactically invalid .meta file"
- egg)
- (return #f))
- (with-input-from-file meta read))))))))))
- ls)))
-
- (define (metafile dir egg)
- (conc dir #\/ egg ".meta"))
-
- (define (deconstruct-url url)
- (let ([m (irregex-match +url-regex+ url)])
- (values
- (if m (irregex-match-substring m 2) url)
- (if (and m (irregex-match-substring m 3))
- (let ((port (irregex-match-substring m 4)))
- (or (string->number port)
- (error "not a valid port" port)))
- 80)
- (or (and m (irregex-match-substring m 5))
- "/"))))
-
- (define (locate-egg/http egg url #!optional version destination tests
- proxy-host proxy-port proxy-user-pass)
- (receive (host port locn)
- (deconstruct-url url)
- (let* ((locn (string-append
- locn
- "?name=" egg
- "&release=" (->string *chicken-release*)
- (if version (string-append "&version=" version) "")
- "&mode=" (->string *mode*)
- (if tests "&tests=yes" "")))
- (tmpdir (or destination (get-temporary-directory)))
- (eggdir (make-pathname tmpdir egg))
- (pre-existing-dir? (file-exists? eggdir)) )
- (unless pre-existing-dir? (create-directory eggdir))
- (handle-exceptions exn
- (begin (unless pre-existing-dir? (remove-directory eggdir))
- (signal exn))
- (let ((fversion
- (http-fetch host port locn eggdir proxy-host proxy-port proxy-user-pass)))
- ;; If we get here then version of egg exists
- (values eggdir (or fversion version "")) )) ) ) )
-
- (define (network-failure msg . args)
- (signal
- (make-composite-condition
- (make-property-condition
- 'exn
- 'message "invalid response from server"
- 'arguments args)
- (make-property-condition 'http-fetch))) )
-
- (define (make-HTTP-GET/1.1 location user-agent host
- #!key
- (port 80)
- (connection "close")
- (accept "*")
- (content-length 0)
- proxy-host proxy-port proxy-user-pass)
- (conc
- "GET "
- (if proxy-host
- (string-append "http://" host location)
- location)
- " HTTP/1.1" "\r\n"
- "Connection: " connection "\r\n"
- "User-Agent: " user-agent "\r\n"
- "Accept: " accept "\r\n"
- "Host: " host #\: port "\r\n"
- (if proxy-user-pass
- (string-append "Proxy-Authorization: Basic " proxy-user-pass "\r\n")
- "")
- "Content-length: " content-length "\r\n"
- "\r\n") )
-
- (define (match-http-response rsp)
- (and (string? rsp)
- (irregex-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" rsp)) )
-
- (define (response-match-code? mrsp code)
- (and mrsp (string=? (number->string code) (irregex-match-substring mrsp 1))) )
-
- (define (match-chunked-transfer-encoding ln)
- (irregex-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )
-
- (define (http-connect host port locn proxy-host proxy-port proxy-user-pass)
- (d "connecting to host ~s, port ~a ~a...~%" host port
- (if proxy-host
- (sprintf "(via ~a:~a) " proxy-host proxy-port)
- ""))
- (let-values (((in out) (tcp-connect (or proxy-host host) (or proxy-port port))))
- (d "requesting ~s ...~%" locn)
- (display
- (make-HTTP-GET/1.1 locn *chicken-install-user-agent* host port: port accept: "*/*"
- proxy-host: proxy-host proxy-port: proxy-port)
- out)
- (flush-output out)
- (d "reading response ...~%")
- (let ([chunked #f])
- (let* ([h1 (read-line in)]
- [response-match (match-http-response h1)])
- (d "~a~%" h1)
- ;;XXX handle redirects here
- (if (response-match-code? response-match 407)
- (let-values (((inpx outpx) (tcp-connect proxy-host proxy-port)))
- (set! in inpx) (set! out outpx)
- (display
- (make-HTTP-GET/1.1
- locn *chicken-install-user-agent* host port: port accept: "*/*"
- proxy-host: proxy-host proxy-port: proxy-port
- proxy-user-pass: proxy-user-pass)
- out))
- (unless (response-match-code? response-match 200)
- (network-failure "invalid response from server" h1)))
- (let loop ()
- (let ([ln (read-line in)])
- (unless (equal? ln "")
- (when (match-chunked-transfer-encoding ln) (set! chunked #t))
- (d "~a~%" ln)
- (loop) ) ) ) )
- (when chunked
- (d "reading chunks ")
- (let ([data (read-chunks in)])
- (close-input-port in)
- (set! in (open-input-string data))) ) )
- (values in out)))
-
- (define (http-retrieve-files in out dest)
- (d "reading files ...~%")
- (let ((version #f))
- (define (skip)
- (let ((ln (read-line in)))
- (cond ((or (eof-object? ln)
- (irregex-match " *#!eof *" ln))
- (open-input-string ""))
- ((irregex-match " *#\\|[- ]*([^- ]*) *\\|#.*" ln) =>
- (lambda (m)
- (let ((v (irregex-match-substring m 1)))
- (cond ((or (string=? "" v) (string=? "#f" v)))
- ((and version (not (string=? v version)))
- (warning "files-versions are not identical" ln version)
- (set! version #f))
- (else
- (set! version v)))
- (open-input-string ln))))
- ((irregex-match "^[ ]*\\(error .*\\)[ ]*$" ln)
- (open-input-string ln)) ; get-files deals with errors
- ((irregex-match '(* ("\x09\x0a\x0b\x0c\x0d\x20\xa0")) ln)
- (skip)) ; Blank line.
- (else
- (error "unrecognized file-information - possibly corrupt transmission"
- ln)))))
- (let get-files ((files '()))
- (let ((ins (skip)))
- (let ((name (read ins)))
- (cond ((and (pair? name) (eq? 'error (car name)))
- (throw-server-error (cadr name) (cddr name)))
- ((or (eof-object? name) (not name))
- (close-input-port in)
- (close-output-port out)
- version)
- ((not (string? name))
- (error "invalid file name - possibly corrupt transmission" name) )
- ((string-suffix? "/" name)
- (d " ~a~%" name)
- (create-directory (make-pathname dest name))
- (get-files files) )
- (else
- (d " ~a~%" name)
- (let* ((size (read ins))
- (data (read-string size in)) )
- (with-output-to-file (make-pathname dest name) (cut display data) #:binary ) )
- (get-files (cons name files)) ) ) ) ) )))
-
- (define (http-fetch host port locn dest proxy-host proxy-port proxy-user-pass)
- (let-values (((in out)
- (http-connect host port locn proxy-host proxy-port proxy-user-pass)))
- (http-retrieve-files in out dest)))
-
- (define (list-eggs/http location proxy-host proxy-port proxy-user-pass)
- (let-values ([(host port locn) (deconstruct-url location)])
- (let-values (((in out)
- (http-connect
- host port
- (string-append locn "?list=1")
- proxy-host proxy-port proxy-user-pass)))
- (let ((ls (read-string #f in)))
- (close-input-port in)
- (close-output-port out)
- ls))))
-
- (define (throw-server-error msg args)
- (abort
- (make-composite-condition
- (make-property-condition
- 'exn
- 'message (string-append "[Server] " msg)
- 'arguments args)
- (make-property-condition 'setup-download-error))))
-
- (define (read-chunks in)
- (let get-chunks ([data '()])
- (let ((size (string->number (read-line in) 16)))
- (cond ((not size)
- (error "invalid response from server - please try again"))
- ((zero? size)
- (d "~%")
- (string-intersperse (reverse data) ""))
- (else
- (let ([chunk (read-string size in)])
- (d ".")
- (read-line in)
- (get-chunks (cons chunk data)) ) ) ) ) ))
-
- (define slashes '("\\" "/"))
-
- (define (valid-extension-name? name)
- (and (not (member name '("" ".." ".")))
- (not (any (lambda (slash)
- (substring-index slash name))
- slashes))))
-
- (define (check-egg-name name)
- (unless (valid-extension-name? name)
- (error "invalid extension name" name)))
-
- (define (retrieve-extension name transport location
- #!key version quiet destination username password tests
- proxy-host proxy-port proxy-user-pass
- trunk (mode 'default) clean)
- (check-egg-name name)
- (fluid-let ((*quiet* quiet)
- (*trunk* trunk)
- (*mode* mode))
- (case transport
- ((local)
- (locate-egg/local name location version destination clean) )
- ((http)
- (locate-egg/http name location version destination tests proxy-host proxy-port proxy-user-pass) )
- (else
- (error "cannot retrieve extension - unsupported transport" transport) ) ) ) )
-
- (define (list-extensions transport location #!key quiet username password
- proxy-host proxy-port proxy-user-pass)
- (fluid-let ((*quiet* quiet))
- (case transport
- ((local)
- (list-eggs/local location) )
- ((http)
- (list-eggs/http location proxy-host proxy-port proxy-user-pass))
- (else
- (error "cannot list extensions - unsupported transport" transport) ) ) ) )
-
- (define (list-extension-versions name transport location #!key quiet username password)
- (check-egg-name name)
- (fluid-let ((*quiet* quiet))
- (case transport
- ((local)
- (list-egg-versions/local name location) )
- (else
- (error "cannot list extensions - unsupported transport" transport) ) ) ) )
-
-) ;module setup-download
Trap