Changeset 13548 in project


Ignore:
Timestamp:
03/07/09 02:25:03 (11 years ago)
Author:
Kon Lovett
Message:

Added version capture & export. Since the http server doesn't report the actual version for no-specific-version this feature is currently broken for 'chicken-install ... foo'. However 'chicken-install ... foo:#.#' will report version "#.#".

Location:
chicken/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/chicken-install.scm

    r13023 r13548  
    88;
    99;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
    10 ;     disclaimer. 
     10;     disclaimer.
    1111;   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. 
     12;     disclaimer in the documentation and/or other materials provided with the distribution.
    1313;   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. 
     14;     products derived from this software without specific prior written permission.
    1515;
    1616; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
     
    2727(require-library setup-download setup-api)
    2828(require-library srfi-1 posix data-structures utils regex ports extras
    29                 srfi-13 files)
     29                srfi-13 files)
    3030
    3131
    3232(module main ()
    33  
     33
    3434  (import scheme chicken srfi-1 posix data-structures utils regex ports extras
    35           srfi-13 files)
     35          srfi-13 files)
    3636  (import setup-download setup-api)
    37  
     37
    3838  (import foreign)
    3939
     
    6666  (define *program-path*
    6767    (or (and-let* ((p (getenv "CHICKEN_PREFIX")))
    68           (make-pathname p "bin") )
    69         (foreign-value "C_INSTALL_BIN_HOME" c-string) ) )
     68          (make-pathname p "bin") )
     69        (foreign-value "C_INSTALL_BIN_HOME" c-string) ) )
    7070
    7171  (define *keep* #f)
     
    8787
    8888  (define (load-defaults)
    89     (let ((deff (make-pathname (chicken-home) +defaults-file+)))
    90       (cond ((not (file-exists? deff)) '())
    91             (else
    92              (set! *default-sources* (read-file deff))
    93              (pair? *default-sources*)))))
     89    (let ([deff (make-pathname (chicken-home) +defaults-file+)])
     90      (cond [(not (file-exists? deff))
     91             '() ]
     92            [else
     93             (set! *default-sources* (read-file deff))
     94             (pair? *default-sources*) ] ) ) )
     95
     96  (define (known-default-sources)
     97    (if (and *default-location* *default-transport*)
     98        `(((location ,*default-location*)
     99           (transport ,*default-transport*)))
     100        *default-sources* ) )
     101
     102  (define (invalidate-default-source! def)
     103    (set! *default-sources* (delete def *default-sources* eq?)) )
    94104
    95105  (define (deps key meta)
    96106    (or (and-let* ((d (assq key meta)))
    97           (cdr d))
    98         '()))
     107          (cdr d))
     108        '()))
    99109
    100110  (define (init-repository dir)
    101111    (let ((src (repository-path))
    102           (copy (if *windows-shell*
    103                     "copy"
    104                     "cp -r")))
     112          (copy (if *windows-shell*
     113                    "copy"
     114                    "cp -r")))
    105115      (print "copying required files to " dir " ...")
    106116      (for-each
    107117       (lambda (f)
    108         ($system (sprintf "~a ~a ~a" copy (shellpath (make-pathname src f)) (shellpath dir))))
     118        ($system (sprintf "~a ~a ~a" copy (shellpath (make-pathname src f)) (shellpath dir))))
    109119       +default-repository-files+)))
    110  
     120
    111121  (define (ext-version x)
    112122    (cond ((or (eq? x 'chicken)
    113                (equal? x "chicken")
    114                (member (->string x) ##sys#core-library-modules))
    115            (chicken-version) )
    116           ((extension-information x) =>
    117            (lambda (info)
    118              (let ((a (assq 'version info)))
    119                (if a
    120                    (->string (cadr a))
    121                    "1.0.0"))))
    122           (else #f)))
     123               (equal? x "chicken")
     124               (member (->string x) ##sys#core-library-modules))
     125           (chicken-version) )
     126          ((extension-information x) =>
     127           (lambda (info)
     128             (let ((a (assq 'version info)))
     129               (if a
     130                   (->string (cadr a))
     131                   "1.0.0"))))
     132          (else #f)))
    123133
    124134  (define (outdated-dependencies meta)
    125     (let ((ds (append 
    126                (deps 'depends meta)
    127                (deps 'needs meta)
    128                (if *run-tests* (deps 'test-depends meta) '()))))
     135    (let ((ds (append
     136               (deps 'depends meta)
     137               (deps 'needs meta)
     138               (if *run-tests* (deps 'test-depends meta) '()))))
    129139      (let loop ((deps ds) (missing '()) (upgrade '()))
    130         (if (null? deps)
    131             (values (reverse missing) (reverse upgrade))
    132             (let ((dep (car deps))
    133                   (rest (cdr deps)))
    134               (cond ((or (symbol? dep) (string? dep))
    135                      (loop rest
    136                            (if (ext-version dep)
    137                                missing
    138                                (cons (->string dep) missing))
    139                            upgrade))
    140                     ((and (list? dep) (= 2 (length dep))
    141                           (or (string? (car dep)) (symbol? (car dep))))
    142                      (let ((v (ext-version (car dep))))
    143                        (cond ((not v)
    144                               (warning
    145                                "installed extension has unknown version - assuming it is outdated"
    146                                (car dep))
    147                               (loop rest missing
    148                                     (alist-cons
    149                                      (->string (car dep))
    150                                      (->string (cadr dep))
    151                                      upgrade)))
    152                              ((version>=? (->string (cadr dep)) v)
    153                               (loop rest missing
    154                                     (alist-cons
    155                                      (->string (car dep)) (->string (cadr dep))
    156                                      upgrade)))
    157                              (else (loop rest missing upgrade)))))
    158                     (else
    159                      (warning
    160                       "invalid dependency syntax in extension meta information"
    161                       dep)
    162                      (loop rest missing upgrade))))))))
    163 
    164     (define *eggs+dirs* '())
    165     (define *checked* '())
    166     (define *csi* (shellpath (make-pathname *program-path* "csi")))
    167 
    168     (define (try name version)
    169       (let loop ((defs (if (and *default-location* *default-transport*)
    170                            `(((location ,*default-location*)
    171                               (transport ,*default-transport*)))
    172                            *default-sources*)))
    173         (and (pair? defs)
    174              (let* ((def (car defs))
    175                     (loc (cadr (or (assq 'location def)
    176                                    (error "missing location entry" def))))
    177                     (trans (cadr (or (assq 'transport def)
    178                                      (error "missing transport entry" def)))))
    179                (or (condition-case
    180                        (retrieve-extension
    181                         name trans loc
    182                         version: version
    183                         destination: (and *retrieve-only* (current-directory))
    184                         tests: *run-tests*
    185                         username: *username*
    186                         password: *password*)
    187                      ((exn net)
    188                       (print "TCP connect timeout")
    189                       #f)
    190                      ((exn http-fetch)
    191                       (print "HTTP protocol error")
    192                       #f)
    193                      (e () (abort e)))
    194                    (begin
    195                      (set! *default-sources* (delete def *default-sources* eq?))
    196                      (loop (cdr defs))))))))
    197 
    198     (define (retrieve eggs)
    199       (print "retrieving ...")
     140        (if (null? deps)
     141            (values (reverse missing) (reverse upgrade))
     142            (let ((dep (car deps))
     143                  (rest (cdr deps)))
     144              (cond ((or (symbol? dep) (string? dep))
     145                     (loop rest
     146                           (if (ext-version dep)
     147                               missing
     148                               (cons (->string dep) missing))
     149                           upgrade))
     150                    ((and (list? dep) (= 2 (length dep))
     151                          (or (string? (car dep)) (symbol? (car dep))))
     152                     (let ((v (ext-version (car dep))))
     153                       (cond ((not v)
     154                              (warning
     155                               "installed extension has unknown version - assuming it is outdated"
     156                               (car dep))
     157                              (loop rest missing
     158                                    (alist-cons
     159                                     (->string (car dep))
     160                                     (->string (cadr dep))
     161                                     upgrade)))
     162                             ((version>=? (->string (cadr dep)) v)
     163                              (loop rest missing
     164                                    (alist-cons
     165                                     (->string (car dep)) (->string (cadr dep))
     166                                     upgrade)))
     167                             (else (loop rest missing upgrade)))))
     168                    (else
     169                     (warning
     170                      "invalid dependency syntax in extension meta information"
     171                      dep)
     172                     (loop rest missing upgrade))))))))
     173
     174  (define *eggs+dirs+vers* '())
     175  (define *checked* '())
     176  (define *csi* (shellpath (make-pathname *program-path* "csi")))
     177 
     178  (define (try-extension name version trans locn)
     179    (condition-case
     180        (retrieve-extension
     181         name trans locn
     182         version: version
     183         destination: (and *retrieve-only* (current-directory))
     184         tests: *run-tests*
     185         username: *username*
     186         password: *password*)
     187      [(exn net)
     188       (print "TCP connect timeout")
     189       (values #f "") ]
     190      [(exn http-fetch)
     191       (print "HTTP protocol error")
     192       (values #f "") ]
     193      [e ()
     194       (abort e) ] ) )
     195
     196  (define (try-default-sources name version)
     197    (let trying-sources ([defs (known-default-sources)])
     198      (if (null? defs)
     199          (values #f "")
     200          (let* ([def (car defs)]
     201                 [locn (cadr (or (assq 'location def)
     202                                 (error "missing location entry" def)))]
     203                 [trans (cadr (or (assq 'transport def)
     204                                  (error "missing transport entry" def)))])
     205            (let-values ([(dir ver) (try-extension name version trans locn)])
     206              (if dir
     207                  (values dir ver)
     208                  (begin
     209                    (invalidate-default-source! def)
     210                    (trying-sources (cdr defs)) ) ) ) ) ) ) )
     211
     212  (define (make-replace-extension-question e+d+v upgrade)
     213    (string-concatenate
     214     (append
     215      (list "The following installed extensions are outdated, because `"
     216            (car e+d+v)
     217            "' requires later versions:\n")
     218      (map
     219       (lambda (e)
     220         (conc
     221          "  " (car e)
     222          " (" (let ([v (assq 'version (extension-information (car e)))]) (if v (cadr v) "???"))
     223               " -> " (cdr e) ")"
     224          #\newline) )
     225       upgrade)
     226      '("\nDo you want to replace the existing extensions?"))) )
     227
     228  (define (retrieve eggs)
     229    (print "retrieving ...")
     230    (for-each
     231     (lambda (egg)
     232       (cond [(assoc egg *eggs+dirs+vers*) =>
     233              (lambda (a)
     234                ;; push to front
     235                (set! *eggs+dirs+vers* (cons a (delete a *eggs+dirs+vers* eq?))) ) ]
     236             [else
     237              (let ([name (if (pair? egg) (car egg) egg)]
     238                    [version (and (pair? egg) (cdr egg))])
     239                (let-values ([(dir ver) (try-default-sources name version)])
     240                  (unless dir (error "extension or version not found"))
     241                  (print " " name " located at " dir)
     242                  (set! *eggs+dirs+vers* (alist-cons name (list dir ver) *eggs+dirs+vers*)) ) ) ] ) )
     243     eggs)
     244    (unless *retrieve-only*
    200245      (for-each
    201        (lambda (egg)
    202          (cond ((assoc egg *eggs+dirs*) =>
    203                 (lambda (a)
    204                   ;; push to front
    205                   (set! *eggs+dirs* (cons a (delete a *eggs+dirs* eq?))) ) )
    206                (else
    207                 (let* ((name (if (pair? egg) (car egg) egg))
    208                        (version (and (pair? egg) (cdr egg)))
    209                        (dir (try name version)))
    210                   (unless dir
    211                     (error "extension or version not found"))
    212                   (print " " name " located at " dir)
    213                   (set! *eggs+dirs* (alist-cons name dir *eggs+dirs*))))) )
    214        eggs)
    215       (unless *retrieve-only*
    216         (for-each
    217          (lambda (e+d)
    218            (unless (member (car e+d) *checked*)
    219              (set! *checked* (cons (car e+d) *checked*))
    220              (let ((mfile (make-pathname (cdr e+d) (car e+d) "meta")))
    221                (cond ((file-exists? mfile)
    222                       (let ((meta (with-input-from-file mfile read)))
    223                         (print "checking dependencies for `" (car e+d) "' ...")
    224                         (let-values (((missing upgrade) (outdated-dependencies meta)))
    225                           (when (pair? missing)
    226                             (print " missing: " (string-intersperse missing ", "))
    227                             (retrieve missing))
    228                           (when (and (pair? upgrade)
    229                                      (or *force*
    230                                          (yes-or-no?
    231                                           (string-concatenate
    232                                            (append
    233                                             (list "The following installed extensions are outdated, because `"
    234                                                   (car e+d) "' requires later versions:\n")
    235                                             (map (lambda (e)
    236                                                    (sprintf
    237                                                     "  ~a (~a -> ~a)~%"
    238                                                     (car e)
    239                                                     (let ((v (assq 'version (extension-information (car e)))))
    240                                                       (if v (cadr v) "???"))
    241                                                     (cdr e)))
    242                                                  upgrade)
    243                                             '("\nDo you want to replace the existing extensions?")))
    244                                           "no") ) )
    245                             (let ((ueggs (unzip1 upgrade)))
    246                               (print " upgrade: " (string-intersperse ueggs ", "))
    247                               (for-each
    248                                (lambda (e)
    249                                  (print "removing previously installed extension `" e "' ...")
    250                                  (remove-extension e) )
    251                                ueggs)
    252                               (retrieve ueggs))))))
    253                      (else
    254                       (warning
    255                        (string-append
    256                         "extension `" (car e+d) "' has no .meta file "
    257                         "- assuming it has no dependencies")))))))
    258          *eggs+dirs*)))
    259 
    260     (define (install eggs)
    261       (retrieve eggs)
    262       (unless *retrieve-only*
    263         (for-each ; we assume the order reflects the dependency tree...
    264          (lambda (e+d)
    265            (print "installing " (car e+d) " ...")
    266            (print "changing current directory to " (cdr e+d))
    267            (parameterize ((current-directory (cdr e+d)))
    268              (let ((cmd (sprintf
    269                          "~a -bnq -e \"(require-library setup-api)\" -e \"(import setup-api)\" ~a ~a ~a ~a ~a ~a"
    270                          *csi*
    271                          (if (sudo-install) "-e \"(sudo-install #t)\"" "")
    272                          (if *keep* "-e \"(keep-intermediates #t)\"" "")
    273                          (if *no-install* "-e \"(setup-install-flag #f)\"" "")
    274                          (if *host-extension* "-e \"(host-extension #t)\"" "")
    275                          (if *prefix*
    276                              (sprintf "-e \"(installation-prefix \\\"~a\\\")\"" *prefix*)
    277                              "")
    278                          (shellpath (make-pathname (cdr e+d) (car e+d) "setup")))))
    279                (print "  " cmd)
    280                ($system cmd))
    281              (when (and *run-tests*
    282                         (file-exists? "tests")
    283                         (directory? "tests")
    284                         (file-exists? "tests/run.scm") )
    285                (current-directory "tests")
    286                (let ((cmd (sprintf "~a -s run.scm ~a" *csi* (car e+d))))
    287                  (print "  " cmd)
    288                  ($system cmd)))))
    289          *eggs+dirs*)))
     246       (lambda (e+d+v)
     247         (unless (member (car e+d+v) *checked*)
     248           (set! *checked* (cons (car e+d+v) *checked*))
     249           (let ([mfile (make-pathname (cadr e+d+v) (car e+d+v) "meta")])
     250             (cond [(file-exists? mfile)
     251                    (let ([meta (with-input-from-file mfile read)])
     252                      (print "checking dependencies for `" (car e+d+v) "' ...")
     253                      (let-values ([(missing upgrade) (outdated-dependencies meta)])
     254                        (when (pair? missing)
     255                          (print " missing: " (string-intersperse missing ", "))
     256                          (retrieve missing))
     257                        (when (and (pair? upgrade)
     258                                   (or *force*
     259                                       (yes-or-no?
     260                                        (make-replace-extension-question e+d+v upgrade)
     261                                        "no") ) )
     262                          (let ([ueggs (unzip1 upgrade)])
     263                            (print " upgrade: " (string-intersperse ueggs ", "))
     264                            (for-each
     265                             (lambda (e)
     266                               (print "removing previously installed extension `" e "' ...")
     267                               (remove-extension e) )
     268                             ueggs)
     269                            (retrieve ueggs) ) ) ) ) ]
     270                   [else
     271                    (warning
     272                     (string-append
     273                      "extension `" (car e+d+v) "' has no .meta file "
     274                      "- assuming it has no dependencies")) ] ) ) ) )
     275       *eggs+dirs+vers*) ) )
     276
     277  (define (make-install-command e+d+v)
     278    (conc
     279     *csi*
     280     " -bnq -e \"(require-library setup-api)\" -e \"(import setup-api)\""
     281     (sprintf " -e \"(extension-name-and-version '(\\\"~a\\\" \\\"~a\\\"))\"" (car e+d+v) (caddr e+d+v))
     282     (if (sudo-install) " -e \"(sudo-install #t)\"" "")
     283     (if *keep* " -e \"(keep-intermediates #t)\"" "")
     284     (if *no-install* " -e \"(setup-install-flag #f)\"" "")
     285     (if *host-extension* " -e \"(host-extension #t)\"" "")
     286     (if *prefix* (sprintf " -e \"(installation-prefix \\\"~a\\\")\"" *prefix*) "")
     287     #\space (shellpath (make-pathname (cadr e+d+v) (car e+d+v) "setup"))) )
     288
     289  (define (install eggs)
     290    (retrieve eggs)
     291    (unless *retrieve-only*
     292      (for-each ; we assume the order reflects the dependency tree...
     293       (lambda (e+d+v)
     294         (print "installing " (car e+d+v) #\: (caddr e+d+v) " ...")
     295         (print "changing current directory to " (cadr e+d+v))
     296         (parameterize ((current-directory (cadr e+d+v)))
     297           (let ([cmd (make-install-command e+d+v)])
     298             (print "  " cmd)
     299             ($system cmd))
     300           (when (and *run-tests*
     301                      (file-exists? "tests")
     302                      (directory? "tests")
     303                      (file-exists? "tests/run.scm") )
     304             (current-directory "tests")
     305             (let ((cmd (sprintf "~a -s run.scm ~a" *csi* (car e+d+v))))
     306               (print "  " cmd)
     307               ($system cmd)))))
     308       *eggs+dirs+vers*)))
    290309
    291310  (define (cleanup)
    292311    (unless *keep*
    293312      (and-let* ((tmpdir (temporary-directory)))
    294         (remove-directory tmpdir))))
     313        (remove-directory tmpdir))))
    295314
    296315  (define (update-db)
    297316    (let* ((files (glob (make-pathname (repository-path) "*.import.*")))
    298            (tmpdir (create-temporary-directory))
    299            (dbfile (make-pathname tmpdir +module-db+))
    300            (rx (regexp ".*/([^/]+)\\.import\\.(scm|so)")))
     317           (tmpdir (create-temporary-directory))
     318           (dbfile (make-pathname tmpdir +module-db+))
     319           (rx (regexp ".*/([^/]+)\\.import\\.(scm|so)")))
    301320      (fluid-let ((##sys#warnings-enabled #f))
    302         (for-each
    303         (lambda (f)
    304            (let ((m (string-match rx f)))
    305              (eval `(import ,(string->symbol (cadr m))))))
    306         files))
     321        (for-each
     322        (lambda (f)
     323           (let ((m (string-match rx f)))
     324             (eval `(import ,(string->symbol (cadr m))))))
     325        files))
    307326      (print "generating database")
    308327      (let ((db
    309              (sort
    310               (append-map
    311                (lambda (m)
    312                 (let* ((mod (cdr m))
    313                         (mname (##sys#module-name mod)))
    314                    (print* " " mname)
    315                    (let-values (((_ ve se) (##sys#module-exports mod)))
    316                      (append
    317                       (map (lambda (se) (list (car se) 'syntax mname)) se)
    318                       (map (lambda (ve) (list (car ve) 'value mname)) ve)))))
    319                ##sys#module-table)
    320               (lambda (e1 e2)
    321                 (string<? (symbol->string (car e1)) (symbol->string (car e2)))))))
    322         (newline)
    323         (with-output-to-file dbfile
    324           (lambda ()
    325             (for-each (lambda (x) (write x) (newline)) db)))
    326         (copy-file dbfile (make-pathname (repository-path) +module-db+))
    327         (remove-directory tmpdir))))
     328             (sort
     329              (append-map
     330               (lambda (m)
     331                (let* ((mod (cdr m))
     332                        (mname (##sys#module-name mod)))
     333                   (print* " " mname)
     334                   (let-values (((_ ve se) (##sys#module-exports mod)))
     335                     (append
     336                      (map (lambda (se) (list (car se) 'syntax mname)) se)
     337                      (map (lambda (ve) (list (car ve) 'value mname)) ve)))))
     338               ##sys#module-table)
     339              (lambda (e1 e2)
     340                (string<? (symbol->string (car e1)) (symbol->string (car e2)))))))
     341        (newline)
     342        (with-output-to-file dbfile
     343          (lambda ()
     344            (for-each (lambda (x) (write x) (newline)) db)))
     345        (copy-file dbfile (make-pathname (repository-path) +module-db+))
     346        (remove-directory tmpdir))))
    328347
    329348  (define ($system str)
    330349    (let ((r (system
    331               (if *windows-shell*
    332                   (string-append "\"" str "\"")
    333                   str))))
     350              (if *windows-shell*
     351                  (string-append "\"" str "\"")
     352                  str))))
    334353      (unless (zero? r)
    335         (error "shell command terminated with nonzero exit code" r str))))
     354        (error "shell command terminated with nonzero exit code" r str))))
    336355
    337356  (define (usage code)
     
    363382  (define (main args)
    364383    (let ((defaults (load-defaults))
    365           (update #f)
    366           (rx "([^:]+):(.+)"))
     384          (update #f)
     385          (rx "([^:]+):(.+)"))
    367386      (let loop ((args args) (eggs '()))
    368         (cond ((null? args)
    369                (cond (update (update-db))
    370                      (else
    371                       (when (null? eggs)
    372                         (let ((setups (glob "*.setup")))
    373                           (cond ((pair? setups)
    374                                  (set! *eggs+dirs*
    375                                    (append
    376                                     (map (lambda (s) (cons (pathname-file s) ".")) setups)
    377                                     *eggs+dirs*)))
    378                                 (else
    379                                  (print "no setup-scripts to process")
    380                                  (exit 1))) ) )
    381                       (unless defaults
    382                         (unless *default-transport*
    383                           (error "no default transport defined - please use `-transport' option"))
    384                         (unless *default-location*
    385                           (error "no default location defined - please use `-location' option")))
    386                       (install (reverse eggs)))))
    387               (else
    388                (let ((arg (car args)))
    389                  (cond ((or (string=? arg "-help")
    390                             (string=? arg "-h")
    391                             (string=? arg "--help"))
    392                         (usage 0))
    393                        ((string=? arg "-force")
    394                         (set! *force* #t)
    395                         (loop (cdr args) eggs))
    396                        ((or (string=? arg "-k") (string=? arg "-keep"))
    397                         (set! *keep* #t)
    398                         (loop (cdr args) eggs))
    399                        ((or (string=? arg "-s") (string=? arg "-sudo"))
    400                         (sudo-install #t)
    401                         (loop (cdr args) eggs))
    402                        ((or (string=? arg "-r") (string=? arg "-retrieve"))
    403                         (set! *retrieve-only* #t)
    404                         (loop (cdr args) eggs))
    405                        ((or (string=? arg "-l") (string=? arg "-location"))
    406                         (unless (pair? (cdr args)) (usage 1))
    407                         (set! *default-location* (cadr args))
    408                         (loop (cddr args) eggs))
    409                        ((or (string=? arg "-t") (string=? arg "-transport"))
    410                         (unless (pair? (cdr args)) (usage 1))
    411                         (set! *default-transport* (string->symbol (cadr args)))
    412                         (loop (cddr args) eggs))
    413                        ((or (string=? arg "-p") (string=? arg "-prefix"))
    414                         (unless (pair? (cdr args)) (usage 1))
    415                         (set! *prefix* (cadr args))
    416                         (loop (cddr args) eggs))
    417                        ((or (string=? arg "-n") (string=? arg "-no-install"))
    418                         (set! *keep* #t)
    419                         (set! *no-install* #t)
    420                         (loop (cdr args) eggs))
    421                        ((or (string=? arg "-v") (string=? arg "-version"))
    422                         (print (chicken-version))
    423                         (exit 0))
    424                        ((or (string=? arg "-u") (string=? arg "-update-db"))
    425                         (set! update #t)
    426                         (loop (cdr args) eggs))
    427                        ((or (string=? arg "-i") (string=? arg "-init"))
    428                         (unless (pair? (cdr args)) (usage 1))
    429                         (init-repository (cadr args))
    430                         (exit 0))
    431                        ((string=? "-test" arg)
    432                         (set! *run-tests* #t)
    433                         (loop (cdr args) eggs))
    434                        ((string=? "-host-extension" arg)
    435                         (set! *host-extension* #t)
    436                         (loop (cdr args) eggs))
    437                        ((string=? "-username" arg)
    438                         (unless (pair? (cdr args)) (usage 1))
    439                         (set! *username* (cadr args))
    440                         (loop (cddr args) eggs))
    441                        ((string=? "-password" arg)
    442                         (unless (pair? (cdr args)) (usage 1))
    443                         (set! *password* (cadr args))
    444                         (loop (cddr args) eggs))
    445                        ((and (positive? (string-length arg))
    446                              (char=? #\- (string-ref arg 0)))
    447                         (if (> (string-length arg) 2)
    448                             (let ((sos (string->list (substring arg 1))))
    449                               (if (null? (lset-intersection eq? *short-options* sos))
    450                                   (loop (append (map (cut string #\- <>) sos) (cdr args)) eggs)
    451                                   (usage 1)))
    452                             (usage 1)))
    453                        ((equal? "setup" (pathname-extension arg))
    454                         (let ((egg (pathname-file arg)))
    455                           (set! *eggs+dirs*
    456                             (alist-cons
    457                              egg
    458                              (let ((dir (pathname-directory arg)))
    459                                (if dir
    460                                    (if (absolute-pathname? dir)
    461                                        dir
    462                                        (make-pathname (current-directory) dir) )
    463                                    (current-directory)))
    464                              *eggs+dirs*))
    465                           (loop (cdr args) (cons egg eggs))))
    466                        ((string-match rx arg) =>
    467                         (lambda (m)
    468                           (loop (cdr args) (alist-cons (cadr m) (caddr m) eggs))))
    469                        (else (loop (cdr args) (cons arg eggs))))))))))
     387        (cond ((null? args)
     388               (cond (update (update-db))
     389                     (else
     390                      (when (null? eggs)
     391                        (let ((setups (glob "*.setup")))
     392                          (cond ((pair? setups)
     393                                 (set! *eggs+dirs+vers*
     394                                       (append
     395                                        (map
     396                                         (lambda (s) (cons (pathname-file s) (list "." "")))
     397                                         setups)
     398                                        *eggs+dirs+vers*)))
     399                                (else
     400                                 (print "no setup-scripts to process")
     401                                 (exit 1))) ) )
     402                      (unless defaults
     403                        (unless *default-transport*
     404                          (error "no default transport defined - please use `-transport' option"))
     405                        (unless *default-location*
     406                          (error "no default location defined - please use `-location' option")))
     407                      (install (reverse eggs)))))
     408              (else
     409               (let ((arg (car args)))
     410                 (cond ((or (string=? arg "-help")
     411                            (string=? arg "-h")
     412                            (string=? arg "--help"))
     413                        (usage 0))
     414                       ((string=? arg "-force")
     415                        (set! *force* #t)
     416                        (loop (cdr args) eggs))
     417                       ((or (string=? arg "-k") (string=? arg "-keep"))
     418                        (set! *keep* #t)
     419                        (loop (cdr args) eggs))
     420                       ((or (string=? arg "-s") (string=? arg "-sudo"))
     421                        (sudo-install #t)
     422                        (loop (cdr args) eggs))
     423                       ((or (string=? arg "-r") (string=? arg "-retrieve"))
     424                        (set! *retrieve-only* #t)
     425                        (loop (cdr args) eggs))
     426                       ((or (string=? arg "-l") (string=? arg "-location"))
     427                        (unless (pair? (cdr args)) (usage 1))
     428                        (set! *default-location* (cadr args))
     429                        (loop (cddr args) eggs))
     430                       ((or (string=? arg "-t") (string=? arg "-transport"))
     431                        (unless (pair? (cdr args)) (usage 1))
     432                        (set! *default-transport* (string->symbol (cadr args)))
     433                        (loop (cddr args) eggs))
     434                       ((or (string=? arg "-p") (string=? arg "-prefix"))
     435                        (unless (pair? (cdr args)) (usage 1))
     436                        (set! *prefix* (cadr args))
     437                        (loop (cddr args) eggs))
     438                       ((or (string=? arg "-n") (string=? arg "-no-install"))
     439                        (set! *keep* #t)
     440                        (set! *no-install* #t)
     441                        (loop (cdr args) eggs))
     442                       ((or (string=? arg "-v") (string=? arg "-version"))
     443                        (print (chicken-version))
     444                        (exit 0))
     445                       ((or (string=? arg "-u") (string=? arg "-update-db"))
     446                        (set! update #t)
     447                        (loop (cdr args) eggs))
     448                       ((or (string=? arg "-i") (string=? arg "-init"))
     449                        (unless (pair? (cdr args)) (usage 1))
     450                        (init-repository (cadr args))
     451                        (exit 0))
     452                       ((string=? "-test" arg)
     453                        (set! *run-tests* #t)
     454                        (loop (cdr args) eggs))
     455                       ((string=? "-host-extension" arg)
     456                        (set! *host-extension* #t)
     457                        (loop (cdr args) eggs))
     458                       ((string=? "-username" arg)
     459                        (unless (pair? (cdr args)) (usage 1))
     460                        (set! *username* (cadr args))
     461                        (loop (cddr args) eggs))
     462                       ((string=? "-password" arg)
     463                        (unless (pair? (cdr args)) (usage 1))
     464                        (set! *password* (cadr args))
     465                        (loop (cddr args) eggs))
     466                       ((and (positive? (string-length arg))
     467                             (char=? #\- (string-ref arg 0)))
     468                        (if (> (string-length arg) 2)
     469                            (let ((sos (string->list (substring arg 1))))
     470                              (if (null? (lset-intersection eq? *short-options* sos))
     471                                  (loop (append (map (cut string #\- <>) sos) (cdr args)) eggs)
     472                                  (usage 1)))
     473                            (usage 1)))
     474                       ((equal? "setup" (pathname-extension arg))
     475                        (let ((egg (pathname-file arg)))
     476                          (set! *eggs+dirs+vers*
     477                            (alist-cons
     478                             egg
     479                             (list
     480                              (let ((dir (pathname-directory arg)))
     481                                (if dir
     482                                    (if (absolute-pathname? dir)
     483                                        dir
     484                                        (make-pathname (current-directory) dir) )
     485                                    (current-directory)))
     486                              "")
     487                             *eggs+dirs+vers*))
     488                          (loop (cdr args) (cons egg eggs))))
     489                       ((string-match rx arg) =>
     490                        (lambda (m)
     491                          (loop (cdr args) (alist-cons (cadr m) (caddr m) eggs))))
     492                       (else (loop (cdr args) (cons arg eggs))))))))))
    470493
    471494  (register-feature! 'chicken-install)
     
    474497  (handle-exceptions ex
    475498      (begin
    476         (print-error-message ex (current-error-port))
    477         (cleanup)
    478         (exit 1))
     499        (print-error-message ex (current-error-port))
     500        (cleanup)
     501        (exit 1))
    479502    (main (command-line-arguments))
    480503    (cleanup))
    481  
    482 )
     504
     505) ;module main
  • chicken/trunk/setup-api.scm

    r13452 r13548  
    5050     sudo-install keep-intermediates
    5151     version>=?
     52     extension-name-and-version
     53     extension-name
     54     extension-version
    5255     create-temporary-directory
    5356     remove-directory
     
    116119(define setup-verbose-flag        (make-parameter #f))
    117120(define setup-install-flag        (make-parameter #t))
    118 (define program-path (make-parameter *chicken-bin-path*))
     121(define program-path              (make-parameter *chicken-bin-path*))
    119122(define keep-intermediates (make-parameter #f))
    120123
     
    192195          ($system (sprintf "mkdir -p ~a" (shellpath dir) ) ) ) ) ) )
    193196
    194 (define abort-setup
    195   (make-parameter exit))
     197(define abort-setup (make-parameter exit))
    196198
    197199(define (yes-or-no? str #!key default (abort (abort-setup)))
     
    682684          (else #f))))
    683685
     686(define extension-name-and-version (make-parameter '("" "")))
     687
     688(define (extension-name)
     689  (car (extension-name-and-version)) )
     690
     691(define (extension-version #!optional defver)
     692  (let ([ver (cadr (extension-name-and-version))])
     693    (if (string-null? ver)
     694        defver
     695        ver ) ) )
     696
    684697(define (read-info egg)
    685698  (with-input-from-file
  • chicken/trunk/setup-download.scm

    r13389 r13548  
    88;
    99;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
    10 ;     disclaimer. 
     10;     disclaimer.
    1111;   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. 
     12;     disclaimer in the documentation and/or other materials provided with the distribution.
    1313;   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. 
     14;     products derived from this software without specific prior written permission.
    1515;
    1616; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
     
    3737
    3838  (import scheme chicken)
    39   (import extras regex posix utils srfi-1 data-structures tcp
    40           srfi-13 files setup-api)
     39  (import extras regex posix utils srfi-1 data-structures tcp srfi-13 files setup-api)
    4140
    4241  (tcp-connect-timeout 10000)           ; 10 seconds
     
    4645  (define *quiet* #f)
    4746
     47  (define *chicken-install-user-agent* (conc "chicken-install " (chicken-version)))
     48
    4849  (define (d fstr . args)
    49     (let ((port (if *quiet* (current-error-port) (current-output-port))))
     50    (let ([port (if *quiet* (current-error-port) (current-output-port))])
    5051      (apply fprintf port fstr args)
    51       (flush-output port)))
    52      
     52      (flush-output port) ) )
     53
    5354  (define temporary-directory (make-parameter #f))
    5455
    5556  (define (get-temporary-directory)
    5657    (or (temporary-directory)
    57         (let ((dir (create-temporary-directory)))
     58        (let ([dir (create-temporary-directory)])
    5859          (temporary-directory dir)
    59           dir)))
     60          dir ) ) )
     61
     62  (define (existing-version egg version vs)
     63    (if version
     64        (if (member version vs)
     65            version
     66            (error "version not found" egg version) )
     67        (let ([vs (sort vs version>=?)])
     68          (and (pair? vs)
     69               (car vs) ) ) ) )
     70
     71  (define (when-no-such-version-warning egg version)
     72    (when version (warning "extension has no such version - using default" egg version)) )
    6073
    6174  (define (list-eggs/local dir)
    62     (string-concatenate
    63      (map (cut string-append <> "\n")
    64           (directory dir))))
     75    (string-concatenate (map (cut string-append <> "\n") (directory dir))) )
    6576
    6677  (define (locate-egg/local egg dir #!optional version destination)
    67     (let* ((eggdir (make-pathname dir egg))
    68            (files (directory eggdir))
    69            (trunkdir (make-pathname eggdir "trunk"))
    70            (tagdir (make-pathname eggdir "tags"))
    71            (hastrunk (and (file-exists? trunkdir) (directory? trunkdir))))
    72       (or (and (file-exists? tagdir) (directory? tagdir)
    73                (let ((vs (directory tagdir)))
    74                  (if version
    75                      (if (member version vs)
    76                          (make-pathname tagdir version)
    77                          (error "version not found" egg version))
    78                      (let ((vs (sort vs version>=?)))
    79                        (and (pair? vs)
    80                             (make-pathname tagdir (car vs)))))))
    81           (begin
    82             (when version
    83               (warning "extension has no such version - using trunk" egg version))
    84             (or (and hastrunk trunkdir)
    85                 eggdir)))))
     78    (let* ([eggdir (make-pathname dir egg)]
     79           [tagdir (make-pathname eggdir "tags")]
     80           [tagver (and (file-exists? tagdir) (directory? tagdir)
     81                        (existing-version egg version (directory tagdir)) ) ] )
     82      (if tagver
     83          (values (make-pathname tagdir tagver) tagver)
     84          (let ([trunkdir (make-pathname eggdir "trunk")])
     85            (when-no-such-version-warning egg version)
     86            (if (and (file-exists? trunkdir) (directory? trunkdir))
     87                (values trunkdir "trunk")
     88                (values eggdir "") ) ) ) ) )
     89
     90  (define (make-svn-ls-cmd uarg parg pnam #!key recursive?)
     91    (conc "svn ls " uarg #\space parg (if recursive? " -R " "") (qs pnam)) )
     92
     93  (define (make-svn-export-cmd uarg parg dir tmpdir)
     94    (conc "svn export " uarg #\space parg #\space #\" dir #\" #\space #\" tmpdir #\"
     95          (if *quiet* " 1>&2" "")) )
    8696
    8797  (define (list-eggs/svn repo #!optional username password)
    88     (call/cc
    89      (lambda (k)
    90        (define (runcmd cmd)
    91          (unless (zero? (system cmd))
    92            (k #f)))
    93        (let* ((uarg (if username (string-append "--username='" username "'") ""))
    94               (parg (if password (string-append "--password='" password "'") ""))
    95               (cmd (sprintf "svn ls ~a ~a ~a" uarg parg (qs repo))))
    96          (d "listing extension directory ...~%  ~a~%" cmd)
    97          (string-concatenate
    98           (map (lambda (str) (string-append (string-chomp str "/") "\n"))
    99                (with-input-from-pipe cmd read-lines)))))))
    100  
    101   (define (locate-egg/svn egg repo #!optional version destination username
    102                           password)
    103     (call/cc
    104      (lambda (k)
    105        (define (runcmd cmd)
    106          (unless (zero? (system cmd))
    107            (k #f)))
    108        (let* ((uarg (if username (string-append "--username='" username "'") ""))
    109               (parg (if password (string-append "--password='" password "'") ""))
    110               (cmd (sprintf "svn ls ~a ~a -R ~a" uarg parg (qs (make-pathname repo egg)))))
    111          (d "checking available versions ...~%  ~a~%" cmd)
    112          (let* ((files (with-input-from-pipe cmd read-lines))
    113                 (hastrunk (member "trunk/" files))
    114                 (filedir
    115                  (or (let ((vs (filter-map
    116                                 (lambda (f)
    117                                   (and-let* ((m (string-search "^tags/([^/]+)/" f)))
    118                                     (cadr m)))
    119                                 files)))
    120                        (if version
    121                            (if (member version vs)
    122                                (string-append "tags/" version)
    123                                (error "version not found" egg version))
    124                            (let ((vs (sort vs version>=?)))
    125                              (and (pair? vs)
    126                                   (string-append "tags/" (car vs))))))
    127                      (begin
    128                        (when version
    129                          (warning "extension has no such version - using trunk" egg version))
    130                        (and hastrunk "trunk") )
    131                      ""))
    132                 (tmpdir (make-pathname (or destination (get-temporary-directory)) egg))
    133                 (cmd (sprintf "svn export ~a ~a \"~a/~a/~a\" \"~a\" ~a"
    134                               uarg parg repo egg filedir
    135                               tmpdir
    136                               (if *quiet* "1>&2" ""))))
    137            (d "  ~a~%" cmd)
    138            (runcmd cmd)
    139            tmpdir)) )))
     98    (let ([uarg (if username (string-append "--username='" username "'") "")]
     99          [parg (if password (string-append "--password='" password "'") "")])
     100      (let ([cmd (make-svn-ls-cmd uarg parg repo)])
     101        (d "listing extension directory ...~%  ~a~%" cmd)
     102        (string-concatenate
     103         (map (lambda (s) (string-append (string-chomp s "/") "\n"))
     104              (with-input-from-pipe cmd read-lines))) ) ) )
     105
     106  (define (locate-egg/svn egg repo #!optional version destination username  password)
     107    (let* ([uarg (if username (string-append "--username='" username "'") "")]
     108           [parg (if password (string-append "--password='" password "'") "")]
     109           [cmd (make-svn-ls-cmd uarg parg (make-pathname repo egg) recursive?: #t)])
     110      (d "checking available versions ...~%  ~a~%" cmd)
     111      (let* ([files (with-input-from-pipe cmd read-lines)]
     112             [tagver (existing-version
     113                      egg version
     114                      (filter-map
     115                       (lambda (f) (and-let* ((m (string-search "^tags/([^/]+)/" f))) (cadr m)))
     116                       files))])
     117        (let-values ([(filedir ver)
     118                      (if tagver
     119                          (values (string-append "tags/" tagver) tagver)
     120                          (begin
     121                            (when-no-such-version-warning egg version)
     122                            (if (member "trunk/" files)
     123                                (values "trunk" "trunk")
     124                                (values "" "") ) ) ) ] )
     125          (let* ([tmpdir (make-pathname (or destination (get-temporary-directory)) egg)]
     126                 [cmd (make-svn-export-cmd uarg parg (conc repo #\/ egg #\/ filedir) tmpdir)])
     127            (d "  ~a~%" cmd)
     128            (if (zero? (system cmd))
     129                (values tmpdir ver)
     130                (values #f "") ) ) ) ) ) )
    140131
    141132  (define (deconstruct-url url)
    142     (let ((m (string-match "(http://)?([^/:]+)(:([^:/]+))?(/.+)" url)))
     133    (let ([m (string-match "(http://)?([^/:]+)(:([^:/]+))?(/.+)" url)])
    143134      (values
    144135       (if m (caddr m) url)
    145        (if (and m (cadddr m)) 
    146            (or (string->number (list-ref m 4)) 
     136       (if (and m (cadddr m))
     137           (or (string->number (list-ref m 4))
    147138               (error "not a valid port" (list-ref m 4)))
    148139           80)
    149        (if m (list-ref m 5) "/"))))
     140       (if m (list-ref m 5) "/")) ) )
    150141
    151142  (define (locate-egg/http egg url #!optional version destination tests)
    152     (let ((tmpdir (or destination (get-temporary-directory))))
    153       (let-values (((host port loc) (deconstruct-url url)))
    154         (let ((loc (string-append
    155                     loc
    156                     "?name=" egg
    157                     (if version
    158                         (string-append "&version=" version)
    159                         "")
    160                     (if tests
    161                         "&tests=yes"
    162                         "")))
    163               (eggdir (make-pathname tmpdir egg)))
    164           (unless (file-exists? eggdir)
    165             (create-directory eggdir))
    166           (http-fetch host port loc eggdir)
    167           eggdir))))
     143    (let ([tmpdir (or destination (get-temporary-directory))])
     144      (let-values ([(host port locn) (deconstruct-url url)])
     145        (let ([locn (string-append
     146                     locn
     147                     "?name=" egg
     148                     (if version (string-append "&version=" version) "")
     149                     (if tests "&tests=yes" ""))]
     150              [eggdir (make-pathname tmpdir egg) ] )
     151          (unless (file-exists? eggdir) (create-directory eggdir))
     152          (http-fetch host port locn eggdir)
     153          ; If we get here then version of egg exists
     154          (values eggdir (or version "")) ) ) ) )
    168155
    169156  (define (network-failure msg . args)
     
    171158     (make-composite-condition
    172159      (make-property-condition
    173        'exn 'message "invalid response from server"
     160       'exn
     161       'message "invalid response from server"
    174162       'arguments args)
    175       (make-property-condition 'http-fetch))))
    176 
    177   (define (http-fetch host port loc dest)
     163      (make-property-condition 'http-fetch))) )
     164
     165  (define (make-HTTP-GET/1.1 location user-agent host
     166                             #!key
     167                             (port 80)
     168                             (connection "close")
     169                             (accept "*")
     170                             (content-length 0))
     171    (conc
     172     "GET " location " HTTP/1.1" "\r\n"
     173     "Connection: " connection "\r\n"
     174     "User-Agent: " user-agent "\r\n"
     175     "Accept: " accept "\r\n"
     176     "Host: " host #\: port "\r\n"
     177     "Content-length: " content-length "\r\n"
     178     "\r\n") )
     179
     180  (define (match-http-response rsp)
     181    (and (string? rsp)
     182         (string-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" rsp)) )
     183
     184  (define (response-match-code? mrsp code)
     185    (and mrsp (string=? (number->string code) (cadr mrsp))) )
     186
     187  (define (match-chunked-transfer-encoding ln)
     188    (string-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )
     189
     190  (define (http-fetch host port locn dest)
    178191    (d "connecting to host ~s, port ~a ...~%" host port)
    179     (let-values (((in out) (tcp-connect host port)))
    180       (d "requesting ~s ...~%" loc)
    181       (fprintf out "GET ~a HTTP/1.1\r\nConnection: close\r\nUser-Agent: chicken-install ~a\r\nAccept: */*\r\nHost: ~a:~a\r\nContent-length: 0\r\n\r\n"
    182                loc (chicken-version) host port)
     192    (let-values ([(in out) (tcp-connect host port)])
     193      (d "requesting ~s ...~%" locn)
     194      (display
     195       (make-HTTP-GET/1.1 locn *chicken-install-user-agent* host port: port accept: "*/*")
     196       out)
    183197      (close-output-port out)
    184       (let ((chunked #f))
    185         (let* ((h1 (read-line in))
    186                (m (and (string? h1)
    187                        (string-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" h1))))
    188           (print h1)
     198      (d "reading response ...~%")
     199      (let ([chunked #f])
     200        (let* ([h1 (read-line in)]
     201               [response-match (match-http-response h1)])
     202          (d "~a~%" h1)
    189203          ;;*** handle redirects here
    190           (unless (and m (string=? "200" (cadr m)))
    191             (network-failure "invalid response from server" h1))
     204          (unless (response-match-code? response-match 200)
     205            (network-failure "invalid response from server" h1) )
    192206          (let loop ()
    193             (let ((ln (read-line in)))
    194               (unless (equal? "" ln)
    195                 (when (string-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln)
    196                   (set! chunked #t))
    197                 (print ln)
    198                 (loop)))))
     207            (let ([ln (read-line in)])
     208              (unless (string-null? ln)
     209                (when (match-chunked-transfer-encoding ln) (set! chunked #t))
     210                (d "~a~%" ln)
     211                (loop) ) ) ) )
    199212        (when chunked
    200213          (d "reading chunks ...~%")
    201           (let ((data (read-chunks in)))
     214          (let ([data (read-chunks in)])
    202215            (close-input-port in)
    203             (set! in (open-input-string data))))
    204         (d "reading files ...~%")
    205         (let loop ((files '()))
    206           (let ((name (read in)))
    207             (cond ((and (pair? name) (eq? 'error (car name)))
    208                    (apply
    209                     error
    210                     (string-append "[Server] " (cadr name))
    211                     (cddr name)))
    212                   ((or (eof-object? name) (not name))
    213                    (close-input-port in)
    214                    (reverse files) )
    215                   ((not (string? name))
    216                    (error "invalid file name - possibly corrupt transmission" name))
    217                   ((string-suffix? "/" name)
    218                    (read in)            ; skip size
    219                    (d "  ~a~%" name)
    220                    (create-directory (make-pathname dest name))
    221                    (loop files))
    222                   (else
    223                    (d "  ~a~%" name)
    224                    (let* ((size (read in))
    225                           (_ (read-line in))
    226                           (data (read-string size in)) )
    227                      (with-output-to-file (make-pathname dest name)
    228                        (cut display data) ) )
    229                    (loop (cons name files)))))))) )
     216            (set! in (open-input-string data))) ) )
     217      (d "reading files ...~%")
     218      (let get-files ([files '()])
     219        (let ([name (read in)])
     220          (cond [(and (pair? name) (eq? 'error (car name)))
     221                 (apply error (string-append "[Server] " (cadr name)) (cddr name)) ]
     222                [(or (eof-object? name) (not name))
     223                 (close-input-port in)
     224                 (reverse files) ]
     225                [(not (string? name))
     226                 (error "invalid file name - possibly corrupt transmission" name) ]
     227                [(string-suffix? "/" name)
     228                 (read in)              ; skip size
     229                 (d "  ~a~%" name)
     230                 (create-directory (make-pathname dest name))
     231                 (get-files files) ]
     232                [else
     233                 (d "  ~a~%" name)
     234                 (let* ([size (read in)]
     235                        [_ (read-line in)]
     236                        [data (read-string size in)] )
     237                   (with-output-to-file (make-pathname dest name) (cut display data) ) )
     238                 (get-files (cons name files)) ] ) ) ) ) )
    230239
    231240  (define (read-chunks in)
    232     (let loop ((data '()))
    233       (let ((size (string->number (read-line in) 16)))
     241    (let get-chunks ([data '()])
     242      (let ([size (string->number (read-line in) 16)])
    234243        (if (zero? size)
    235             (string-concatenate-reverse data) 
    236             (let ((chunk (read-string size in)))
     244            (string-concatenate-reverse data)
     245            (let ([chunk (read-string size in)])
    237246              (read-line in)
    238               (loop (cons chunk data)))))))
    239 
    240   (define (retrieve-extension name transport location #!key version quiet
    241                               destination username password tests)
    242     (fluid-let ((*quiet* quiet))
     247              (get-chunks (cons chunk data)) ) ) ) ) )
     248
     249  (define (retrieve-extension name transport location
     250                              #!key version quiet destination username password tests)
     251    (fluid-let ([*quiet* quiet])
    243252      (case transport
    244         ((local)
    245          (when destination
    246            (warning "destination for transport `local' ignored"))
    247          (locate-egg/local name location version destination))
    248         ((svn)
    249          (locate-egg/svn name location version destination username password))
    250         ((http)
    251          (locate-egg/http name location version destination tests))
    252         (else (error "cannot retrieve extension unsupported transport" transport)))) )
     253        [(local)
     254         (when destination (warning "destination for transport `local' ignored"))
     255         (locate-egg/local name location version destination) ]
     256        [(svn)
     257         (locate-egg/svn name location version destination username password) ]
     258        [(http)
     259         (locate-egg/http name location version destination tests) ]
     260        [else
     261         (error "cannot retrieve extension unsupported transport" transport) ] ) ) )
    253262
    254263  (define (list-extensions transport location #!key quiet username password)
    255     (fluid-let ((*quiet* quiet))
     264    (fluid-let ([*quiet* quiet])
    256265      (case transport
    257         ((local)
    258          (list-eggs/local location))
    259         ((svn)
    260          (list-eggs/svn location username password))
    261         (else (error "cannot list extensions - unsupported transport" transport)))) )
    262 
    263 )
     266        [(local)
     267         (list-eggs/local location) ]
     268        [(svn)
     269         (list-eggs/svn location username password) ]
     270        [else
     271         (error "cannot list extensions - unsupported transport" transport) ] ) ) )
     272
     273) ;module setup-download
Note: See TracChangeset for help on using the changeset viewer.