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