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