~ chicken-core (master) /chicken-install.scm

   1;;;; chicken-install.scm
   2;
   3; Copyright (c) 2008-2022, The CHICKEN Team
   4; All rights reserved.
   5;
   6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
   7; conditions are met:
   8;
   9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
  10;     disclaimer.
  11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
  12;     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 promote
  14;     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 EXPRESS
  17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
  19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  24; POSSIBILITY OF SUCH DAMAGE.
  25
  26(declare
  27  (uses chicken-ffi-syntax)) ; populate ##sys#chicken-ffi-macro-environment
  28
  29(module main ()
  30
  31(import (scheme))
  32(import (only (scheme base) open-input-bytevector))
  33(import (chicken base))
  34(import (chicken condition))
  35(import (chicken foreign))
  36(import (chicken keyword))
  37(import (chicken file))
  38(import (chicken file posix))
  39(import (chicken fixnum))
  40(import (chicken format))
  41(import (chicken irregex))
  42(import (chicken module))
  43(import (chicken tcp))
  44(import (chicken port))
  45(import (chicken platform))
  46(import (chicken internal))
  47(import (chicken io))
  48(import (chicken sort))
  49(import (chicken time))
  50(import (chicken pathname))
  51(import (chicken process))
  52(import (chicken process-context))
  53(import (chicken process-context posix))
  54(import (chicken pretty-print))
  55(import (chicken string))
  56(import (chicken bytevector))
  57(import (only (scheme base) open-input-string))
  58
  59(define +defaults-version+ 2)
  60(define +module-db+ "modules.db")
  61(define +defaults-file+ "setup.defaults")
  62(define +short-options+ '(#\h #\k #\s #\r #\n #\u #\v))
  63(define +one-hour+ (* 60 60))
  64(define +internal-modules+ '(chicken.internal chicken.internal.syntax))
  65
  66(include "mini-srfi-1.scm")
  67(include "egg-environment.scm")
  68(include "egg-information.scm")
  69(include "egg-compile.scm")
  70(include "egg-download.scm")
  71
  72(define user-defaults #f)
  73(define quiet #t)
  74(define default-servers '())
  75(define default-locations '())
  76(define mappings '())
  77(define aliases '())
  78(define override '())
  79(define hacks '())
  80(define proxy-host #f)
  81(define proxy-port #f)
  82(define proxy-user-pass #f)
  83(define retrieve-only #f)
  84(define retrieve-recursive #f)
  85(define do-not-build #f)
  86(define no-install #f)
  87(define no-install-dependencies #f)
  88(define list-versions-only #f)
  89(define canonical-eggs '())
  90(define requested-eggs '())
  91(define dependencies '())
  92(define checked-eggs '())
  93(define run-tests #f)
  94(define force-install #f)
  95(define host-extension cross-chicken)
  96(define target-extension cross-chicken)
  97(define sudo-install #f)
  98(define sudo-program (or (get-environment-variable "SUDO") "sudo"))
  99(define update-module-db #f)
 100(define purge-mode #f)
 101(define keepfiles #f)
 102(define print-repository #f)
 103(define cached-only #f)
 104
 105(define platform
 106  (if (eq? (software-version) 'mingw) 'windows 'unix))
 107
 108(define current-status
 109  (list ##sys#build-id default-prefix
 110        (get-environment-variable "CSC_OPTIONS")
 111        (get-environment-variable "LD_LIBRARY_PATH")
 112        (get-environment-variable "DYLD_LIBRARY_PATH")
 113        (get-environment-variable "CHICKEN_INCLUDE_PATH")
 114        (get-environment-variable "DYLD_LIBRARY_PATH")))
 115
 116(define (repo-path)
 117  (if (and cross-chicken (not host-extension))
 118      (##sys#split-path (destination-repository 'target))
 119      (repository-path)))
 120
 121(define (install-path)
 122  (if (and cross-chicken (not host-extension))
 123      (destination-repository 'target)
 124      (destination-repository 'host)))
 125
 126(define (build-script-extension mode)
 127  (string-append "build"
 128                 (if (eq? mode 'target) ".target" "")
 129                 ".sh"))
 130
 131(define (install-script-extension mode)
 132  (string-append "install"
 133                 (if (eq? mode 'target) ".target" "")
 134                 ".sh"))
 135
 136
 137;;; validate egg-information tree
 138
 139(define (egg-version? v)
 140  (and (pair? v)
 141       (null? (cdr v))
 142       (let ((v (car v)))
 143         (and (string? v) (positive? (string-length v))))))
 144
 145(define (optname? x)
 146  (and (list? x)
 147       (or (null? x)
 148           (string? (car x))
 149           (symbol? (car x)))))
 150
 151(define (nameprop? x)
 152  (and (list? x) (or (symbol? (car x)) (string? (car x)))))
 153
 154(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)))))
 160
 161;; ENTRY = (NAME TOPLEVEL? NESTED? NAMED? [VALIDATOR])
 162(define egg-info-items
 163  `((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-cache
 180    (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    (installed-c-object #f #t #t)
 195    (generated-source-file #f #t #t)
 196    (program #f #t #t)
 197    (data #f #t #t)
 198    (modules #f #f #f)
 199    (component-options #t #f #f)
 200    (cond-expand * #t #f)
 201    (error * #f #f)
 202    (c-include #f #f #t)
 203    (scheme-include #f #f #t)))
 204
 205(define (validate-egg-info info)
 206  (define (validate info top?)
 207    (for-each
 208      (lambda (item)
 209        (cond ((or (not (pair? item))
 210                   (not (list? item))
 211                   (not (symbol? (car item))))
 212               (error "invalid egg information item" item))
 213              ((assq (car item) egg-info-items) =>
 214               (lambda (a)
 215                 (apply (lambda (name toplevel nested named #!optional validator)
 216                          (cond ((and top?
 217                                      (not (eq? toplevel '*))
 218                                      (not toplevel))
 219                                 (error "egg information item not allowed at toplevel"
 220                                        item))
 221                                ((and (not (eq? toplevel '*))
 222                                      toplevel
 223                                      (not top?))
 224                                 (error "egg information item only allowed at toplevel" item))
 225                                ((and named
 226                                      (or (null? (cdr item))
 227                                          (not (symbol? (cadr item)))))
 228                                 (error "unnamed egg information item" item))
 229                                ((and validator
 230                                      (not (validator (cdr item))))
 231                                 (error "egg information item has invalid structure" item)))
 232                          (when nested
 233                            (cond (named (validate (cddr item) #f))
 234                                  ((eq? name 'cond-expand)
 235                                   (for-each
 236                                     (lambda (clause)
 237                                       (unless (and (list? clause)
 238                                                    (>= (length clause) 1))
 239                                         (error "invalid syntax in `cond-expand' clause" clause))
 240                                       (validate (cdr clause) top?))
 241                                     (cdr item)))
 242                                  (else (validate (cdr item) #f)))))
 243                        a)))
 244              (else (error "unknown egg information item" item))))
 245      info))
 246  (validate info #t)
 247  info)
 248
 249
 250;; utilities
 251
 252;; Simpler replacement for SRFI-13's "string-suffix?"
 253(define (string-suffix? suffix s)
 254  (let ((len-s (string-length s))
 255        (len-suffix (string-length suffix)))
 256     (and (not (< len-s len-suffix))
 257          (string=? suffix
 258   	            (substring s (- len-s len-suffix))))))
 259
 260(define (d flag . args)
 261  (let ((flag (and (not (string? flag)) flag))
 262        (fstr (if (string? flag) flag (car args)))
 263        (args (if (string? flag) args (cdr args))))
 264    (when (or flag (not quiet))
 265      (flush-output)
 266      (let ((port (current-error-port)))
 267        (apply fprintf port fstr args)
 268        (flush-output port) ) )))
 269
 270(define (version>=? v1 v2)
 271  (define (version->list v)
 272    (map (lambda (x) (or (string->number x) x))
 273	 (irregex-split "[-\\._]" (->string v))))
 274  (let loop ((p1 (version->list v1))
 275	     (p2 (version->list v2)))
 276    (cond ((null? p1) (null? p2))
 277	  ((null? p2))
 278	  ((number? (car p1))
 279	   (and (number? (car p2))
 280		(or (> (car p1) (car p2))
 281		    (and (= (car p1) (car p2))
 282			 (loop (cdr p1) (cdr p2))))))
 283	  ((number? (car p2)))
 284	  ((string>? (car p1) (car p2)))
 285	  (else
 286	   (and (string=? (car p1) (car p2))
 287		(loop (cdr p1) (cdr p2)))))))
 288
 289
 290;; load defaults file ("setup.defaults")
 291
 292(define (load-defaults)
 293  (let* ((cfg-dir (system-config-directory))
 294         (user-file (and cfg-dir (make-pathname (list cfg-dir "chicken")
 295                                                +defaults-file+)))
 296         (deff (or user-defaults
 297                   (and user-file (file-exists? user-file))
 298                   (make-pathname host-sharedir +defaults-file+))))
 299      (define (broken x)
 300	(error "invalid entry in defaults file" deff x))
 301      (cond ((not (file-exists? deff)) '())
 302            (else
 303	     (for-each
 304	      (lambda (x)
 305		(unless (and (list? x) (positive? (length x)))
 306		  (broken x))
 307		(case (car x)
 308		  ((version)
 309		   (cond ((not (pair? (cdr x))) (broken x))
 310			 ((not (= (cadr x) +defaults-version+))
 311			  (error
 312			   (sprintf
 313			       "version of installed `~a' does not match chicken-install version (~a)"
 314			     +defaults-file+
 315			     +defaults-version+)
 316			   (cadr x)))
 317			 ;; others are ignored
 318			 ))
 319		  ((server)
 320		   (set! default-servers
 321		     (append default-servers (cdr x))))
 322		  ((map)
 323		   (set! mappings
 324		     (append
 325		      mappings
 326		      (map (lambda (m)
 327			     (let ((p (list-index (cut eq? '-> <>) m)))
 328			       (unless p (broken x))
 329			       (let-values (((from to) (split-at m p)))
 330				 (cons from (cdr to)))))
 331			   (cdr x)))))
 332		  ((alias)
 333		   (set! aliases
 334		     (append
 335		      aliases
 336		      (map (lambda (a)
 337			     (if (and (list? a) (= 2 (length a)) (every string? a))
 338				 (cons (car a) (cadr a))
 339				 (broken x)))
 340			   (cdr x)))))
 341		  ((override)
 342		   (set! override
 343		     (if (and (pair? (cdr x)) (string? (cadr x)))
 344			 (call-with-input-file (cadr x) read-list)
 345			 (cdr x))))
 346                  ((location)
 347                   (set! default-locations
 348                     (append default-locations (cdr x))))
 349		  ((hack)
 350		   (set! hacks (append hacks (list (eval (cadr x))))))
 351		  (else (broken x))))
 352	      (call-with-input-file deff read-list))))))
 353
 354
 355;; set variables with HTTP proxy information
 356
 357(define (setup-proxy uri)
 358  (and-let* (((string? uri))
 359             (m (irregex-match "(http://)?([^:]+):?([0-9]*)" uri))
 360             (port (irregex-match-substring m 3)))
 361    (set! proxy-user-pass (get-environment-variable "proxy_auth"))
 362    (set! proxy-host (irregex-match-substring m 2))
 363    (set! proxy-port (or (string->number port) 80))))
 364
 365
 366;; apply egg->egg mappings loaded from defaults
 367
 368(define (canonical x)
 369  (cond ((symbol? x) (cons (symbol->string x) #f))
 370        ((string? x) (cons x #f))
 371        ((pair? x) x)
 372        (else (error "internal error - bad egg spec" x))))
 373
 374(define (apply-mappings eggs)
 375  (define (same? e1 e2)
 376    (equal? (car (canonical e1)) (car (canonical e2))))
 377  (let ((eggs2
 378         (delete-duplicates
 379           (append-map
 380             (lambda (egg)
 381               (cond ((find (lambda (m) (find (cut same? egg <>) (car m)))
 382                        mappings) =>
 383                      (lambda (m) (map ->string (cdr m))))
 384                 (else (list egg))))
 385             eggs)
 386           same?)))
 387    (unless (and (= (length eggs) (length eggs2))
 388                 (every (lambda (egg)
 389                          (find (cut same? <> egg) eggs2))
 390                        eggs))
 391      (d "mapped ~s to ~s~%" eggs eggs2))
 392    eggs2))
 393
 394
 395;; override versions, if specified in "overrides" file
 396
 397(define (override-version egg)
 398  (let ((name (string->symbol (if (pair? egg) (car egg) egg))))
 399    (cond ((assq name override) =>
 400           (lambda (a)
 401             (if (and (pair? egg)
 402                      (pair? (cdr a))
 403                      (not (equal? (cadr a) (cdr egg))))
 404                 (warning
 405                  (sprintf
 406                   "version `~a' of extension `~a' overrides explicitly given version `~a'"
 407                   (cadr a) name (cdr egg)))
 408                 (d "overriding: ~a~%" a))
 409             (if (null? (cdr a))
 410                 (and (pair? egg) (cdr egg))
 411                 (cadr a))))
 412          ((pair? egg) (cdr egg))
 413          (else #f))))
 414
 415
 416;; "locate" egg: either perform HTTP download or copy from a file-system
 417;; location, also make sure it is up to date
 418
 419(define (locate-egg name version)
 420  (let* ((cached (make-pathname cache-directory name))
 421         (metadata-dir (make-pathname cache-metadata-directory name))
 422         (now (current-seconds))
 423         (status (make-pathname metadata-dir +status-file+))
 424         (eggfile (make-pathname cached name +egg-extension+)))
 425    (define (fetch lax)
 426      (when (file-exists? cached)
 427        (delete-directory cached #t))
 428      (when (file-exists? metadata-dir)
 429        (delete-directory metadata-dir #t))
 430      (create-directory cached #t)
 431      (create-directory metadata-dir #t)
 432      (fetch-egg-sources name version cached lax))
 433    (cond ((and (probe-dir cached)
 434                (not (file-exists? status)))
 435           ;; If for whatever reason the status file doesn't exist
 436           ;; (e.g., it was renamed, as in 2f6a7221), reset the cache
 437           ;; of the egg to prevent the object files in there from
 438           ;; being reused.
 439           (d "resetting ~a, as ~a does not exist~%" cached status)
 440           (fetch #f))
 441	  ((or (not (probe-dir cached))
 442               (not (file-exists? eggfile)))
 443           (d "~a not cached~%" name)
 444           (when cached-only (error "extension not cached" name))
 445           (fetch #f))
 446          ((and (file-exists? status)
 447                (not (equal? current-status
 448                             (with-input-from-file status read))))
 449           (d "status changed for ~a~%" name)
 450           (cond (cached-only
 451                   (if force-install
 452                       (warning "cached egg does not match CHICKEN version" name)
 453                       (error "cached egg does not match CHICKEN version - use `-force' to install anyway" name)))
 454                 (else (fetch #f)))))
 455    (let* ((info (validate-egg-info (load-egg-info eggfile)))
 456           (vfile (make-pathname metadata-dir +version-file+))
 457           (tfile (make-pathname metadata-dir +timestamp-file+))
 458           (lversion (or (get-egg-property info 'version)
 459                         (and (file-exists? vfile)
 460                              (with-input-from-file vfile read)))))
 461      (cond ((and (not cached-only)
 462                  (if (string? version)
 463                      (not (equal? version lversion))
 464                      (or (and (file-exists? tfile)
 465                               (> (- now (with-input-from-file tfile read)) +one-hour+))
 466                          (not (check-remote-version name lversion cached)))))
 467             (d "version of ~a out of date~%" name)
 468             (fetch #t)
 469             (let* ((info (validate-egg-info (load-egg-info eggfile))) ; new egg info (fetched)
 470                    (lversion (or (get-egg-property info 'version)
 471                                  (and (file-exists? vfile)
 472                                       (with-input-from-file vfile read)))))
 473               (values cached lversion)))
 474            (else (values cached version))))))
 475
 476(define (resolve-location name)
 477  (cond ((assoc name aliases) =>
 478         (lambda (a)
 479           (let ((new (cdr a)))
 480             (d "resolving alias `~a' to: ~a~%" name new)
 481             (resolve-location new))))
 482        (else name)))
 483
 484(define (locate-local-egg-dir location egg-name version)
 485  ;; Locate the directory of egg-name, considering the following
 486  ;; directory layouts in order:
 487  ;; * <location>/<egg-name>/<egg-name>.egg
 488  ;; * <location>/<egg-name>/<version>/<egg-name>.egg
 489  ;;
 490  ;; Return (values <egg-dir> <version>).  <egg-dir> and <version>
 491  ;; will be #f in case they cannot be determined.
 492  (let ((egg-dir (probe-dir (make-pathname location egg-name))))
 493    (cond
 494     ((not egg-dir)
 495      (values #f #f))
 496     ;; <location>/<egg-name>/<egg-name>.egg
 497     ((file-exists? (make-pathname egg-dir egg-name +egg-extension+))
 498      (values egg-dir #f))
 499     (else
 500      ;; <location>/<egg-name>/<version>/<egg-name>.egg
 501      (if version
 502          (values (probe-dir (make-pathname egg-dir (->string version)))
 503                  version)
 504          (let ((versions (directory egg-dir)))
 505            (if (null? versions)
 506                (values #f #f)
 507                (let ((latest (car (sort versions version>=?))))
 508                  (values (make-pathname egg-dir (->string latest))
 509                          latest)))))))))
 510
 511(define (write-cache-metadata egg egg-version)
 512  (let ((metadata-dir (make-pathname cache-metadata-directory egg)))
 513    (when egg-version
 514      (with-output-to-file (make-pathname metadata-dir +version-file+)
 515        (cut write egg-version)))
 516    (with-output-to-file (make-pathname metadata-dir +timestamp-file+)
 517      (cut write (current-seconds)))
 518    (with-output-to-file (make-pathname metadata-dir +status-file+)
 519      (cut write current-status))))
 520
 521(define (fetch-egg-sources name version dest lax)
 522  (print "fetching " name)
 523  (let loop ((locs default-locations))
 524    (cond ((null? locs)
 525           (let ((tmpdir (create-temporary-directory)))
 526             (let loop ((srvs (map resolve-location default-servers)))
 527               (if (null? srvs)
 528                   (if lax
 529                       (print "no connection to server or egg not found remotely - will use cached version")
 530                       (begin
 531                         (delete-directory dest)
 532                         (delete-directory tmpdir)
 533                         (error "extension or version not found" name)))
 534                   (begin
 535                     (d "trying server ~a ...~%" (car srvs))
 536                     (receive (dir ver)
 537                       (try-download name (car srvs)
 538                                     version: version
 539                                     destination: tmpdir
 540                                     tests: #t ;; Always fetch tests, otherwise cached eggs can't be tested later
 541                                     proxy-host: proxy-host
 542                                     proxy-port: proxy-port
 543                                     proxy-user-pass: proxy-user-pass)
 544                       (cond (dir
 545                               (copy-egg-sources tmpdir dest)
 546                               (delete-directory tmpdir #t)
 547			       (write-cache-metadata name ver))
 548                             (else (loop (cdr srvs))))))))))
 549          (else
 550           (receive (dir version-from-path)
 551               (locate-local-egg-dir (car locs) name version)
 552             (if dir
 553                 (let* ((eggfile (make-pathname dir name +egg-extension+))
 554                        (info (validate-egg-info (load-egg-info eggfile)))
 555                        (rversion
 556                         ;; If version-from-path is non-#f, prefer it
 557                         ;; over rversion, as it means the egg author
 558                         ;; actually tagged the egg.  rversion might
 559                         ;; be outdated in case the egg author forgot
 560                         ;; to bump it in the .egg file.
 561                         (or version-from-path
 562                             (get-egg-property info 'version))))
 563                   (d "trying location ~a ...~%" dir)
 564                   (if (or (not rversion)
 565                           (not version)
 566                           (version>=? rversion version))
 567                       (begin
 568                         (copy-egg-sources dir dest)
 569                         (write-cache-metadata name (or rversion version)))
 570                       (loop (cdr locs))))
 571                 (loop (cdr locs))))))))
 572
 573
 574(define (copy-egg-sources from to)
 575  (for-each
 576    (lambda (f)
 577      (let ((cmd (string-append
 578                   (copy-directory-command platform)
 579                   " "
 580                   (qs* f)
 581                   " "
 582                   (qs* to))))
 583	(d "~a~%" cmd)
 584        (system+ cmd platform)))
 585    (glob (make-pathname from "*"))))
 586
 587(define (check-remote-version name lversion cached)
 588  (let loop ((locs default-locations))
 589    (cond ((null? locs)
 590           (let loop ((srvs (map resolve-location default-servers)))
 591             (and (pair? srvs)
 592                  (let ((versions (try-list-versions name (car srvs))))
 593                    (or (and versions
 594                             (every (cut version>=? lversion <>) versions))
 595                        (loop (cdr srvs)))))))
 596          ;; The order of probe-dir's here is important.  First try
 597          ;; the path with version, then the path without version.
 598          ((or (probe-dir (make-pathname (list (car locs) name)
 599                                         (->string lversion)))
 600               (probe-dir (make-pathname (car locs) name)))
 601           => (lambda (dir)
 602                ;; for locally available eggs, check set of files and
 603                ;; timestamps
 604                (compare-trees dir cached)))
 605          (else (loop (cdr locs))))))
 606
 607(define (compare-trees there here)
 608  (let walk ((there there)
 609             (here here))
 610    (let ((tfs (directory there))
 611          (hfs (directory here)))
 612      (every (lambda (f)
 613               (and (member f hfs)
 614                    (let ((tf2 (make-pathname there f))
 615                          (hf2 (make-pathname here f)))
 616                      (and (<= (file-modification-time tf2)
 617                               (file-modification-time hf2))
 618                           (if (directory-exists? tf2)
 619                               (and (directory-exists? hf2)
 620                                    (walk tf2 hf2))
 621                               (not (directory-exists? hf2)))))))
 622             tfs))))
 623
 624
 625;; check installed eggs for already installed files
 626
 627(define (matching-installed-files egg fnames)
 628  (let ((eggs (glob (make-pathname (install-path) "*" +egg-info-extension+))))
 629    (let loop ((eggs eggs) (same '()))
 630      (cond ((null? eggs) same)
 631            ((string=? egg (pathname-file (car eggs)))
 632             (loop (cdr eggs) same))
 633            (else
 634              (let* ((info (load-egg-info (car eggs)))
 635                     (files (assq 'installed-files info))
 636                     (mfiles (and files
 637                                  (filter (lambda (fname)
 638                                            (and (not (member fname same))
 639                                                 (member fname files)))
 640                                          fnames))))
 641                (loop (cdr eggs) (append (or mfiles '()) same))))))))
 642
 643(define (check-installed-files name info)
 644  (let ((bad (matching-installed-files name (cdr (assq 'installed-files info)))))
 645    (unless (null? bad)
 646      (flush-output)
 647      (fprintf (current-error-port)
 648               "\nthe extension `~a' will overwrite the following files:\n\n" name)
 649      (for-each
 650        (lambda (fname)
 651          (fprintf (current-error-port) "  ~a~%" fname))
 652        bad)
 653      (exit 1))))
 654
 655
 656;; retrieve eggs, recursively (if needed)
 657
 658(define (retrieve-eggs eggs)
 659  (for-each
 660    (lambda (egg)
 661      (cond ((assoc egg canonical-eggs) =>
 662             (lambda (a)
 663               ;; push to front
 664               (set! canonical-eggs (cons a (delete a canonical-eggs eq?)))))
 665            (else
 666              (let ((name (if (pair? egg) (car egg) egg))
 667                    (version (override-version egg)))
 668                (let-values (((dir ver) (locate-egg name version)))
 669                  (when (or (not dir)
 670                            (null? (directory dir)))
 671                    (when dir (delete-directory dir))
 672                    (error "extension or version not found" name))
 673                  (d retrieve-only "~a located at ~a~%" egg dir)
 674                  (set! canonical-eggs
 675                    (cons (list name dir ver) canonical-eggs)))))))
 676     eggs)
 677  (when (or (not retrieve-only) retrieve-recursive)
 678    (for-each
 679      (lambda (e+d+v)
 680        (unless (member (car e+d+v) checked-eggs)
 681          (d "checking ~a ...~%" (car e+d+v))
 682          (set! checked-eggs (cons (car e+d+v) checked-eggs))
 683          (let* ((fname (make-pathname (cadr e+d+v) (car e+d+v) +egg-extension+))
 684                 (info (validate-egg-info (load-egg-info fname))))
 685            (d "checking platform for `~a'~%" (car e+d+v))
 686            (check-platform (car e+d+v) info)
 687            (d "checking dependencies for `~a'~%" (car e+d+v))
 688            (let-values (((missing upgrade)
 689                          (outdated-dependencies (car e+d+v) info)))
 690              (set! missing (apply-mappings missing))
 691              (set! dependencies
 692                (cons (cons (car e+d+v)
 693                            (map (lambda (mu)
 694                                   (if (pair? mu)
 695                                       (car mu)
 696                                       mu))
 697                              (append missing upgrade)))
 698                      dependencies))
 699              (when (pair? missing)
 700                (d " missing: ~a~%" (string-intersperse missing ", "))
 701                (retrieve-eggs missing))
 702              (when (and (pair? upgrade)
 703                         (or force-install
 704                             (replace-extension-question e+d+v upgrade)))
 705                (let ((ueggs (unzip1 upgrade)))
 706                  (d " upgrade: ~a~%" (string-intersperse ueggs ", "))
 707                  ;; XXX think about this...
 708                  #;(for-each
 709                    (lambda (e)
 710                      (d "removing previously installed extension `~a'" e)
 711                      (remove-extension e) )
 712                    ueggs)
 713                  (retrieve-eggs ueggs) ) ) ) ) ) )
 714      canonical-eggs)))
 715
 716(define (outdated-dependencies egg info)
 717  (let ((ds (get-egg-dependencies info)))
 718    (for-each (lambda (h) (set! ds (h egg ds))) hacks)
 719    (let loop ((deps ds) (missing '()) (upgrade '()))
 720      (if (null? deps)
 721          (values (reverse missing) (reverse upgrade))
 722          (let-values (((m u) (check-dependency (car deps))))
 723            (loop (cdr deps)
 724                  (if m (cons m missing) missing)
 725                  (if u (cons u upgrade) upgrade)))))))
 726
 727(define (get-egg-dependencies info)
 728  (append (get-egg-property* info 'dependencies '())
 729          (get-egg-property* info 'build-dependencies '())
 730          (if run-tests
 731              (get-egg-property* info 'test-dependencies '())
 732              '())))
 733
 734(define (check-dependency dep)
 735  (cond ((or (symbol? dep) (string? dep))
 736         (values (and (not (ext-version dep)) (->string dep))
 737                 #f))
 738        ((and (list? dep) (eq? 'or (car dep)))
 739         (let scan ((ordeps (cdr dep)) (bestm #f) (bestu #f))
 740           (if (null? ordeps)
 741               (values (cond (bestu #f)	; upgrade overrides new
 742                             (bestm bestm)
 743                             (else #f))
 744                       bestu)
 745               (let-values (((m u) (check-dependency (car ordeps))))
 746                 (if (and (not m) (not u))
 747                     (values #f #f)
 748                     (scan (cdr ordeps)
 749                           (if (and m (not bestm))
 750                               m
 751                               bestm)
 752                           (if (and u (not bestu))
 753                               u
 754                               bestu)))))))
 755        ((and (list? dep) (= 2 (length dep))
 756              (or (string? (car dep)) (symbol? (car dep))))
 757         (let ((v (ext-version (car dep))))
 758           (cond ((not v)
 759                  (values (->string (car dep)) #f))
 760                 ((not (version>=? v (->string (cadr dep))))
 761                  (cond ((string=? "chicken" (->string (car dep)))
 762                         (if force-install
 763                             (values #f #f)
 764                             (error
 765                               (string-append
 766                                 "Your CHICKEN version is not recent enough to use this extension - version "
 767                                 (cadr dep)
 768				 " or newer is required"))))
 769                        (else
 770                          (values #f
 771                                  (cons (->string (car dep)) (->string (cadr dep)))))))
 772                 (else (values #f #f)))))
 773        (else
 774          (warning "invalid dependency syntax in extension meta information"
 775                   dep)
 776          (values #f #f))))
 777
 778(define (ext-version x)
 779  (cond ((or (eq? x 'chicken) (equal? x "chicken"))
 780         (chicken-version))
 781        ((let* ((sf (chicken.load#find-file
 782                     (make-pathname #f (->string x) +egg-info-extension+)
 783                     (repo-path))))
 784           (and sf
 785                (file-exists? sf)
 786                (load-egg-info sf))) =>
 787         (lambda (info)
 788           (let ((a (assq 'version info)))
 789             (if a
 790                 (->string (cadr a))
 791                 "0.0.0"))))
 792        (else #f)))
 793
 794(define (check-platform name info)
 795  (unless cross-chicken
 796    (and-let* ((platform (get-egg-property info 'platform)))
 797      (or (let loop ((p platform))
 798	    (cond ((symbol? p)
 799		   (feature? p))
 800		  ((not (list? p))
 801		   (error "invalid `platform' property" name platform))
 802		  ((and (eq? 'not (car p)) (pair? (cdr p)))
 803		   (not (loop (cadr p))))
 804		  ((eq? 'and (car p))
 805		   (every loop (cdr p)))
 806		  ((eq? 'or (car p))
 807		   (any loop (cdr p)))
 808		  (else (error "invalid `platform' property" name platform))))
 809	  (error "extension is not targeted for this system" name)))))
 810
 811(define (replace-extension-question e+d+v upgrade)
 812  (print (string-intersperse
 813           (append
 814             (list "The following installed extensions are outdated, because `"
 815                   (car e+d+v)
 816                   "' requires later versions:\n\n")
 817             (filter-map
 818              (lambda (e)
 819                (cond ((assq (string->symbol (car e)) override) =>
 820                       (lambda (a)
 821                         (when (and (pair? (cdr a))
 822                                    (not (equal? (cadr a) (cdr e))))
 823                           (warning
 824                            (sprintf "version `~a' of extension `~a' overrides required version `~a'"
 825                                     (cadr a) (car a) (cdr e))))
 826                         #f))
 827                      (else
 828                       (conc "  " (car e) " ("
 829                             (or (ext-version (car e)) "unknown") " -> " (cdr e)
 830                             ")" #\newline))))
 831              upgrade))
 832             ""))
 833  (let loop ()
 834    (display "Do you want to replace the existing extensions? (yes/no/abort) ")
 835    (flush-output)
 836    (let ((r (trim (read-line))))
 837      (cond ((string=? r "yes"))
 838            ((string=? r "no") #f)
 839            ((string=? r "abort") (exit 2))
 840            (else (loop))))))
 841
 842(define (trim str)
 843  (define (left lst)
 844    (cond ((null? lst) '())
 845          ((char-whitespace? (car lst)) (left (cdr lst)))
 846          (else (cons (car lst) (left (cdr lst))))))
 847  (list->string (reverse (left (reverse (left (string->list str)))))))
 848
 849
 850;; list available egg versions on servers
 851
 852(define (list-egg-versions eggs)
 853  (let ((srvs (map resolve-location default-servers)))
 854    (let loop1 ((eggs eggs))
 855      (unless (null? eggs)
 856        (let* ((egg (car eggs))
 857               (name (if (pair? egg) (car egg) egg)))
 858          (let loop2 ((srvs srvs))
 859            (and (pair? srvs)
 860                 (let ((versions (try-list-versions name (car srvs))))
 861                   (or (and versions
 862                            (begin
 863                              (printf "~a:" name)
 864                              (for-each (cut printf " ~a" <>) versions)
 865                              (newline)))
 866                       (loop2 (cdr srvs))))))
 867          (loop1 (cdr eggs)))))))
 868
 869
 870;; perform installation of retrieved eggs
 871
 872(define (install-eggs)
 873  (for-each
 874    (lambda (egg)
 875      (let* ((name (car egg))
 876             (dir (cadr egg))
 877             (metadata-dir (make-pathname cache-metadata-directory name))
 878             (eggfile (make-pathname dir name +egg-extension+))
 879             (info (load-egg-info eggfile))
 880             (vfile (make-pathname metadata-dir +version-file+))
 881             (ver (and (file-exists? vfile)
 882                       (with-input-from-file vfile read))))
 883        (when (or host-extension
 884                  (and (not target-extension)
 885                       (not host-extension)))
 886          (let-values (((build install info) (compile-egg-info eggfile
 887                                                               info
 888                                                               ver
 889                                                               platform
 890                                                               'host)))
 891            (let ((bscript (make-pathname dir name
 892                                          (build-script-extension 'host)))
 893                  (iscript (make-pathname dir name
 894                                          (install-script-extension 'host))))
 895              (generate-shell-commands platform build bscript dir
 896                                       (build-prefix 'host name info)
 897                                       (build-suffix 'host name info)
 898                                       keepfiles)
 899              (generate-shell-commands platform install iscript dir
 900                                       (install-prefix 'host name info)
 901                                       (install-suffix 'host name info)
 902                                       keepfiles)
 903              (cond (do-not-build (print bscript "\n" iscript))
 904                    (else
 905                      (print "building " name)
 906                      (run-script dir bscript platform)
 907                      (unless (if (member name requested-eggs) no-install no-install-dependencies)
 908                        (with-lock
 909                          (lambda ()
 910                            (check-installed-files name info)
 911                            (print "installing " name)
 912                            (run-script dir iscript platform sudo: sudo-install))))
 913                      (when (and (member name requested-eggs)
 914                                 run-tests
 915                                 (not (test-egg egg platform)))
 916                        (exit 2)))))))
 917        (when target-extension
 918          (let-values (((build install info) (compile-egg-info eggfile
 919                                                               info
 920                                                               ver
 921                                                               platform
 922                                                               'target)))
 923            (let ((bscript (make-pathname dir name
 924                                          (build-script-extension 'target)))
 925                  (iscript (make-pathname dir name
 926                                          (install-script-extension 'target))))
 927              (generate-shell-commands platform build bscript dir
 928                                       (build-prefix 'target name info)
 929                                       (build-suffix 'target name info)
 930                                       keepfiles)
 931              (generate-shell-commands platform install iscript dir
 932                                       (install-prefix 'target name info)
 933                                       (install-suffix 'target name info)
 934                                       keepfiles)
 935              (cond (do-not-build (print bscript "\n" iscript))
 936                    (else
 937                      (print "building " name " (target)")
 938                      (run-script dir bscript platform)
 939                      (unless (if (member name requested-eggs) no-install no-install-dependencies)
 940                        (print "installing " name " (target)")
 941                        (run-script dir iscript platform)))))))))
 942    (order-installed-eggs)))
 943
 944(define (order-installed-eggs)
 945  (let* ((dag (reverse (sort-dependencies dependencies string=?)))
 946         (ordered (filter-map (cut assoc <> canonical-eggs) dag)))
 947    (unless quiet
 948      (d "install order:~%")
 949      (pp dag))
 950    ordered))
 951
 952(define (test-egg egg platform)
 953  (let* ((name (car egg))
 954         (dir (cadr egg))
 955         (version (caddr egg))
 956         (testdir (make-pathname dir "tests"))
 957         (tscript (make-pathname testdir "run.scm")))
 958    (if (and (directory-exists? testdir)
 959             (file-exists? tscript))
 960        (let ((old (current-directory))
 961              (cmd (string-append (qs* default-csi)
 962				  " -s " (qs* tscript)
 963				  " " (qs* name)
 964				  " " (or version ""))))
 965          (change-directory testdir)
 966	  (d "running: ~a~%" cmd)
 967          (let ((r (system+ cmd platform)))
 968            (flush-output (current-error-port))
 969            (cond ((zero? r)
 970                   (change-directory old)
 971                   #t)
 972                  (else
 973                    (print "test script failed with nonzero exit status")
 974                    #f))))
 975        #t)))
 976
 977(define (run-script dir script platform #!key sudo (stop #t))
 978  (d "running script ~a~%" script)
 979  (exec (if (eq? platform 'windows)
 980            (string-append "sh " script)
 981            (string-append
 982             (if sudo
 983                 (string-append sudo-program " ")
 984                 "")
 985             (let ((dyld (and (eq? (software-version) 'macosx)
 986                              (get-environment-variable "DYLD_LIBRARY_PATH"))))
 987               (if dyld
 988                   (string-append "/usr/bin/env DYLD_LIBRARY_PATH="
 989                                  (qs* dyld)
 990                                  " ")
 991                   ""))
 992             "sh " script))
 993        stop))
 994
 995(define (exec cmd #!optional (stop #t))
 996  (d "executing: ~s~%" cmd)
 997  (let ((r (system+ cmd platform)))
 998    (unless (zero? r)
 999      (if stop
 1000          (error "shell command terminated with nonzero exit code" r cmd)
1001          (print "shell command terminated with nonzero exit code " r ": " cmd)))
1002    r))
1003
1004
1005;;; update module-db
1006
1007(define (update-db)
1008  (let* ((files (glob (make-pathname (install-path) "*.import.so")
1009                      (make-pathname (install-path) "*.import.scm")))
1010         (dbfile (create-temporary-file)))
1011      (print "loading import libraries ...")
1012      (fluid-let ((##sys#warnings-enabled #f))
1013        (for-each
1014         (lambda (path)
1015           (let* ((file (pathname-strip-directory path))
1016		  (import-name (pathname-strip-extension file))
1017		  (module-name (pathname-strip-extension import-name)))
1018	     (handle-exceptions ex
1019		 (print-error-message
1020		  ex (current-error-port)
1021		  (sprintf "Failed to import from `~a'" file))
1022	       (unless quiet (print "loading " file " ..."))
1023	       (eval `(import-syntax ,(string->symbol module-name))))))
1024         files))
1025      (print "generating database ...")
1026      (let ((db
1027             (sort
1028              (concatenate
1029               (filter-map
1030                (lambda (m)
1031                  (and-let* ((mod (cdr m))
1032                             (mname (##sys#module-name mod))
1033                             ((not (memq mname +internal-modules+)))
1034                             ((not (eq? mname (current-module)))))
1035                    (unless quiet (print "processing " mname " ..."))
1036                    (let-values (((_ ve se) (##sys#module-exports mod)))
1037                      (append (map (lambda (se) (list (car se) 'syntax mname)) se)
1038                              (map (lambda (ve) (list (car ve) 'value mname)) ve)))))
1039                ##sys#module-table))
1040              (lambda (e1 e2)
1041                (string<? (symbol->string (car e1)) (symbol->string (car e2)))))))
1042        (with-output-to-file dbfile
1043          (lambda ()
1044            (for-each (lambda (x) (write x) (newline)) db)))
1045        (unless quiet (print "installing " +module-db+ " ..."))
1046        (copy-file dbfile (make-pathname (install-path) +module-db+) #t)
1047        (delete-file dbfile))))
1048
1049
1050;; purge cache for given (or all) eggs
1051
1052(define (purge-cache eggs)
1053  (cond ((null? eggs)
1054         (when (file-exists? cache-directory)
1055           (d "purging complete cache at ~a~%" cache-directory)
1056           (delete-directory cache-directory #t)))
1057        (else
1058          (for-each
1059            (lambda (egg)
1060              (let* ((name (if (pair? egg) (car egg) egg))
1061                     (cache-dir (make-pathname cache-directory name))
1062                     (metadata-dir (make-pathname cache-metadata-directory name)))
1063                (when (file-exists? cache-dir)
1064                  (d "purging ~a from cache at ~a~%" name cache-dir)
1065                  (delete-directory cache-dir #t))
1066                (when (file-exists? metadata-dir)
1067                  (d "purging metadata of ~a from cache at ~a~%" name metadata-dir)
1068                  (delete-directory metadata-dir #t))))
1069            eggs))))
1070
1071
1072;; locking of cache directory
1073
1074(define (with-lock thunk)
1075  (cond ((eq? platform 'windows) (thunk))
1076        (else
1077          (unless (directory-exists? cache-directory)
1078            (create-directory cache-directory #t))
1079          (let ((fd (file-open cache-directory open/read)))
1080            (let loop ((f #t))
1081              (cond ((file-lock fd)
1082                     (handle-exceptions ex
1083                       (begin
1084                         (file-close fd)
1085                         (abort ex))
1086                       (call-with-values thunk
1087                         (lambda results
1088                           (file-close fd)
1089                           (apply values results)))))
1090                    (else
1091                      (when f
1092                        (d "[~A] cache locked - waiting for release ...\n"
1093                           (current-process-id)))
1094                      (sleep 1)
1095                      (loop #f))))))))
1096
1097
1098;; command line parsing and selection of operations
1099
1100(define (perform-actions eggs)
1101  (load-defaults)
1102  (cond (update-module-db (with-lock update-db))
1103        (purge-mode (with-lock (cut purge-cache eggs)))
1104        (print-repository (print (install-path)))
1105        ((null? eggs)
1106         (cond ((or list-versions-only retrieve-only)
1107                 (print "no eggs specified"))
1108               (else
1109                 (let ((files (glob "*.egg" "chicken/*.egg")))
1110                   (when (null? files) (exit 3))
1111                   (set! canonical-eggs
1112                     (map (lambda (fname)
1113                            (list (pathname-file fname) (current-directory) #f))
1114                       files))
1115                   (set! requested-eggs (map car canonical-eggs))
1116                   (with-lock
1117                     (lambda ()
1118                       (retrieve-eggs '())))
1119                   (install-eggs)))))
1120        (else
1121          (let ((eggs (apply-mappings eggs)))
1122            (cond (list-versions-only (list-egg-versions eggs))
1123                  (else
1124                    (set! requested-eggs (map (o car canonical) eggs))
1125                    (with-lock
1126                      (lambda ()
1127                        (retrieve-eggs eggs)))
1128                    (unless retrieve-only (install-eggs))))))))
1129
1130(define (usage code)
1131  (print #<<EOF
1132usage: chicken-install [OPTION ...] [NAME[:VERSION] ...]
1133
1134  -h   -help                    show this message and exit
1135       -version                 show version and exit
1136       -force                   don't ask, install even if versions don't match
1137  -k   -keep                    keep temporary files
1138  -s   -sudo                    use external command to elevate privileges for filesystem operations
1139  -l   -location DIRECTORY      get egg sources from DIRECTORY.  May be provided multiple times.
1140                                Locations specified on the command line have precedence over the
1141                                ones specified in setup.defaults.
1142  -r   -retrieve                only retrieve egg into cache directory, don't install (giving `-r'
1143                                more than once implies `-recursive')
1144       -recursive               if `-retrieve' is given, retrieve also dependencies
1145       -dry-run                 do not build or install, just print the locations of the generated
1146                                build & install scripts
1147       -list-versions           list available versions for given eggs (HTTP transport only)
1148  -n   -no-install              do not install, just build
1149       -no-install-dependencies do not install dependencies
1150       -purge                   remove cached files for given eggs (or purge cache completely)
1151       -host                    when cross-compiling, compile extension only for host
1152       -target                  when cross-compiling, compile extension only for target
1153       -test                    run included test-cases, if available
1154  -u   -update-db               update export database
1155       -repository              print path used for egg installation
1156       -override FILENAME       override versions for installed eggs with information from file
1157       -from-list FILENAME      install eggs from list obtained by `chicken-status -list'
1158  -v   -verbose                 be verbose
1159       -cached                  only install from cache
1160  -D   -feature NAME            define build feature
1161       -defaults FILENAME       use FILENAME as defaults instead of the installed `setup.defaults'
1162                                file
1163
1164chicken-install recognizes the SUDO, http_proxy and proxy_auth environment variables, if set.
1165
1166EOF
1167);|
1168    (exit code))
1169
1170(define (main args)
1171  (setup-proxy (get-environment-variable "http_proxy"))
1172  (let ((eggs '())
1173        (rx (irregex "([^:]+):(.+)")))
1174    (let loop ((args args))
1175      (if (null? args)
1176          (begin
1177            (validate-environment)
1178            (perform-actions (reverse eggs)))
1179          (let ((arg (car args)))
1180            (cond ((member arg '("-h" "-help" "--help"))
1181                   (usage 0))
1182                  ((equal? arg "-test")
1183                   (set! run-tests #t)
1184                   (loop (cdr args)))
1185                  ((equal? arg "-repository")
1186                   (set! print-repository #t)
1187                   (loop (cdr args)))
1188                  ((equal? arg "-r")
1189                   (if retrieve-only
1190                       (set! retrieve-recursive #t)
1191                       (set! retrieve-only #t))
1192                   (loop (cdr args)))
1193                  ((equal? arg "-retrieve")
1194                   (set! retrieve-only #t)
1195                   (loop (cdr args)))
1196                  ((equal? arg "-version")
1197                   (print (chicken-version))
1198                   (exit 0))
1199                  ((member arg '("-D" "-feature"))
1200                   (register-feature! (cadr args))
1201                   (loop (cddr args)))
1202                  ((equal? arg "-recursive")
1203                   (set! retrieve-recursive #t)
1204                   (loop (cdr args)))
1205                  ((equal? arg "-list-versions")
1206                   (set! list-versions-only #t)
1207                   (loop (cdr args)))
1208                  ((equal? arg "-defaults")
1209                   (set! user-defaults (cadr args))
1210                   (loop (cddr args)))
1211                  ((equal? arg "-force")
1212                   (set! force-install #t)
1213                   (loop (cdr args)))
1214                  ((equal? arg "-host")
1215                   (set! target-extension #f)
1216                   (loop (cdr args)))
1217                  ((equal? arg "-target")
1218                   (set! host-extension #f)
1219                   (loop (cdr args)))
1220                  ((member arg '("-u" "-update-db"))
1221                   (set! update-module-db #t)
1222                   (loop (cdr args)))
1223                  ((equal? arg "-no-install-dependencies")
1224                   (set! no-install-dependencies #t)
1225                   (loop (cdr args)))
1226                  ((equal? arg "-dry-run")
1227                   (set! do-not-build #t)
1228                   (loop (cdr args)))
1229                  ((member arg '("-v" "-verbose"))
1230                   (set! quiet #f)
1231                   (loop (cdr args)))
1232                  ((member arg '("-k" "-keep"))
1233                   (set! keepfiles #t)
1234                   (loop (cdr args)))
1235                  ((member arg '("-s" "-sudo"))
1236                   (set! sudo-install #t)
1237                   (loop (cdr args)))
1238                  ((member arg '("-l" "-location"))
1239                   (when (null? (cdr args))
1240                     (fprintf (current-error-port) "-l|-location: missing argument.~%")
1241                     (exit 1))
1242                   (set! default-locations
1243                     (append (list (cadr args)) default-locations))
1244                   (loop (cddr args)))
1245                  ((member arg '("-n" "-no-install"))
1246                   (set! no-install #t)
1247                   (loop (cdr args)))
1248                  ((equal? arg "-purge")
1249                   (set! purge-mode #t)
1250                   (loop (cdr args)))
1251                  ((equal? arg "-cached")
1252                   (set! cached-only #t)
1253                   (loop (cdr args)))
1254                  ((equal? arg "-from-list")
1255                   (unless (pair? (cdr args)) (usage 1))
1256                   (set! eggs
1257                     (append eggs
1258                             (map (lambda (p)
1259                                    (if (null? (cdr p))
1260                                        (->string (car p))
1261                                        (cons (->string (car p))
1262                                              (cadr p))))
1263                                  (with-input-from-file (cadr args) read-list))))
1264                   (loop (cddr args)))
1265                  ((equal? arg "-override")
1266                   (unless (pair? (cdr args)) (usage 1))
1267                   (set! override
1268                     (call-with-input-file (cadr args) read-list))
1269                   (loop (cddr args)))
1270
1271                  ;;XXX
1272
1273                  ((and (positive? (string-length arg))
1274                        (char=? #\- (string-ref arg 0)))
1275                   (if (> (string-length arg) 2)
1276                       (let ((sos (string->list (substring arg 1))))
1277                         (if (every (cut memq <> +short-options+) sos)
1278                             (loop (append
1279                                     (map (cut string #\- <>) sos)
1280                                     (cdr args)))
1281                             (usage 1)))
1282                       (usage 1)))
1283                  ((irregex-match rx arg) =>
1284                   (lambda (m)
1285                     (set! eggs
1286                       (alist-cons
1287                         (irregex-match-substring m 1)
1288                         (irregex-match-substring m 2)
1289                         eggs))
1290                     (loop (cdr args))))
1291                  (else
1292                    (set! eggs (cons arg eggs))
1293                    (loop (cdr args)))))))))
1294
1295(main (command-line-arguments))
1296
1297)