~ chicken-core (chicken-5) /chicken-install.scm
Trap1;;;; chicken-install.scm2;3; Copyright (c) 2008-2022, The CHICKEN Team4; All rights reserved.5;6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following7; conditions are met:8;9; Redistributions of source code must retain the above copyright notice, this list of conditions and the following10; disclaimer.11; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following12; disclaimer in the documentation and/or other materials provided with the distribution.13; Neither the name of the author nor the names of its contributors may be used to endorse or promote14; products derived from this software without specific prior written permission.15;16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE24; POSSIBILITY OF SUCH DAMAGE.2526(declare27 (uses chicken-ffi-syntax)) ; populate ##sys#chicken-ffi-macro-environment2829(module main ()3031(import (scheme))32(import (chicken base))33(import (chicken condition))34(import (chicken foreign))35(import (chicken keyword))36(import (chicken file))37(import (chicken file posix))38(import (chicken fixnum))39(import (chicken format))40(import (chicken irregex))41(import (chicken module))42(import (chicken tcp))43(import (chicken port))44(import (chicken platform))45(import (chicken internal))46(import (chicken io))47(import (chicken sort))48(import (chicken time))49(import (chicken pathname))50(import (chicken process))51(import (chicken process-context))52(import (chicken pretty-print))53(import (chicken string))5455(define +defaults-version+ 2)56(define +module-db+ "modules.db")57(define +defaults-file+ "setup.defaults")58(define +short-options+ '(#\h #\k #\s #\r #\n #\u #\v))59(define +one-hour+ (* 60 60))60(define +internal-modules+ '(chicken.internal chicken.internal.syntax))6162(include "mini-srfi-1.scm")63(include "egg-environment.scm")64(include "egg-information.scm")65(include "egg-compile.scm")66(include "egg-download.scm")6768(define user-defaults #f)69(define quiet #t)70(define default-servers '())71(define default-locations '())72(define mappings '())73(define aliases '())74(define override '())75(define hacks '())76(define proxy-host #f)77(define proxy-port #f)78(define proxy-user-pass #f)79(define retrieve-only #f)80(define retrieve-recursive #f)81(define do-not-build #f)82(define no-install #f)83(define no-install-dependencies #f)84(define list-versions-only #f)85(define canonical-eggs '())86(define requested-eggs '())87(define dependencies '())88(define checked-eggs '())89(define run-tests #f)90(define force-install #f)91(define host-extension cross-chicken)92(define target-extension cross-chicken)93(define sudo-install #f)94(define sudo-program (or (get-environment-variable "SUDO") "sudo"))95(define update-module-db #f)96(define purge-mode #f)97(define keepfiles #f)98(define print-repository #f)99(define cached-only #f)100101(define platform102 (if (eq? (software-version) 'mingw32) 'windows 'unix))103104(define current-status105 (list ##sys#build-id default-prefix106 (get-environment-variable "CSC_OPTIONS")107 (get-environment-variable "LD_LIBRARY_PATH")108 (get-environment-variable "DYLD_LIBRARY_PATH")109 (get-environment-variable "CHICKEN_INCLUDE_PATH")110 (get-environment-variable "DYLD_LIBRARY_PATH")))111112(define (repo-path)113 (if (and cross-chicken (not host-extension))114 (##sys#split-path (destination-repository 'target))115 (repository-path)))116117(define (install-path)118 (if (and cross-chicken (not host-extension))119 (destination-repository 'target)120 (destination-repository 'host)))121122(define (build-script-extension mode platform)123 (string-append "build"124 (if (eq? mode 'target) ".target" "")125 (if (eq? platform 'windows) ".bat" ".sh")))126127(define (install-script-extension mode platform)128 (string-append "install"129 (if (eq? mode 'target) ".target" "")130 (if (eq? platform 'windows) ".bat" ".sh")))131132133;;; validate egg-information tree134135(define (egg-version? v)136 (and (list? v)137 (pair? v)138 (null? (cdr v))139 (let ((str (->string (car v))))140 (irregex-match '(seq (+ numeric)141 (? #\. (+ numeric)142 (? #\. (+ numeric))))143 str))))144145(define (optname? x)146 (and (list? x)147 (or (null? x)148 (string? (car x))149 (symbol? (car x)))))150151(define (nameprop? x)152 (and (list? x) (or (symbol? (car x)) (string? (car x)))))153154(define (name-or-predefd? x)155 (or (optname? x)156 (and (pair? x)157 (pair? (car x))158 (eq? 'predefined (caar x))159 (optname? (cdar x)))))160161;; ENTRY = (NAME TOPLEVEL? NESTED? NAMED? [VALIDATOR])162(define egg-info-items163 `((synopsis #t #f #f)164 (author #t #f #f)165 (category #t #f #f)166 (license #t #f #f)167 (version #t #f #f ,egg-version?)168 (dependencies #t #f #f ,list?)169 (source-dependencies #f #f #f ,list?)170 (component-dependencies #f #f #f ,list?)171 (test-dependencies #t #f #f ,list?)172 (build-dependencies #t #f #f ,list?)173 (components #t #t #f)174 (foreign-dependencies #t #f #f ,list?)175 (platform #t #f #f)176 (installed-files #t #f #f ,list?)177 (maintainer #t #f #f)178 (files #f #f #f ,list?)179 (distribution-files #t #f #f ,list?) ;; handled by henrietta-cache180 (source #f #f #f)181 (csc-options #f #f #f)182 (link-options #f #f #f)183 (custom-build #f #f #f)184 (linkage #f #f #f)185 (objects #f #f #f)186 (destination #f #f #f ,list?)187 (install-name #f #f #f ,nameprop?)188 (target #f #t #f)189 (host #f #t #f)190 (types-file #f #f #f ,name-or-predefd?)191 (inline-file #f #f #f ,optname?)192 (extension #f #t #t)193 (c-object #f #t #t)194 (generated-source-file #f #t #t)195 (program #f #t #t)196 (data #f #t #t)197 (modules #f #f #f)198 (component-options #t #f #f)199 (cond-expand * #t #f)200 (error * #f #f)201 (c-include #f #f #t)202 (scheme-include #f #f #t)))203204(define (validate-egg-info info)205 (define (validate info top?)206 (for-each207 (lambda (item)208 (cond ((or (not (pair? item))209 (not (list? item))210 (not (symbol? (car item))))211 (error "invalid egg information item" item))212 ((assq (car item) egg-info-items) =>213 (lambda (a)214 (apply (lambda (name toplevel nested named #!optional validator)215 (cond ((and top?216 (not (eq? toplevel '*))217 (not toplevel))218 (error "egg information item not allowed at toplevel"219 item))220 ((and (not (eq? toplevel '*))221 toplevel222 (not top?))223 (error "egg information item only allowed at toplevel" item))224 ((and named225 (or (null? (cdr item))226 (not (symbol? (cadr item)))))227 (error "unnamed egg information item" item))228 ((and validator229 (not (validator (cdr item))))230 (error "egg information item has invalid structure" item)))231 (when nested232 (cond (named (validate (cddr item) #f))233 ((eq? name 'cond-expand)234 (for-each235 (lambda (clause)236 (unless (and (list? clause)237 (>= (length clause) 1))238 (error "invalid syntax in `cond-expand' clause" clause))239 (validate (cdr clause) top?))240 (cdr item)))241 (else (validate (cdr item) #f)))))242 a)))243 (else (error "unknown egg information item" item))))244 info))245 (validate info #t)246 info)247248249;; utilities250251;; Simpler replacement for SRFI-13's "string-suffix?"252(define (string-suffix? suffix s)253 (let ((len-s (string-length s))254 (len-suffix (string-length suffix)))255 (and (not (< len-s len-suffix))256 (string=? suffix257 (substring s (- len-s len-suffix))))))258259(define (d flag . args)260 (let ((flag (and (not (string? flag)) flag))261 (fstr (if (string? flag) flag (car args)))262 (args (if (string? flag) args (cdr args))))263 (when (or flag (not quiet))264 (flush-output)265 (let ((port (current-error-port)))266 (apply fprintf port fstr args)267 (flush-output port) ) )))268269(define (version>=? v1 v2)270 (define (version->list v)271 (map (lambda (x) (or (string->number x) x))272 (irregex-split "[-\\._]" (->string v))))273 (let loop ((p1 (version->list v1))274 (p2 (version->list v2)))275 (cond ((null? p1) (null? p2))276 ((null? p2))277 ((number? (car p1))278 (and (number? (car p2))279 (or (> (car p1) (car p2))280 (and (= (car p1) (car p2))281 (loop (cdr p1) (cdr p2))))))282 ((number? (car p2)))283 ((string>? (car p1) (car p2)))284 (else285 (and (string=? (car p1) (car p2))286 (loop (cdr p1) (cdr p2)))))))287288289;; load defaults file ("setup.defaults")290291(define (load-defaults)292 (let* ((cfg-dir (system-config-directory))293 (user-file (and cfg-dir (make-pathname (list cfg-dir "chicken")294 +defaults-file+)))295 (deff (or user-defaults296 (and user-file (file-exists? user-file))297 (make-pathname host-sharedir +defaults-file+))))298 (define (broken x)299 (error "invalid entry in defaults file" deff x))300 (cond ((not (file-exists? deff)) '())301 (else302 (for-each303 (lambda (x)304 (unless (and (list? x) (positive? (length x)))305 (broken x))306 (case (car x)307 ((version)308 (cond ((not (pair? (cdr x))) (broken x))309 ((not (= (cadr x) +defaults-version+))310 (error311 (sprintf312 "version of installed `~a' does not match chicken-install version (~a)"313 +defaults-file+314 +defaults-version+)315 (cadr x)))316 ;; others are ignored317 ))318 ((server)319 (set! default-servers320 (append default-servers (cdr x))))321 ((map)322 (set! mappings323 (append324 mappings325 (map (lambda (m)326 (let ((p (list-index (cut eq? '-> <>) m)))327 (unless p (broken x))328 (let-values (((from to) (split-at m p)))329 (cons from (cdr to)))))330 (cdr x)))))331 ((alias)332 (set! aliases333 (append334 aliases335 (map (lambda (a)336 (if (and (list? a) (= 2 (length a)) (every string? a))337 (cons (car a) (cadr a))338 (broken x)))339 (cdr x)))))340 ((override)341 (set! override342 (if (and (pair? (cdr x)) (string? (cadr x)))343 (call-with-input-file (cadr x) read-list)344 (cdr x))))345 ((location)346 (set! default-locations347 (append default-locations (cdr x))))348 ((hack)349 (set! hacks (append hacks (list (eval (cadr x))))))350 (else (broken x))))351 (call-with-input-file deff read-list))))))352353354;; set variables with HTTP proxy information355356(define (setup-proxy uri)357 (and-let* (((string? uri))358 (m (irregex-match "(http://)?([^:]+):?([0-9]*)" uri))359 (port (irregex-match-substring m 3)))360 (set! proxy-user-pass (get-environment-variable "proxy_auth"))361 (set! proxy-host (irregex-match-substring m 2))362 (set! proxy-port (or (string->number port) 80))))363364365;; apply egg->egg mappings loaded from defaults366367(define (canonical x)368 (cond ((symbol? x) (cons (symbol->string x) #f))369 ((string? x) (cons x #f))370 ((pair? x) x)371 (else (error "internal error - bad egg spec" x))))372373(define (apply-mappings eggs)374 (define (same? e1 e2)375 (equal? (car (canonical e1)) (car (canonical e2))))376 (let ((eggs2377 (delete-duplicates378 (append-map379 (lambda (egg)380 (cond ((find (lambda (m) (find (cut same? egg <>) (car m)))381 mappings) =>382 (lambda (m) (map ->string (cdr m))))383 (else (list egg))))384 eggs)385 same?)))386 (unless (and (= (length eggs) (length eggs2))387 (every (lambda (egg)388 (find (cut same? <> egg) eggs2))389 eggs))390 (d "mapped ~s to ~s~%" eggs eggs2))391 eggs2))392393394;; override versions, if specified in "overrides" file395396(define (override-version egg)397 (let ((name (string->symbol (if (pair? egg) (car egg) egg))))398 (cond ((assq name override) =>399 (lambda (a)400 (if (and (pair? egg)401 (pair? (cdr a))402 (not (equal? (cadr a) (cdr egg))))403 (warning404 (sprintf405 "version `~a' of extension `~a' overrides explicitly given version `~a'"406 (cadr a) name (cdr egg)))407 (d "overriding: ~a~%" a))408 (if (null? (cdr a))409 (and (pair? egg) (cdr egg))410 (cadr a))))411 ((pair? egg) (cdr egg))412 (else #f))))413414415;; "locate" egg: either perform HTTP download or copy from a file-system416;; location, also make sure it is up to date417418(define (locate-egg name version)419 (let* ((cached (make-pathname cache-directory name))420 (metadata-dir (make-pathname cache-metadata-directory name))421 (now (current-seconds))422 (status (make-pathname metadata-dir +status-file+))423 (eggfile (make-pathname cached name +egg-extension+)))424 (define (fetch lax)425 (when (file-exists? cached)426 (delete-directory cached #t))427 (when (file-exists? metadata-dir)428 (delete-directory metadata-dir #t))429 (create-directory cached #t)430 (create-directory metadata-dir #t)431 (fetch-egg-sources name version cached lax))432 (cond ((and (probe-dir cached)433 (not (file-exists? status)))434 ;; If for whatever reason the status file doesn't exist435 ;; (e.g., it was renamed, as in 2f6a7221), reset the cache436 ;; of the egg to prevent the object files in there from437 ;; being reused.438 (d "resetting ~a, as ~a does not exist~%" cached status)439 (fetch #f))440 ((or (not (probe-dir cached))441 (not (file-exists? eggfile)))442 (d "~a not cached~%" name)443 (when cached-only (error "extension not cached" name))444 (fetch #f))445 ((and (file-exists? status)446 (not (equal? current-status447 (with-input-from-file status read))))448 (d "status changed for ~a~%" name)449 (cond (cached-only450 (if force-install451 (warning "cached egg does not match CHICKEN version" name)452 (error "cached egg does not match CHICKEN version - use `-force' to install anyway" name)))453 (else (fetch #f)))))454 (let* ((info (validate-egg-info (load-egg-info eggfile)))455 (vfile (make-pathname metadata-dir +version-file+))456 (tfile (make-pathname metadata-dir +timestamp-file+))457 (lversion (or (get-egg-property info 'version)458 (and (file-exists? vfile)459 (with-input-from-file vfile read)))))460 (cond ((and (not cached-only)461 (if (string? version)462 (not (equal? version lversion))463 (or (and (file-exists? tfile)464 (> (- now (with-input-from-file tfile read)) +one-hour+))465 (not (check-remote-version name lversion cached)))))466 (d "version of ~a out of date~%" name)467 (fetch #t)468 (let* ((info (validate-egg-info (load-egg-info eggfile))) ; new egg info (fetched)469 (lversion (or (get-egg-property info 'version)470 (and (file-exists? vfile)471 (with-input-from-file vfile read)))))472 (values cached lversion)))473 (else (values cached version))))))474475(define (resolve-location name)476 (cond ((assoc name aliases) =>477 (lambda (a)478 (let ((new (cdr a)))479 (d "resolving alias `~a' to: ~a~%" name new)480 (resolve-location new))))481 (else name)))482483(define (locate-local-egg-dir location egg-name version)484 ;; Locate the directory of egg-name, considering the following485 ;; directory layouts in order:486 ;; * <location>/<egg-name>/<egg-name>.egg487 ;; * <location>/<egg-name>/<version>/<egg-name>.egg488 ;;489 ;; Return (values <egg-dir> <version>). <egg-dir> and <version>490 ;; will be #f in case they cannot be determined.491 (let ((egg-dir (probe-dir (make-pathname location egg-name))))492 (cond493 ((not egg-dir)494 (values #f #f))495 ;; <location>/<egg-name>/<egg-name>.egg496 ((file-exists? (make-pathname egg-dir egg-name +egg-extension+))497 (values egg-dir #f))498 (else499 ;; <location>/<egg-name>/<version>/<egg-name>.egg500 (if version501 (values (probe-dir (make-pathname egg-dir (->string version)))502 version)503 (let ((versions (directory egg-dir)))504 (if (null? versions)505 (values #f #f)506 (let ((latest (car (sort versions version>=?))))507 (values (make-pathname egg-dir (->string latest))508 latest)))))))))509510(define (write-cache-metadata egg egg-version)511 (let ((metadata-dir (make-pathname cache-metadata-directory egg)))512 (when egg-version513 (with-output-to-file (make-pathname metadata-dir +version-file+)514 (cut write egg-version)))515 (with-output-to-file (make-pathname metadata-dir +timestamp-file+)516 (cut write (current-seconds)))517 (with-output-to-file (make-pathname metadata-dir +status-file+)518 (cut write current-status))))519520(define (fetch-egg-sources name version dest lax)521 (print "fetching " name)522 (let loop ((locs default-locations))523 (cond ((null? locs)524 (let ((tmpdir (create-temporary-directory)))525 (let loop ((srvs (map resolve-location default-servers)))526 (if (null? srvs)527 (if lax528 (print "no connection to server or egg not found remotely - will use cached version")529 (begin530 (delete-directory dest)531 (delete-directory tmpdir)532 (error "extension or version not found" name)))533 (begin534 (d "trying server ~a ...~%" (car srvs))535 (receive (dir ver)536 (try-download name (car srvs)537 version: version538 destination: tmpdir539 tests: #t ;; Always fetch tests, otherwise cached eggs can't be tested later540 proxy-host: proxy-host541 proxy-port: proxy-port542 proxy-user-pass: proxy-user-pass)543 (cond (dir544 (copy-egg-sources tmpdir dest)545 (delete-directory tmpdir #t)546 (write-cache-metadata name ver))547 (else (loop (cdr srvs))))))))))548 (else549 (receive (dir version-from-path)550 (locate-local-egg-dir (car locs) name version)551 (if dir552 (let* ((eggfile (make-pathname dir name +egg-extension+))553 (info (validate-egg-info (load-egg-info eggfile)))554 (rversion555 ;; If version-from-path is non-#f, prefer it556 ;; over rversion, as it means the egg author557 ;; actually tagged the egg. rversion might558 ;; be outdated in case the egg author forgot559 ;; to bump it in the .egg file.560 (or version-from-path561 (get-egg-property info 'version))))562 (d "trying location ~a ...~%" dir)563 (if (or (not rversion)564 (not version)565 (version>=? rversion version))566 (begin567 (copy-egg-sources dir dest)568 (write-cache-metadata name (or rversion version)))569 (loop (cdr locs))))570 (loop (cdr locs))))))))571572573(define (copy-egg-sources from to)574 ;;XXX should probably be done manually, instead of calling tool575 (let ((cmd (string-append576 (copy-directory-command platform)577 ;; Don't quote the globbing character!578 " " (make-pathname (qs* from platform #t) "*")579 " " (qs* to platform #t))))580 (d "~a~%" cmd)581 (system+ cmd platform)))582583(define (check-remote-version name lversion cached)584 (let loop ((locs default-locations))585 (cond ((null? locs)586 (let loop ((srvs (map resolve-location default-servers)))587 (and (pair? srvs)588 (let ((versions (try-list-versions name (car srvs))))589 (or (and versions590 (every (cut version>=? lversion <>) versions))591 (loop (cdr srvs)))))))592 ;; The order of probe-dir's here is important. First try593 ;; the path with version, then the path without version.594 ((or (probe-dir (make-pathname (list (car locs) name)595 (->string lversion)))596 (probe-dir (make-pathname (car locs) name)))597 => (lambda (dir)598 ;; for locally available eggs, check set of files and599 ;; timestamps600 (compare-trees dir cached)))601 (else (loop (cdr locs))))))602603(define (compare-trees there here)604 (let walk ((there there)605 (here here))606 (let ((tfs (directory there))607 (hfs (directory here)))608 (every (lambda (f)609 (and (member f hfs)610 (let ((tf2 (make-pathname there f))611 (hf2 (make-pathname here f)))612 (and (<= (file-modification-time tf2)613 (file-modification-time hf2))614 (if (directory-exists? tf2)615 (and (directory-exists? hf2)616 (walk tf2 hf2))617 (not (directory-exists? hf2)))))))618 tfs))))619620621;; check installed eggs for already installed files622623(define (matching-installed-files egg fnames)624 (let ((eggs (glob (make-pathname (install-path) "*" +egg-info-extension+))))625 (let loop ((eggs eggs) (same '()))626 (cond ((null? eggs) same)627 ((string=? egg (pathname-file (car eggs)))628 (loop (cdr eggs) same))629 (else630 (let* ((info (load-egg-info (car eggs)))631 (files (assq 'installed-files info))632 (mfiles (and files633 (filter (lambda (fname)634 (and (not (member fname same))635 (member fname files)))636 fnames))))637 (loop (cdr eggs) (append (or mfiles '()) same))))))))638639(define (check-installed-files name info)640 (let ((bad (matching-installed-files name (cdr (assq 'installed-files info)))))641 (unless (null? bad)642 (flush-output)643 (fprintf (current-error-port)644 "\nthe extension `~a' will overwrite the following files:\n\n" name)645 (for-each646 (lambda (fname)647 (fprintf (current-error-port) " ~a~%" fname))648 bad)649 (exit 1))))650651652;; retrieve eggs, recursively (if needed)653654(define (retrieve-eggs eggs)655 (for-each656 (lambda (egg)657 (cond ((assoc egg canonical-eggs) =>658 (lambda (a)659 ;; push to front660 (set! canonical-eggs (cons a (delete a canonical-eggs eq?)))))661 (else662 (let ((name (if (pair? egg) (car egg) egg))663 (version (override-version egg)))664 (let-values (((dir ver) (locate-egg name version)))665 (when (or (not dir)666 (null? (directory dir)))667 (when dir (delete-directory dir))668 (error "extension or version not found" name))669 (d retrieve-only "~a located at ~a~%" egg dir)670 (set! canonical-eggs671 (cons (list name dir ver) canonical-eggs)))))))672 eggs)673 (when (or (not retrieve-only) retrieve-recursive)674 (for-each675 (lambda (e+d+v)676 (unless (member (car e+d+v) checked-eggs)677 (d "checking ~a ...~%" (car e+d+v))678 (set! checked-eggs (cons (car e+d+v) checked-eggs))679 (let* ((fname (make-pathname (cadr e+d+v) (car e+d+v) +egg-extension+))680 (info (validate-egg-info (load-egg-info fname))))681 (d "checking platform for `~a'~%" (car e+d+v))682 (check-platform (car e+d+v) info)683 (d "checking dependencies for `~a'~%" (car e+d+v))684 (let-values (((missing upgrade)685 (outdated-dependencies (car e+d+v) info)))686 (set! missing (apply-mappings missing))687 (set! dependencies688 (cons (cons (car e+d+v)689 (map (lambda (mu)690 (if (pair? mu)691 (car mu)692 mu))693 (append missing upgrade)))694 dependencies))695 (when (pair? missing)696 (d " missing: ~a~%" (string-intersperse missing ", "))697 (retrieve-eggs missing))698 (when (and (pair? upgrade)699 (or force-install700 (replace-extension-question e+d+v upgrade)))701 (let ((ueggs (unzip1 upgrade)))702 (d " upgrade: ~a~%" (string-intersperse ueggs ", "))703 ;; XXX think about this...704 #;(for-each705 (lambda (e)706 (d "removing previously installed extension `~a'" e)707 (remove-extension e) )708 ueggs)709 (retrieve-eggs ueggs) ) ) ) ) ) )710 canonical-eggs)))711712(define (outdated-dependencies egg info)713 (let ((ds (get-egg-dependencies info)))714 (for-each (lambda (h) (set! ds (h egg ds))) hacks)715 (let loop ((deps ds) (missing '()) (upgrade '()))716 (if (null? deps)717 (values (reverse missing) (reverse upgrade))718 (let-values (((m u) (check-dependency (car deps))))719 (loop (cdr deps)720 (if m (cons m missing) missing)721 (if u (cons u upgrade) upgrade)))))))722723(define (get-egg-dependencies info)724 (append (get-egg-property* info 'dependencies '())725 (get-egg-property* info 'build-dependencies '())726 (if run-tests727 (get-egg-property* info 'test-dependencies '())728 '())))729730(define (check-dependency dep)731 (cond ((or (symbol? dep) (string? dep))732 (values (and (not (ext-version dep)) (->string dep))733 #f))734 ((and (list? dep) (eq? 'or (car dep)))735 (let scan ((ordeps (cdr dep)) (bestm #f) (bestu #f))736 (if (null? ordeps)737 (values (cond (bestu #f) ; upgrade overrides new738 (bestm bestm)739 (else #f))740 bestu)741 (let-values (((m u) (check-dependency (car ordeps))))742 (if (and (not m) (not u))743 (values #f #f)744 (scan (cdr ordeps)745 (if (and m (not bestm))746 m747 bestm)748 (if (and u (not bestu))749 u750 bestu)))))))751 ((and (list? dep) (= 2 (length dep))752 (or (string? (car dep)) (symbol? (car dep))))753 (let ((v (ext-version (car dep))))754 (cond ((not v)755 (values (->string (car dep)) #f))756 ((not (version>=? v (->string (cadr dep))))757 (cond ((string=? "chicken" (->string (car dep)))758 (if force-install759 (values #f #f)760 (error761 (string-append762 "Your CHICKEN version is not recent enough to use this extension - version "763 (cadr dep)764 " or newer is required"))))765 (else766 (values #f767 (cons (->string (car dep)) (->string (cadr dep)))))))768 (else (values #f #f)))))769 (else770 (warning "invalid dependency syntax in extension meta information"771 dep)772 (values #f #f))))773774(define (ext-version x)775 (cond ((or (eq? x 'chicken) (equal? x "chicken"))776 (chicken-version))777 ((let* ((sf (chicken.load#find-file778 (make-pathname #f (->string x) +egg-info-extension+)779 (repo-path))))780 (and sf781 (file-exists? sf)782 (load-egg-info sf))) =>783 (lambda (info)784 (let ((a (assq 'version info)))785 (if a786 (->string (cadr a))787 "0.0.0"))))788 (else #f)))789790(define (check-platform name info)791 (unless cross-chicken792 (and-let* ((platform (get-egg-property info 'platform)))793 (or (let loop ((p platform))794 (cond ((symbol? p)795 (feature? p))796 ((not (list? p))797 (error "invalid `platform' property" name platform))798 ((and (eq? 'not (car p)) (pair? (cdr p)))799 (not (loop (cadr p))))800 ((eq? 'and (car p))801 (every loop (cdr p)))802 ((eq? 'or (car p))803 (any loop (cdr p)))804 (else (error "invalid `platform' property" name platform))))805 (error "extension is not targeted for this system" name)))))806807(define (replace-extension-question e+d+v upgrade)808 (print (string-intersperse809 (append810 (list "The following installed extensions are outdated, because `"811 (car e+d+v)812 "' requires later versions:\n\n")813 (filter-map814 (lambda (e)815 (cond ((assq (string->symbol (car e)) override) =>816 (lambda (a)817 (when (and (pair? (cdr a))818 (not (equal? (cadr a) (cdr e))))819 (warning820 (sprintf "version `~a' of extension `~a' overrides required version `~a'"821 (cadr a) (car a) (cdr e))))822 #f))823 (else824 (conc " " (car e) " ("825 (or (ext-version (car e)) "unknown") " -> " (cdr e)826 ")" #\newline))))827 upgrade))828 ""))829 (let loop ()830 (display "Do you want to replace the existing extensions? (yes/no/abort) ")831 (flush-output)832 (let ((r (trim (read-line))))833 (cond ((string=? r "yes"))834 ((string=? r "no") #f)835 ((string=? r "abort") (exit 2))836 (else (loop))))))837838(define (trim str)839 (define (left lst)840 (cond ((null? lst) '())841 ((char-whitespace? (car lst)) (left (cdr lst)))842 (else (cons (car lst) (left (cdr lst))))))843 (list->string (reverse (left (reverse (left (string->list str)))))))844845846;; list available egg versions on servers847848(define (list-egg-versions eggs)849 (let ((srvs (map resolve-location default-servers)))850 (let loop1 ((eggs eggs))851 (unless (null? eggs)852 (let* ((egg (car eggs))853 (name (if (pair? egg) (car egg) egg)))854 (let loop2 ((srvs srvs))855 (and (pair? srvs)856 (let ((versions (try-list-versions name (car srvs))))857 (or (and versions858 (begin859 (printf "~a:" name)860 (for-each (cut printf " ~a" <>) versions)861 (newline)))862 (loop2 (cdr srvs))))))863 (loop1 (cdr eggs)))))))864865866;; perform installation of retrieved eggs867868(define (install-eggs)869 (for-each870 (lambda (egg)871 (let* ((name (car egg))872 (dir (cadr egg))873 (metadata-dir (make-pathname cache-metadata-directory name))874 (eggfile (make-pathname dir name +egg-extension+))875 (info (load-egg-info eggfile))876 (vfile (make-pathname metadata-dir +version-file+))877 (ver (and (file-exists? vfile)878 (with-input-from-file vfile read))))879 (when (or host-extension880 (and (not target-extension)881 (not host-extension)))882 (let-values (((build install info) (compile-egg-info eggfile883 info884 ver885 platform886 'host)))887 (let ((bscript (make-pathname dir name888 (build-script-extension 'host platform)))889 (iscript (make-pathname dir name890 (install-script-extension 'host891 platform))))892 (generate-shell-commands platform build bscript dir893 (build-prefix 'host name info)894 (build-suffix 'host name info)895 keepfiles)896 (generate-shell-commands platform install iscript dir897 (install-prefix 'host name info)898 (install-suffix 'host name info)899 keepfiles)900 (cond (do-not-build (print bscript "\n" iscript))901 (else902 (print "building " name)903 (run-script dir bscript platform)904 (unless (if (member name requested-eggs) no-install no-install-dependencies)905 (check-installed-files name info)906 (print "installing " name)907 (run-script dir iscript platform sudo: sudo-install))908 (when (and (member name requested-eggs)909 run-tests910 (not (test-egg egg platform)))911 (exit 2)))))))912 (when target-extension913 (let-values (((build install info) (compile-egg-info eggfile914 info915 ver916 platform917 'target)))918 (let ((bscript (make-pathname dir name919 (build-script-extension 'target platform)))920 (iscript (make-pathname dir name921 (install-script-extension 'target922 platform))))923 (generate-shell-commands platform build bscript dir924 (build-prefix 'target name info)925 (build-suffix 'target name info)926 keepfiles)927 (generate-shell-commands platform install iscript dir928 (install-prefix 'target name info)929 (install-suffix 'target name info)930 keepfiles)931 (cond (do-not-build (print bscript "\n" iscript))932 (else933 (print "building " name " (target)")934 (run-script dir bscript platform)935 (unless (if (member name requested-eggs) no-install no-install-dependencies)936 (print "installing " name " (target)")937 (run-script dir iscript platform)))))))))938 (order-installed-eggs)))939940(define (order-installed-eggs)941 (let* ((dag (reverse (sort-dependencies dependencies string=?)))942 (ordered (filter-map (cut assoc <> canonical-eggs) dag)))943 (unless quiet944 (d "install order:~%")945 (pp dag))946 ordered))947948(define (test-egg egg platform)949 (let* ((name (car egg))950 (dir (cadr egg))951 (version (caddr egg))952 (testdir (make-pathname dir "tests"))953 (tscript (make-pathname testdir "run.scm")))954 (if (and (directory-exists? testdir)955 (file-exists? tscript))956 (let ((old (current-directory))957 (cmd (string-append (qs* default-csi platform)958 " -s " (qs* tscript platform)959 " " (qs* name platform)960 " " (or version ""))))961 (change-directory testdir)962 (d "running: ~a~%" cmd)963 (let ((r (system+ cmd platform)))964 (flush-output (current-error-port))965 (cond ((zero? r)966 (change-directory old)967 #t)968 (else969 (print "test script failed with nonzero exit status")970 #f))))971 #t)))972973(define (run-script dir script platform #!key sudo (stop #t))974 (d "running script ~a~%" script)975 (exec (if (eq? platform 'windows)976 script977 (string-append978 (if sudo979 (string-append sudo-program " ")980 "")981 (let ((dyld (and (eq? (software-version) 'macosx)982 (get-environment-variable "DYLD_LIBRARY_PATH"))))983 (if dyld984 (string-append "/usr/bin/env DYLD_LIBRARY_PATH="985 (qs* dyld platform)986 " ")987 ""))988 "sh " script))989 stop))990991(define (exec cmd #!optional (stop #t))992 (d "executing: ~s~%" cmd)993 (let ((r (system+ cmd platform)))994 (unless (zero? r)995 (if stop996 (error "shell command terminated with nonzero exit code" r cmd)997 (print "shell command terminated with nonzero exit code " r ": " cmd)))998 r))99910001001;;; update module-db10021003(define (update-db)1004 (let* ((files (glob (make-pathname (install-path) "*.import.so")1005 (make-pathname (install-path) "*.import.scm")))1006 (dbfile (create-temporary-file)))1007 (print "loading import libraries ...")1008 (fluid-let ((##sys#warnings-enabled #f))1009 (for-each1010 (lambda (path)1011 (let* ((file (pathname-strip-directory path))1012 (import-name (pathname-strip-extension file))1013 (module-name (pathname-strip-extension import-name)))1014 (handle-exceptions ex1015 (print-error-message1016 ex (current-error-port)1017 (sprintf "Failed to import from `~a'" file))1018 (unless quiet (print "loading " file " ..."))1019 (eval `(import-syntax ,(string->symbol module-name))))))1020 files))1021 (print "generating database ...")1022 (let ((db1023 (sort1024 (concatenate1025 (filter-map1026 (lambda (m)1027 (and-let* ((mod (cdr m))1028 (mname (##sys#module-name mod))1029 ((not (memq mname +internal-modules+)))1030 ((not (eq? mname (current-module)))))1031 (unless quiet (print "processing " mname " ..."))1032 (let-values (((_ ve se) (##sys#module-exports mod)))1033 (append (map (lambda (se) (list (car se) 'syntax mname)) se)1034 (map (lambda (ve) (list (car ve) 'value mname)) ve)))))1035 ##sys#module-table))1036 (lambda (e1 e2)1037 (string<? (symbol->string (car e1)) (symbol->string (car e2)))))))1038 (with-output-to-file dbfile1039 (lambda ()1040 (for-each (lambda (x) (write x) (newline)) db)))1041 (unless quiet (print "installing " +module-db+ " ..."))1042 (copy-file dbfile (make-pathname (install-path) +module-db+) #t)1043 (delete-file dbfile))))104410451046;; purge cache for given (or all) eggs10471048(define (purge-cache eggs)1049 (cond ((null? eggs)1050 (when (file-exists? cache-directory)1051 (d "purging complete cache at ~a~%" cache-directory)1052 (delete-directory cache-directory #t)))1053 (else1054 (for-each1055 (lambda (egg)1056 (let* ((name (if (pair? egg) (car egg) egg))1057 (cache-dir (make-pathname cache-directory name))1058 (metadata-dir (make-pathname cache-metadata-directory name)))1059 (when (file-exists? cache-dir)1060 (d "purging ~a from cache at ~a~%" name cache-dir)1061 (delete-directory cache-dir #t))1062 (when (file-exists? metadata-dir)1063 (d "purging metadata of ~a from cache at ~a~%" name metadata-dir)1064 (delete-directory metadata-dir #t))))1065 eggs))))106610671068;; command line parsing and selection of operations10691070(define (perform-actions eggs)1071 (load-defaults)1072 (cond (update-module-db (update-db))1073 (purge-mode (purge-cache eggs))1074 (print-repository (print (install-path)))1075 ((null? eggs)1076 (cond (list-versions-only1077 (print "no eggs specified"))1078 (else1079 (let ((files (glob "*.egg" "chicken/*.egg")))1080 (when (null? files) (exit 3))1081 (set! canonical-eggs1082 (map (lambda (fname)1083 (list (pathname-file fname) (current-directory) #f))1084 files))1085 (set! requested-eggs (map car canonical-eggs))1086 (retrieve-eggs '())1087 (unless retrieve-only (install-eggs))))))1088 (else1089 (let ((eggs (apply-mappings eggs)))1090 (cond (list-versions-only (list-egg-versions eggs))1091 (else1092 (set! requested-eggs (map (o car canonical) eggs))1093 (retrieve-eggs eggs)1094 (unless retrieve-only (install-eggs))))))))10951096(define (usage code)1097 (print #<<EOF1098usage: chicken-install [OPTION ...] [NAME[:VERSION] ...]10991100 -h -help show this message and exit1101 -version show version and exit1102 -force don't ask, install even if versions don't match1103 -k -keep keep temporary files1104 -s -sudo use external command to elevate privileges for filesystem operations1105 -l -location DIRECTORY get egg sources from DIRECTORY. May be provided multiple times.1106 Locations specified on the command line have precedence over the1107 ones specified in setup.defaults.1108 -r -retrieve only retrieve egg into cache directory, don't install (giving `-r'1109 more than once implies `-recursive')1110 -recursive if `-retrieve' is given, retrieve also dependencies1111 -dry-run do not build or install, just print the locations of the generated1112 build & install scripts1113 -list-versions list available versions for given eggs (HTTP transport only)1114 -n -no-install do not install, just build1115 -no-install-dependencies do not install dependencies1116 -purge remove cached files for given eggs (or purge cache completely)1117 -host when cross-compiling, compile extension only for host1118 -target when cross-compiling, compile extension only for target1119 -test run included test-cases, if available1120 -u -update-db update export database1121 -repository print path used for egg installation1122 -override FILENAME override versions for installed eggs with information from file1123 -from-list FILENAME install eggs from list obtained by `chicken-status -list'1124 -v -verbose be verbose1125 -cached only install from cache1126 -D -feature NAME define build feature1127 -defaults FILENAME use FILENAME as defaults instead of the installed `setup.defaults'1128 file11291130chicken-install recognizes the SUDO, http_proxy and proxy_auth environment variables, if set.11311132EOF1133);|1134 (exit code))11351136(define (main args)1137 (setup-proxy (get-environment-variable "http_proxy"))1138 (let ((eggs '())1139 (rx (irregex "([^:]+):(.+)")))1140 (let loop ((args args))1141 (if (null? args)1142 (begin1143 (validate-environment)1144 (perform-actions (reverse eggs)))1145 (let ((arg (car args)))1146 (cond ((member arg '("-h" "-help" "--help"))1147 (usage 0))1148 ((equal? arg "-test")1149 (set! run-tests #t)1150 (loop (cdr args)))1151 ((equal? arg "-repository")1152 (set! print-repository #t)1153 (loop (cdr args)))1154 ((equal? arg "-r")1155 (if retrieve-only1156 (set! retrieve-recursive #t)1157 (set! retrieve-only #t))1158 (loop (cdr args)))1159 ((equal? arg "-retrieve")1160 (set! retrieve-only #t)1161 (loop (cdr args)))1162 ((equal? arg "-version")1163 (print (chicken-version))1164 (exit 0))1165 ((member arg '("-D" "-feature"))1166 (register-feature! (cadr args))1167 (loop (cddr args)))1168 ((equal? arg "-recursive")1169 (set! retrieve-recursive #t)1170 (loop (cdr args)))1171 ((equal? arg "-list-versions")1172 (set! list-versions-only #t)1173 (loop (cdr args)))1174 ((equal? arg "-defaults")1175 (set! user-defaults (cadr args))1176 (loop (cddr args)))1177 ((equal? arg "-force")1178 (set! force-install #t)1179 (loop (cdr args)))1180 ((equal? arg "-host")1181 (set! target-extension #f)1182 (loop (cdr args)))1183 ((equal? arg "-target")1184 (set! host-extension #f)1185 (loop (cdr args)))1186 ((member arg '("-u" "-update-db"))1187 (set! update-module-db #t)1188 (loop (cdr args)))1189 ((equal? arg "-no-install-dependencies")1190 (set! no-install-dependencies #t)1191 (loop (cdr args)))1192 ((equal? arg "-dry-run")1193 (set! do-not-build #t)1194 (loop (cdr args)))1195 ((member arg '("-v" "-verbose"))1196 (set! quiet #f)1197 (loop (cdr args)))1198 ((member arg '("-k" "-keep"))1199 (set! keepfiles #t)1200 (loop (cdr args)))1201 ((member arg '("-s" "-sudo"))1202 (set! sudo-install #t)1203 (loop (cdr args)))1204 ((member arg '("-l" "-location"))1205 (when (null? (cdr args))1206 (fprintf (current-error-port) "-l|-location: missing argument.~%")1207 (exit 1))1208 (set! default-locations1209 (append (list (cadr args)) default-locations))1210 (loop (cddr args)))1211 ((member arg '("-n" "-no-install"))1212 (set! no-install #t)1213 (loop (cdr args)))1214 ((equal? arg "-purge")1215 (set! purge-mode #t)1216 (loop (cdr args)))1217 ((equal? arg "-cached")1218 (set! cached-only #t)1219 (loop (cdr args)))1220 ((equal? arg "-from-list")1221 (unless (pair? (cdr args)) (usage 1))1222 (set! eggs1223 (append eggs1224 (map (lambda (p)1225 (if (null? (cdr p))1226 (->string (car p))1227 (cons (->string (car p))1228 (cadr p))))1229 (with-input-from-file (cadr args) read-list))))1230 (loop (cddr args)))1231 ((equal? arg "-override")1232 (unless (pair? (cdr args)) (usage 1))1233 (set! override1234 (call-with-input-file (cadr args) read-list))1235 (loop (cddr args)))12361237 ;;XXX12381239 ((and (positive? (string-length arg))1240 (char=? #\- (string-ref arg 0)))1241 (if (> (string-length arg) 2)1242 (let ((sos (string->list (substring arg 1))))1243 (if (every (cut memq <> +short-options+) sos)1244 (loop (append1245 (map (cut string #\- <>) sos)1246 (cdr args)))1247 (usage 1)))1248 (usage 1)))1249 ((irregex-match rx arg) =>1250 (lambda (m)1251 (set! eggs1252 (alist-cons1253 (irregex-match-substring m 1)1254 (irregex-match-substring m 2)1255 eggs))1256 (loop (cdr args))))1257 (else1258 (set! eggs (cons arg eggs))1259 (loop (cdr args)))))))))12601261(main (command-line-arguments))12621263)