source: project/chicken/branches/prerelease/chicken-setup.scm @ 9599

Last change on this file since 9599 was 9599, checked in by Ivan Raikov, 12 years ago

Merged trunk with prerelease branch.

File size: 47.4 KB
Line 
1;;;; chicken-setup
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29  (run-time-macros)
30  (uses srfi-1 regex utils posix tcp match srfi-18 srfi-13)
31  (export move-file run:execute make/proc uninstall-extension
32          install-extension install-program install-script setup-verbose-flag
33          setup-install-flag installation-prefix chicken-prefix find-library
34          find-header program-path remove-file* patch yes-or-no?
35          setup-build-directory setup-root-directory create-directory
36          test-compile try-compile copy-file run-verbose
37          required-chicken-version required-extension-version cross-chicken
38          ##sys#current-source-filename host-extension) )
39
40
41;;; Constants, variables and parameters
42
43#>
44#ifndef C_INSTALL_BIN_HOME
45# define C_INSTALL_BIN_HOME   NULL
46#endif
47
48#ifndef C_INSTALL_CC
49# ifdef _MSC_VER
50#  define C_INSTALL_CC                "cl"
51# else
52#  ifdef __GNUC__
53#   define C_INSTALL_CC                "gcc"
54#  else
55#   define C_INSTALL_CC                "cc"
56#  endif
57# endif
58#endif
59
60#ifndef C_TARGET_CC
61# define C_TARGET_CC  C_INSTALL_CC
62#endif
63
64#ifndef C_TARGET_CXX
65# define C_TARGET_CXX  C_INSTALL_CXX
66#endif
67
68#ifndef C_TARGET_CFLAGS
69# define C_TARGET_CFLAGS  C_INSTALL_CFLAGS
70#endif
71
72#ifndef C_TARGET_MORE_LIBS
73# define C_TARGET_MORE_LIBS  C_INSTALL_LIB_HOME
74#endif
75
76#ifndef C_TARGET_LIB_HOME
77# define C_TARGET_LIB_HOME  C_INSTALL_LIB_HOME
78#endif
79
80#ifndef C_CHICKEN_PROGRAM
81# define C_CHICKEN_PROGRAM   "chicken"
82#endif
83
84#ifndef C_CSC_PROGRAM
85# define C_CSC_PROGRAM   "csc"
86#endif
87
88#ifndef C_CSI_PROGRAM
89# define C_CSI_PROGRAM   "csi"
90#endif
91
92#ifndef C_CHICKEN_PROFILE_PROGRAM
93# define C_CHICKEN_PROFILE_PROGRAM   "chicken-profile"
94#endif
95
96#ifndef C_CHICKEN_SETUP_PROGRAM
97# define C_CHICKEN_SETUP_PROGRAM   "chicken-setup"
98#endif
99
100#ifndef C_CHICKEN_BUG_PROGRAM
101# define C_CHICKEN_BUG_PROGRAM   "chicken-bug"
102#endif
103<#
104
105
106(define-constant setup-file-extension "setup-info")
107(define-constant remote-repository-name "repository")
108
109(include "chicken-more-macros.scm")
110
111
112(define-constant long-options
113'("-help" "-uninstall" "-list" "-run" "-repository" "-program-path"
114  "-version" "-script" "-fetch" "-host" "-proxy" "-keep" "-verbose"
115  "-csc-option" "-dont-ask" "-no-install" "-docindex" "-eval"
116  "-debug" "-ls" "-release" "-test" "-fetch-tree" "-tree" "-svn"
117  "-local" "-revision" "-host-extension" "-build-prefix"
118  "-download-path" "-install-prefix") )
119
120
121(define-constant short-options
122  '(#\h #\u #\l #\r #\R #\P #\V #\s #\f #\H #\p #\k #\v #\c #\d #\n #\i #\e #\D #f #f #\t #f #f #f #f #f #f
123    #f) )
124
125(define *installed-executables* 
126  `(("chicken" . ,(foreign-value "C_CHICKEN_PROGRAM" c-string))
127    ("csc" . ,(foreign-value "C_CSC_PROGRAM" c-string))
128    ("csi" . ,(foreign-value "C_CSI_PROGRAM" c-string))
129    ("chicken-profile" . ,(foreign-value "C_CHICKEN_PROFILE_PROGRAM" c-string))
130    ("chicken-setup" . ,(foreign-value "C_CHICKEN_SETUP_PROGRAM" c-string))
131    ("chicken-bug" . ,(foreign-value "C_CHICKEN_BUG_PROGRAM" c-string))))
132
133
134(define *cc* (foreign-value "C_TARGET_CC" c-string))
135(define *cxx* (foreign-value "C_TARGET_CXX" c-string))
136(define *target-cflags* (foreign-value "C_TARGET_CFLAGS" c-string))
137(define *target-libs* (foreign-value "C_TARGET_MORE_LIBS" c-string))
138(define *target-lib-home* (foreign-value "C_TARGET_LIB_HOME" c-string))
139
140(define *major-version* (##sys#fudge 41))
141(define *default-eggdir* (conc "eggs/" *major-version*))
142
143(define *windows*
144  (and (eq? (software-type) 'windows) 
145       (build-platform) ) )
146
147(define *windows-shell* (or (eq? *windows* 'mingw32)
148                            (eq? *windows* 'msvc)))
149(define *debug* #f)
150
151(register-feature! 'chicken-setup)
152
153(define chicken-bin-path
154  (or (and-let* ((p (getenv "CHICKEN_PREFIX")))
155        (make-pathname p "bin") )
156      (foreign-value "C_INSTALL_BIN_HOME" c-string) ) )
157
158(define chicken-prefix
159  (or (getenv "CHICKEN_PREFIX")
160      (match (string-match "(.*)/bin/?" chicken-bin-path)
161             ((_ p) p)
162             (_ "/usr/local") ) ) ) 
163
164(define example-path 
165  (make-parameter
166   (or (and-let* ((p chicken-prefix))
167         (make-pathname p "/share/chicken/examples") )
168       "/usr/local/share/chicken/examples")))
169
170(define program-path (make-parameter chicken-bin-path))
171
172(define setup-build-prefix
173  (make-parameter
174   (or (getenv "CHICKEN_TMPDIR") (getenv "TMPDIR") 
175       ((lambda (user) 
176          (and user  (file-write-access? "/tmp") 
177               (conc "/tmp/chicken-setup-" *major-version* "-" user))) 
178        (getenv "USER"))
179       ((lambda (home user) 
180          (and home user  (conc home "/tmp/chicken-setup-" *major-version* "-" user))) 
181        (getenv "HOME") (getenv "USER"))
182       (current-directory))))
183
184(define setup-download-directory  (make-parameter (conc (setup-build-prefix) "/downloads")))
185(define setup-root-directory      (make-parameter #f))
186(define setup-build-directory     (make-parameter #f))
187(define setup-verbose-flag        (make-parameter #f))
188(define setup-install-flag        (make-parameter #t))
189
190(define (cross-chicken) (##sys#fudge 39))
191(define host-extension (make-parameter #f))
192
193(define *copy-command* (if *windows-shell* 'copy "cp -r"))
194(define *remove-command* (if *windows-shell* "del /Q /S" "rm -fr"))
195(define *move-command* (if *windows-shell* 'move 'mv))
196(define *gzip-program* 'gzip)
197(define *tar-program* 'tar)
198(define *fetch-only* #f)
199(define *builddir-created* #f)
200(define *keep-stuff* #f)
201(define *csc-options* '())
202(define *abort-hook* #f)
203(define *dont-ask* #f)
204(define *rebuild-doc-index* #f)
205(define *repository-tree* #f)
206(define *last-decent-host* #f)
207(define *proxy-host* #f)
208(define *proxy-port* #f)
209(define *base-directory* (current-directory))
210(define *fetch-tree-only* #f)
211(define *svn-repository* #f)
212(define *local-repository* #f)
213(define *repository-hosts* (list (list "www.call-with-current-continuation.org" *default-eggdir* 80)))
214(define *revision* #f)
215(define *run-tests* #f)
216(define *fetched-eggs* '())
217
218
219;;; File-system routines
220
221(define create-directory/parents
222  (let ([create-directory create-directory])
223    (lambda (dir)
224      (let loop ([dir dir])
225        (when (and dir (not (directory? dir)))
226          (loop (pathname-directory dir))
227          (create-directory dir))) ) ) )
228
229(define create-directory
230  (let ()
231    (define (verb dir)
232      (when (setup-verbose-flag) (printf "  creating directory `~a'~%~!" dir)) )
233    (if *windows-shell*
234        (lambda (dir)
235          (verb dir)
236          (create-directory/parents dir) ) 
237        (lambda (dir)
238          (verb dir)
239          (system* "mkdir -p ~a" (quotewrap dir) ) ) ) ) )
240
241
242
243;;; Helper stuff
244
245(define (quotewrap str)
246  (if (or (string-any char-whitespace? str)
247          (and *windows-shell* (string-any (lambda (c) (char=? c #\/)) str)))
248      (string-append "\"" str "\"") 
249      str) )
250
251(define (abort-setup)
252  (*abort-hook* #f) )
253
254(define (yes-or-no? str . default)
255  (let ((def (:optional default #f)))
256    (let loop ()
257      (printf "~%~A (yes/no/abort) " str)
258      (when def (printf "[~A] " def))
259      (flush-output)
260      (let ((ln (read-line)))
261        (cond ((eof-object? ln) (set! ln "abort"))
262              ((and def (string=? "" ln)) (set! ln def)) )
263        (cond ((string-ci=? "yes" ln) #t)
264              ((string-ci=? "no" ln) #f)
265              ((string-ci=? "abort" ln) (abort-setup))
266              (else
267               (printf "~%Please enter \"yes\", \"no\" or \"abort\".~%")
268               (loop) ) ) ) ) ) )
269
270(define (patch which rx subst)
271  (when (setup-verbose-flag) (printf "patching ~A ...~%" which))
272  (match which
273    ((from to) 
274     (with-output-to-file to
275       (lambda ()
276         (with-input-from-file from
277           (lambda ()
278             (let loop ()
279               (let ((ln (read-line)))
280                 (unless (eof-object? ln)
281                   (write-line (string-substitute rx subst ln #t)) 
282                   (loop) ) ) ) ) ) ) ) )
283    (both
284     (let ((tmp (create-temporary-file)))
285       (patch (list both tmp) rx subst)
286       (system* "~A ~A ~A" *move-command* (quotewrap tmp) (quotewrap both) ) ) ) ) )
287
288(define run-verbose (make-parameter #t))
289
290(define (fixpath prg)
291  (cond ((string=? prg "csc")
292         (string-intersperse 
293          (cons* (quotewrap 
294                  (make-pathname 
295                   chicken-bin-path
296                   (cdr (assoc prg *installed-executables*))))
297                 "-feature" "compiling-extension"
298                 *csc-options*) 
299          " ") )
300        ((assoc prg *installed-executables*) =>
301         (lambda (a) (quotewrap (make-pathname chicken-bin-path (cdr a)))))
302        (else prg) ) )
303
304(define (fixmaketarget file)
305  (if (and (equal? "so" (pathname-extension file))
306           (not (string=? "so" ##sys#load-dynamic-extension)) )
307      (pathname-replace-extension file ##sys#load-dynamic-extension)
308      file) )
309
310(define (run:execute explist)
311  (define (smooth lst)
312    (let ((slst (map ->string lst)))
313      (string-intersperse (cons (fixpath (car slst)) (cdr slst)) " ") ) )
314  (for-each
315   (lambda (cmd)
316     (when (run-verbose) (printf "  ~A~%~!" cmd))
317     (system* "~a" cmd) )
318   (map smooth explist) ) )
319
320(define-macro (run . explist)
321  `(run:execute (list ,@(map (lambda (x) (list 'quasiquote x)) explist))) )
322
323(define-macro (compile . explist)
324  `(run (csc ,@explist) ) )
325
326
327;;; "make" functionality
328
329(define (make:find-matching-line str spec)
330  (let ((match? (lambda (s) (string=? s str))))
331    (let loop ((lines spec))
332      (cond
333       ((null? lines) #f)
334       (else (let* ((line (car lines))
335                    (names (if (string? (car line))
336                               (list (car line))
337                               (car line))))
338               (if (any match? names)
339                   line
340                   (loop (cdr lines)))))))))
341
342(define (make:form-error s p) (error (sprintf "~a: ~s" s p)))
343(define (make:line-error s p n) (error (sprintf "~a: ~s for line: ~a" s p n)))
344
345(define (make:check-spec spec)
346  (and (or (list? spec) (make:form-error "specification is not a list" spec))
347       (or (pair? spec) (make:form-error "specification is an empty list" spec))
348       (every
349        (lambda (line)
350          (and (or (and (list? line) (<= 2 (length line) 3))
351                   (make:form-error "list is not a list with 2 or 3 parts" line))
352               (or (or (string? (car line))
353                       (and (list? (car line))
354                            (every string? (car line))))
355                   (make:form-error "line does not start with a string or list of strings" line))
356               (let ((name (car line)))
357                 (or (list? (cadr line))
358                     (make:line-error "second part of line is not a list" (cadr line) name)
359                     (every (lambda (dep)
360                               (or (string? dep)
361                                   (make:form-error "dependency item is not a string" dep)))
362                             (cadr line)))
363                 (or (null? (cddr line))
364                     (procedure? (caddr line))
365                     (make:line-error "command part of line is not a thunk" (caddr line) name)))))
366        spec)))
367
368(define (make:check-argv argv)
369  (or (string? argv)
370      (every string? argv)
371      (error "argument is not a string or string list" argv)))
372
373(define (make:make/proc/helper spec argv)
374  (when (vector? argv) (set! argv (vector->list argv)))
375  (make:check-spec spec)
376  (make:check-argv argv)
377  (letrec ((made '())
378           (exn? (condition-predicate 'exn))
379           (exn-message (condition-property-accessor 'exn 'message))
380           (make-file
381            (lambda (s indent)
382              (let* ((line (make:find-matching-line s spec))
383                     (s2 (fixmaketarget s)) 
384                     (date (and (file-exists? s2)
385                                (file-modification-time s2))))
386                (when (setup-verbose-flag)
387                  (printf "make: ~achecking ~a~%" indent s2))
388                (if line
389                    (let ((deps (cadr line)))
390                      (for-each (let ((new-indent (string-append " " indent)))
391                                  (lambda (d) (make-file d new-indent)))
392                                deps)
393                      (let ((reason
394                             (or (not date)
395                                 (any (lambda (dep)
396                                          (let ((dep2 (fixmaketarget dep)))
397                                            (unless (file-exists? dep2)
398                                              (error (sprintf "dependancy ~a was not made~%" dep2)))
399                                            (and (> (file-modification-time dep2) date)
400                                                 dep2)) )
401                                        deps))))
402                        (when reason
403                          (let ((l (cddr line)))
404                            (unless (null? l)
405                              (set! made (cons s made))
406                              (when (setup-verbose-flag)
407                                (printf "make: ~amaking ~a~a~%"
408                                        indent
409                                        s2
410                                        (cond
411                                         ((not date)
412                                          (string-append " because " s2 " does not exist"))
413                                         ((string? reason)
414                                          (string-append " because " reason " changed"))
415                                         (else
416                                          (string-append (sprintf " just because (reason: ~a date: ~a)" 
417                                                                  reason date)))) ) )
418                              (handle-exceptions exn
419                                  (begin
420                                    (printf "make: Failed to make ~a: ~a~%"
421                                            (car line)
422                                            (if (exn? exn)
423                                                (exn-message exn)
424                                                exn))
425                                    (signal exn) )
426                                ((car l))))))))
427                    (unless date
428                      (error (sprintf "don't know how to make ~a" s2))))))))
429    (cond
430     ((string? argv) (make-file argv ""))
431     ((null? argv) (make-file (caar spec) ""))
432     (else (for-each (lambda (f) (make-file f "")) argv)))
433    (when (setup-verbose-flag)
434      (for-each (lambda (item)
435                  (printf "make: made ~a~%" item))
436        (reverse made)))) )
437
438(define make/proc
439  (case-lambda
440   ((spec) (make:make/proc/helper spec '()))
441   ((spec argv)
442    (make:make/proc/helper
443     spec
444     (if (vector? argv)
445         (vector->list argv)
446         argv) ) ) ) )
447
448(define-macro (make spec #!optional (argv ''()))
449  (let ((form-error (lambda (s . p) (apply error s spec p))))
450    (and (or (list? spec) (form-error "illegal specification (not a sequence)"))
451         (or (pair? spec) (form-error "empty specification"))
452         (every
453          (lambda (line)
454            (and (or (and (list? line) (>= (length line) 2))
455                     (form-error "clause does not have at least 2 parts" line))
456                 (let ((name (car line)))
457                   (or (list? (cadr line))
458                       (make:line-error "second part of clause is not a sequence" (cadr line) name)))))
459          spec))
460    `(make/proc (list ,@(map (lambda (line)
461                               `(list ,(car line)
462                                      (list ,@(cadr line))
463                                      ,@(let ((l (cddr line)))
464                                          (if (null? l)
465                                              '()
466                                              `((lambda ()
467                                                  ,@l))))))
468                             spec))
469                ,argv)))
470
471
472;;; Create new repository file
473
474(define (create-repository-file eggdir)
475  (let ((eggs 
476         (filter-map
477          (lambda (d)
478            (and-let* ((mf (or (file-exists? (make-pathname (list eggdir d) d "meta"))
479                               (file-exists? (make-pathname (list eggdir d "trunk") d "meta")))))
480              (display mf (current-error-port))
481              (newline (current-error-port))
482              (cons d (with-input-from-file mf read)) ) )
483          (directory eggdir))) )
484    (write-char #\()
485    (for-each
486     (lambda (e)
487       (let ((needs (assq 'needs (cdr e))))
488         (pp `(,(string->symbol (car e))
489               ()
490               ,(conc e ".egg")
491               ,@(if needs (cdr needs) '())))))
492     eggs) 
493    (write-char #\))))
494
495
496;;; Show usage information
497
498(define (usage)
499  (display #<<EOF
500usage: chicken-setup [OPTION ...] FILENAME
501
502  -h  -help                      shows this text and exits
503  -V  -version                   shows version of this program and exits
504      -release                   shows release number and exits
505  -R  -repository [PATH]         if PATH is not given, prints the location of the extension repository
506                                 if PATH is given, specifies the location for the extension repository 
507  -u  -uninstall                 removes the following extension from repository
508  -H  -host HOSTNAME[:PORT]      specifies alternative host for downloading
509  -p  -proxy HOSTNAME[:PORT]     connects via proxy
510  -l  -list [NAME ...]           lists installed extensions or shows extension information
511  -r  -run FILENAME              loads and executes given file
512  -P  -program-path [PATH]       if PATH is not given, prints the location where executables will be installed
513                                 if PATH is given, specifies the location for installing executables
514  -s  -script FILENAME           executes script with remaining arguments and exits
515  -f  -fetch                     only download, don't extract, build or install
516  -v  -verbose                   verbose mode
517  -k  -keep                      keeps intermediate files after building and installing
518  -c  -csc-option OPTION         passes extra option to csc (if run with `(run (csc ...))')
519  -d  -dont-ask                  always download, if asked
520  -n  -no-install                does not install generated binaries and support files
521  -i  -docindex                  displays path for documentation index
522  -e  -eval EXPRESSION           evaluates expression
523  -t  -test                      runs test suite, if it exists
524      -host-extension            compiles any extensions in "host" mode
525      -ls EXTENSION              lists installed files for extension
526      -fetch-tree                downloads and show repository catalog
527      -create-tree DIRECTORY     creates repository catalog from SVN checkout
528      -tree FILENAME             uses repository catalog from given file
529      -svn URL                   fetches extension from subversion repository
530      -local PATH                fetches extension from local filesystem
531      -revision REV              specifies SVN revision for checkout
532      -build-prefix PATH         location where chicken-setup will create egg build directories
533                                 (default: the value of environment variable CHICKEN_TMPDIR, TMPDIR or
534                                  /tmp/chicken-setup-{MAJOR-VERSION}-{USER} 
535                                  if none of these variables are found in the environment)
536      -download-path PATH         location where chicken-setup will save downloaded files
537                                 (default: {BUILD-PREFIX}/downloads)
538      -install-prefix PATH       specifies alternative installation prefix
539  --                             ignores all following arguments
540
541  Builds and installs extension libraries.
542
543EOF
544  )
545  (exit) )
546
547
548;;; Processing setup scripts
549
550(define (make-setup-info-pathname fn #!optional (rpath (repository-path)))
551  (make-pathname rpath fn setup-file-extension) )
552
553(define installation-prefix
554  (make-parameter (or (getenv "CHICKEN_INSTALL_PREFIX") #f)))
555
556(define (with-ext filename ext)
557  (if (and (equal? (pathname-extension filename) ext)
558           (file-exists? filename) )
559      filename
560      (let ((f2 (pathname-replace-extension filename ext)))
561        (and (file-exists? f2) f2) ) ) )
562
563(define (run-setup-script filename)
564  (when (setup-verbose-flag) (printf "executing ~A ...~%" filename))
565  (load filename) 
566  (when *run-tests* 
567    (if (and (file-exists? "tests")
568             (directory? "tests") 
569             (file-exists? (make-pathname "tests" "run.scm")) )
570        (let ((old (current-directory)))
571          (change-directory "tests")
572          (when (setup-verbose-flag)
573            (printf "running test cases ...~%") )
574          (run (csi -s run.scm ,(pathname-file filename))) 
575          (change-directory old))
576        (print "egg has no test suite.") ) ) )
577
578(define (write-info id files info)
579  (let-values (((exports info) (fix-exports id info)))
580    (let ((info `((files ,@files) 
581                ,@exports
582                ,@(or (and-let* (*repository-tree*
583                                 (a (assq id *repository-tree*))
584                                 (a2 (assq 'date (second a))) )
585                        `((release ,(second a2))) )
586                      '() ) 
587                ,@info)) )
588      (when (setup-verbose-flag) (printf "writing info ~A -> ~S ...~%" id info))
589      (let* ((sid (->string id))
590            (setup-file (make-setup-info-pathname sid (repo-path #t)))
591            (write-setup-info (with-output-to-file setup-file
592                                (cut pp info))))
593        (unless *windows-shell* (run (chmod a+r ,setup-file)))
594        write-setup-info))))
595
596(define (fix-exports id info)
597  (let-values (((einfo oinfo) (partition (lambda (item) (eq? 'exports (car item))) info)))
598    (let ((exports
599           (if (pair? einfo)
600               (append-map
601                (lambda (eitem)
602                  (let loop ((exports (cdr eitem)))
603                    (if (null? exports)
604                        '()
605                        (let ((x (car exports))
606                              (rest (cdr exports)) )
607                          (cond ((string? x) (append (read-file x) (loop rest)))
608                                ((symbol? x) (cons x (loop rest)))
609                                (else (error "invalid export item" x)) ) ) ) ) )
610                einfo) 
611               (and-let* ((f (file-exists? (make-pathname #f (->string id) "exports"))))
612                 (read-file f) ) ) ) )
613      (if exports 
614          (values `((exports ,@exports)) oinfo)
615          (values '() oinfo) ) ) ) )
616
617(define (compute-builddir fpath)
618  (if (equal? "egg-dir" (pathname-extension fpath)) fpath
619      (let ((fname (pathname-strip-directory fpath))) 
620        (let loop ((num (random 10000)))
621          (let* ((buildname (string-append "build." (number->string num)))
622                 (path  (make-pathname (setup-build-prefix) buildname (string-append fname "-dir") )))
623            (if (file-exists? path) (loop (random 10000))
624                path))))))
625
626
627(define (chdir dir)
628  (when (setup-verbose-flag) (printf "changing working directory to `~A'~%" dir))
629  (change-directory dir) )
630
631(define (clear-builddir)
632  (unless (string=? (current-directory) *base-directory*)
633    (chdir *base-directory*) )
634  (when *builddir-created*
635    (set! *builddir-created* #f)
636    (unless *keep-stuff*
637      (when (setup-verbose-flag) (printf "removing egg build directory `~A'~%" (setup-build-directory)))
638      (handle-exceptions ex
639          (warning "removal of egg build directory failed" (setup-build-directory))
640        (run (,*remove-command* ,(quotewrap (setup-build-directory))) )) ) ))
641
642(define (unpack/enter filename)
643  (define (testgz fn)
644    (with-input-from-file fn
645      (lambda () (string=? "\x1f\x8b" (read-string 2))) ) )
646  (let ((tmpdir (compute-builddir filename)))
647    (cond ((file-exists? tmpdir) 
648           (chdir tmpdir)
649           (setup-build-directory (current-directory)) )
650          (else
651           (create-directory tmpdir)
652           (set! *builddir-created* #t)
653           (chdir tmpdir)
654           (setup-build-directory (current-directory))
655           (let ((fn2 (if (and (not (or *local-repository* (with-ext filename "egg") (with-ext filename "egg-dir")))
656                               (not (string-prefix? (setup-download-directory) filename)))
657                          (make-pathname (setup-download-directory) filename)
658                          filename))
659                 (v (setup-verbose-flag)) )
660             (if (testgz fn2)
661                 (run (,*gzip-program* -d -c ,fn2 |\|| ,*tar-program* ,(if v 'xvf 'xf) -))
662                 (run (,*tar-program* ,(if v 'xvf 'xf) ,fn2)) ) ) ) )
663    ))
664
665(define (copy-file from to #!optional (err #t) (prefix (installation-prefix)))
666  (let ((from (if (pair? from) (car from) from))
667        (to ((lambda (pre) (let ((to-path (if (pair? from) (make-pathname to (cadr from)) to)))
668                             (if (and pre (not (string-prefix? pre to-path)))
669                                 (make-pathname pre to-path) to-path)))
670             prefix)))
671    (ensure-directory to)
672    (cond ((or (glob? from) (file-exists? from))
673           (begin
674             (run (,*copy-command* ,(quotewrap from) ,(quotewrap to))) 
675             to))
676          (err (error "file does not exist" from))
677          (else (warning "file does not exist" from)))))
678
679(define (move-file from to)
680  (let ((from  (if (pair? from) (car from) from))
681        (to    (let ((to-path (if (pair? from) (make-pathname to (cadr from)) to)))
682                 (if (and pre (not (string-prefix? pre to-path)))
683                     (make-pathname pre to-path) to-path))))
684    (ensure-directory to)
685    (run (,*move-command* ,(quotewrap from) ,(quotewrap to)) ) ) )
686
687(define (remove-file* dir)
688  (run (,*remove-command* ,(quotewrap dir)) ) )
689
690(define (make-dest-pathname path file)
691  (match file
692    ((from to) (make-dest-pathname path to))
693    (_ (if (absolute-pathname? file)
694           file
695           (make-pathname path file) ) ) ) )
696
697(define (check-filelist flist)
698  (map (lambda (f)
699         (match f
700           ((? string?) f)
701           (((? string?) (? string?)) f)
702           (((? string? h) . (? string? t)) (list h t))
703           (_ (error "invalid file-specification" f)) ) )
704       flist) )
705
706(define (translate-extension f #!optional default)
707  (pathname-replace-extension f
708   (match (pathname-extension f)
709     (#f default)
710     ("so" ##sys#load-dynamic-extension)
711     ("a" (if *windows-shell* "lib" "a"))
712     (x x) ) ) )
713
714
715;;; Installation
716
717(define (install-extension id files #!optional (info '()))
718  (when (setup-install-flag)
719    (let* ((files (check-filelist (if (list? files) files (list files))))
720           (rpath (repo-path))
721           (rpathd (repo-path #t))
722           (dests (map (lambda (f)
723                         (let ((from (if (pair? f) (car f) f))
724                               (to (make-dest-pathname rpathd f)) )
725                           (when (and (not *windows*) 
726                                      (equal? "so" (pathname-extension to)))
727                             (run (,*remove-command* ,to)) )
728                           (copy-file from to)
729                           (unless *windows-shell*
730                             (run (chmod a+r ,to)))
731                           (and-let* ((static (assq 'static info)))
732                             (when (and (eq? (software-version) 'macosx)
733                                        (equal? (cadr static) from) 
734                                        (equal? (pathname-extension to) "a"))
735                               (run (ranlib ,to)) ) )
736                           (make-dest-pathname rpath f)))
737                       files) ) )
738      (and-let* ((docs (assq 'documentation info)))
739        (let ((docpath (pathname-directory (doc-index #t))))
740          (print "\n* Installing documentation files in " docpath ":")
741          (for-each
742           (lambda (f)
743             (copy-file f (make-pathname docpath f) #f) )
744           (cdr docs))
745          (newline)
746          (set! *rebuild-doc-index* #t)) )
747      (and-let* ((exs (assq 'examples info)))
748        (let ((example-dest 
749               ((lambda (pre) (if pre (make-pathname pre (example-path)) (example-path)))
750                (installation-prefix))))
751          (print "\n* Installing example files in " example-dest ":")
752          (for-each
753           (lambda (f)
754             (let ((destf (make-pathname example-dest f)))
755               (copy-file f destf #f)
756               (unless *windows-shell*
757                 (run (chmod a+rx ,destf))) ) )
758           (cdr exs))
759          (newline) ))
760      (write-info id dests info) ) ) )
761
762(define (install-program id files #!optional (info '()))
763  (define (exify f)
764    (translate-extension
765     f
766     (if *windows-shell* "exe" #f) ) )
767  (when (setup-install-flag)
768    (let* ((files (check-filelist (if (list? files) files (list files))))
769           (ppath ((lambda (pre) (if pre (make-pathname pre (program-path)) (program-path)))
770                   (installation-prefix)))
771           (files (if *windows*
772                      (map (lambda (f)
773                             (if (list? f) 
774                                 (list (exify (car f)) (exify (cadr f)))
775                                 (exify f) ) )
776                           files)
777                      files) ) 
778           (dests (map (lambda (f)
779                         (let ((from (if (pair? f) (car f) f))
780                               (to (make-dest-pathname ppath f)) )
781                           (copy-file from to) 
782                           (unless *windows-shell*
783                                   (run (chmod a+r ,to)))
784                           to) )
785                       files) ) )
786      (write-info id dests info) ) ) )
787
788(define (install-script id files #!optional (info '()))
789  (when (setup-install-flag)
790    (let* ((files (check-filelist (if (list? files) files (list files))))
791           (ppath ((lambda (pre) (if pre (make-pathname pre (program-path)) (program-path)))
792                   (installation-prefix)))
793           (pfiles (map (lambda (f)
794                          (let ((from (if (pair? f) (car f) f))
795                                (to (make-dest-pathname ppath f)) )
796                            (copy-file from to) 
797                            (unless *windows-shell*
798                                    (run (chmod a+r ,to)))
799                            to) )
800                        files) ) )
801      (unless *windows-shell*
802        (run (chmod a+rx ,(string-intersperse pfiles " "))) )
803      (write-info id pfiles info) ) ) )
804
805(define (uninstall-extension ext)
806  (let* ((info (extension-information ext))
807         (files (and info (assq 'files info))) )
808    (if files
809        (begin
810          (printf "deleting ~A ...~%" ext)
811          (for-each
812           (lambda (f)
813             (let ((f (if (pair? f) (cadr f) f)))
814               (when (setup-verbose-flag) (printf "  deleting ~A~%" f))
815               (run (,*remove-command* ,(quotewrap f)) ) ) )
816           (cdr files) ) )
817        (print "no files to uninstall") )
818    (when (assq 'documentation info) (set! *rebuild-doc-index* #t))
819    (delete-file* (make-setup-info-pathname (->string ext)))))
820
821
822;;; More helper stuff
823
824(define (repo-path #!optional ddir?)
825  (let ((p (if (and ddir? (installation-prefix))
826               (make-pathname (installation-prefix) (repository-path))
827               (repository-path))) )
828    (ensure-directory p)
829    p) )
830
831(define (ensure-directory path)
832  (and-let* ((dir (pathname-directory path)))
833    (if (file-exists? dir)
834        (unless (directory? dir)
835          (error "can not create directory: a file with the same name already exists") )
836        (begin
837          (create-directory dir)
838          (unless *windows-shell*
839                  (run (chmod a+x ,dir)))))))
840
841(define (try-compile code #!key c++ (cc (if c++ *cxx* *cc*)) (cflags "") (ldflags "") 
842                     (verb (setup-verbose-flag)) (compile-only #f))
843  (let* ((fname (create-temporary-file "c"))
844         (oname (pathname-replace-extension fname "o"))
845         (r (begin
846              (with-output-to-file fname (cut display code))
847              (system 
848               (let ((cmd (conc
849                           cc " "
850                           (if compile-only "-c" "") " "
851                           cflags " " *target-cflags* " "
852                           fname " "
853                           (if compile-only
854                               "" 
855                               (conc "-L" *target-lib-home* " " ldflags " " *target-libs*) )
856                           " >/dev/null "
857                           (if verb "" "2>&1") ) ) )
858                 (when verb (print cmd " ..."))
859                 cmd) ) ) ) )
860    (when verb (print (if (zero? r) "succeeded." "failed.")))
861    (system (sprintf "~A ~A" *remove-command* (quotewrap fname)))
862    (zero? r) ) )
863
864(define (required-chicken-version v)
865  (when (string-ci<? (chicken-version) (->string v))
866    (error (sprintf "CHICKEN version ~a or higher is required" v)) ) )
867
868(define (upgrade-message ext msg)
869  (error
870   (sprintf
871    "the required extension `~s' ~a - please run~%~%  chicken-setup ~a~%~%and repeat the current installation operation."
872    ext msg ext) ) )
873
874(define (required-extension-version . args)
875  (let loop ((args args))
876    (match args
877      (() #f)
878      ((ext version . more)
879       (let ((info (extension-information ext))
880             (version (->string version)) )
881         (if info
882             (let ((ver (and (assq 'version info) (cadr (assq 'version info)))))
883               (cond ((not ver) (upgrade-message ext "has no associated version information"))
884                     ((string-ci<? (->string ver) version)
885                      (upgrade-message 
886                       ext
887                       (sprintf "is older than ~a, which is what this extension requires"
888                                version) ) )
889                     (else (loop more)) ) ) 
890             (upgrade-message ext "is not installed") ) ) )
891      (_ (error 'required-extension-information "bad argument format" args)) ) ) )
892
893(define test-compile try-compile)
894
895(define (find-library name proc)
896  (test-compile 
897   (sprintf "#ifdef __cplusplus~%extern \"C\"~%#endif~%char ~a();~%int main() { ~a(); return 0; }~%" proc proc)
898   ldflags: (conc "-l" name) ) )
899
900
901;;; HTTP repository access
902
903(define (find-header name)
904  (test-compile
905   (sprintf "#include <~a>\nint main() { return 0; }\n" name)
906   compile-only: #t) )
907
908(define (http-get-path-request path fname host)
909  (sprintf "~A HTTP/1.0\r\nHost: ~A\r\nConnection: close\r\nContent-length: 0\r\n\r\n"
910           (let ((p (make-pathname path fname "" "/")))
911             (if (absolute-pathname? p)
912                 p
913                 (conc "/" p) ) )
914           host))
915
916(define (http-get-request path fname host)
917  (if *proxy-host*
918      (sprintf "GET http://~A~A" host (http-get-path-request path fname host))
919      (sprintf "GET ~A" (http-get-path-request path fname host))))
920
921(define (setup-tcp-connect host port)
922  (if *proxy-host*
923      (tcp-connect *proxy-host* *proxy-port*)
924      (tcp-connect host port)))
925
926(define (download-repository-tree)
927  (unless *repository-tree*
928    (when (setup-verbose-flag) (print "downloading catalog ..."))
929    (let loop ((hosts *repository-hosts*))
930      (if (null? hosts)
931          (error "unable to connect")
932          (match hosts
933            (((host path port) . more)
934             (call/cc
935              (lambda (return)
936                (or (handle-exceptions ex
937                      (begin (printf "could not connect to ~A.~%" host) #f)
938                      (when (setup-verbose-flag)
939                        (printf "downloading catalog from ~A ...~%" host) )
940                      (let-values (((i o) (setup-tcp-connect host port)))
941                        (set! *last-decent-host* (car hosts))
942                        (let ((req (http-get-request path remote-repository-name host)))
943                          (when (setup-verbose-flag) (display req))
944                          (display req o) )
945                        (let ((ln (read-line i)))
946                          (when (setup-verbose-flag) (print ln))
947                          (when (string-match "HTTP.+ 404 .+" ln)
948                            (print "no remote repository available") 
949                            (return #f) ) )
950                        (let loop ()
951                          (let ((ln (read-line i)))
952                            (when (setup-verbose-flag) (print ln))
953                            (if (string=? "" ln)
954                                (begin
955                                  (set! *repository-tree* (read i))
956                                  (when *debug*
957                                    (print "catalog:")
958                                    (pp *repository-tree*) )
959                                  (close-input-port i)
960                                  (close-output-port o)
961                                  #t)
962                                (loop) ) ) ) ) )
963                    (loop more) ) ) ) )
964            ((x . _) (error "(internal) invalid host" x)) ) ) ) ) )
965
966(define *progress-indicator*
967  (thread-start!
968   (rec (loop)
969     (thread-sleep! 1)
970     (print* ".")
971     (loop) ) ) )
972
973(thread-suspend! *progress-indicator*)
974
975(define (with-progress-indicator thunk)
976  (dynamic-wind
977      (cut thread-resume! *progress-indicator*)
978      thunk
979      (lambda ()
980        (newline)
981        (thread-suspend! *progress-indicator*) ) ) )
982
983(define (download-data hostdata item #!optional filename)
984  (unless hostdata (set! hostdata (car *repository-hosts*)))
985  (cond (*local-repository*
986         (when (setup-verbose-flag) (printf "fetching from local directory ~a ...~%" *local-repository*))
987         (let* ((p  (->string item))
988               (fpath  (make-pathname (setup-download-directory) p "egg-dir")))
989           (copy-file (make-pathname *local-repository* p) fpath #t #f)))
990
991        (*svn-repository*
992         (when (setup-verbose-flag) (printf "fetching from svn repository ~a ...~%" *svn-repository*))
993         (let* ((p (->string item))
994               (fpath (make-pathname (setup-download-directory) p "egg-dir")))
995           (run (svn co ,(if *revision* (conc "--revision " *revision*) "")
996                     ,(make-pathname *svn-repository* p) ,fpath))
997           fpath))
998
999        (else
1000         (match hostdata
1001           ((host path port)
1002            (let ((fname (or filename (third (assq item *repository-tree*)))))
1003              (printf "downloading ~A from ~A ~!" fname hostdata)
1004              (let-values (((i o) (setup-tcp-connect host port)))
1005                (let ((req (http-get-request 
1006                            (if filename (pathname-directory filename) path)
1007                            (if filename (pathname-strip-directory fname) fname)
1008                            host) ) )
1009                  (when *debug* (display req))
1010                  (display req o) )
1011                (let loop ()
1012                  (let ((ln (read-line i)))
1013                    ;; check for 404 here...
1014                    (if (string=? "" ln)
1015                        (let ((data (with-progress-indicator (cut read-string #f i))))
1016                          (close-input-port i)
1017                          (close-output-port o)
1018                          (if (not (file-exists? (setup-download-directory)))
1019                              (create-directory (setup-download-directory)))
1020                          (let ((fpath (make-pathname (setup-download-directory) (pathname-strip-directory fname))))
1021                            (with-output-to-file fpath
1022                              (cut display data) 
1023                              binary:)
1024                            fpath))
1025                        (loop) ) ) ) ) ) )
1026           (x (error "(internal) invalid host" x)) ) ) ) )
1027
1028(define (requirements reqs)
1029  (fold 
1030   (lambda (r reqs)
1031     (cond ((symbol? r)
1032            (let ((node (assq r *repository-tree*)))
1033              (cond (node (append (requirements (cdddr node)) (list (car node)) reqs))
1034                    ((memq r ##sys#core-library-modules) reqs)
1035                    (else (error "broken dependencies: extension does not exist" r) ) ) ) )
1036           (else (error "invalid requirement spec" r))))
1037   '() 
1038   reqs) )
1039
1040(define (fetch-file ext)
1041  (and (or *dont-ask*
1042           (yes-or-no?
1043            (sprintf "The extension ~A does not exist.~%Do you want to download it ?" ext)
1044            "yes") )
1045       (cond ((pathname-directory ext)
1046              (printf "Warning: no repository index available, trying direct download...~%" ext)
1047              (set! *last-decent-host* (car *repository-hosts*))
1048              (set! *dont-ask* #t)
1049              (download-data
1050               *last-decent-host*
1051               (pathname-file ext)
1052               (pathname-replace-extension ext "egg") ))
1053
1054             (else
1055              (download-repository-tree)
1056              (set! *dont-ask* #t)
1057              (let ((a (and *repository-tree* (assq (string->symbol ext) *repository-tree*))))
1058                (when *debug* (printf "catalog entry: ~s~%" a))
1059                (cond (a (let ((reqs (remove extension-information (delete-duplicates (requirements (cdddr a)) eq?))))
1060                           (when (pair? reqs)
1061                             (print "downloading required extensions " reqs " ...")
1062                             (for-each (cut download-data *last-decent-host* <>) reqs)
1063                             (print "installing required extensions ...")
1064                             (for-each (cut install <>) (map ->string reqs)) )
1065                           (download-data *last-decent-host* (first a))) ) 
1066                      (else
1067                       (error "Extension does not exist in the repository" ext)) ) ) ) ) ) )
1068
1069
1070;;; Main entry point
1071
1072(define (install filename)
1073  (let ((df (not *fetch-only*)))
1074    (let loop ((filename filename))
1075      (cond ((and df (with-ext filename "setup")) => run-setup-script)
1076            ((or (with-ext filename "egg") (with-ext filename "egg-dir")) =>
1077             (lambda (fpath)
1078               (let ((f (pathname-strip-directory fpath)))
1079                 (when df
1080                   (unpack/enter fpath)
1081                   (let ((sfile (pathname-replace-extension f "setup")))
1082                     (when (and (not (file-exists? sfile)) (file-exists? "tags") )
1083                       (let ((ds (sort (directory "tags") string>=?)))
1084                         (when (pair? ds) 
1085                           (let ((d (make-pathname "tags" (car ds))))
1086                             (chdir d) ) )  ) )
1087                     (loop sfile)
1088                     (clear-builddir) ) ) ) ))
1089            ((fetch-file filename) =>
1090             (lambda (fpath)
1091               (set! *fetched-eggs* 
1092                     (append
1093                      *fetched-eggs* 
1094                      (if fpath (list fpath) (list (make-pathname (current-directory) filename "egg")))))
1095               (when df
1096                 (loop fpath))))))))
1097
1098
1099;;; Documentation index generation
1100
1101(define (doc-index #!optional ddir?)
1102  (make-pathname (repo-path ddir?) "index.html"))
1103
1104(define (doc-stylesheet #!optional ddir?)
1105  (make-pathname (repo-path ddir?) "style.css"))
1106
1107(define (extension-documented? rpath fn)
1108  (let ([pn (make-setup-info-pathname fn rpath)])
1109    (and (file-exists? pn)
1110         (with-input-from-file pn
1111           (lambda ()
1112             (not (not (alist-ref 'documentation (read) eq?))) ) ) ) ) )
1113
1114(define (delete-undocumented-extensions rpath lst)
1115  (filter (cut extension-documented? rpath <>) lst) )
1116
1117(define (build-doc-index)
1118  (let ((rpath (repository-path))
1119        (hn (get-host-name)))
1120    (with-output-to-file (doc-stylesheet #t)
1121      (lambda () (display #<<EOF
1122body, html {
1123  color: #000;
1124  background-color: #fff;
1125  font: 9pt "Lucida Grande", "Verdana", sans-serif;
1126  line-height: 1.6;
1127  margin: 0;
1128  padding: 0;
1129}
1130
1131a {
1132    color: #669;
1133    text-decoration: none;
1134}
1135a:visited { color: #555; }
1136a:active  { color: #966; }
1137a:hover   { color: #bbd; }
1138
1139#title {
1140    border-bottom: 1px solid #669;
1141    background-color: #669;
1142    margin: 0;
1143    padding: 0 3em 0.2em;
1144    float: left;
1145    color: #fff;
1146}
1147
1148#install-info {
1149    clear: left;
1150    padding: 1em;
1151}
1152
1153#official-index {
1154    padding: 1em;
1155    float: right;
1156}
1157
1158#egg-index {
1159    width: 60%;
1160    margin: auto;
1161    border-spacing: 0;
1162}
1163
1164/* Everything but the first one is aligned right */
1165#egg-index tr > * {
1166    text-align: left;
1167}
1168
1169#egg-index tr > * + * {
1170    text-align: right;
1171}
1172
1173#egg-index a {
1174    display: block;
1175}
1176
1177thead tr {
1178    color: #fff;
1179    background-color: #669;
1180}
1181
1182th {
1183    padding: 0.1em 1em 0.3em;
1184}
1185
1186td {
1187    padding: 0.3em 1em;
1188}
1189
1190tr.even {
1191    background-color: #eee;
1192}
1193tr {
1194    background-color: white;
1195}
1196EOF
1197    )))
1198    (with-output-to-file (doc-index #t)
1199      (lambda ()
1200        (print "<html><head><title>Egg documentation index for " hn 
1201               "</title><link rel=\"stylesheet\" type=\"text/css\" href=\"style.css\"/></head>")
1202        (print "<body><a id=\"official-index\" href=\"http://www.call-with-current-continuation.org/"
1203               *default-eggdir* "/index.html\">Visit the official egg index</a>")
1204        (print "<h1 id=\"title\">Egg documentation index:</h1>")
1205        (printf "<p id=\"install-info\">CHICKEN: ~a<br>Host: ~a<br>Repository path: ~a<br><p>~%" 
1206                (chicken-version #t)
1207                (get-host-name)
1208                rpath)
1209        (print "<table id=\"egg-index\">")
1210        (print "<thead><tr><th>Egg name</th><th>Version</th><th>Release</th></tr></thead>\n<tbody>")
1211        (let ((c 0))
1212          (for-each
1213           (lambda (f)
1214             (and-let* ((info (extension-information f)))
1215               (printf "<tr~a><td>" (if (even? c) " class=\"even\"" ""))
1216               (set! c (add1 c))
1217               (let ((doc (assq 'documentation info)))
1218                 (if doc
1219                     (printf "<a href=\"~a\">~a</a>" (cadr doc) f) 
1220                     (display f) )
1221                 (printf "</td>~%")
1222                 (printf "<td>~A</td>" (car (alist-ref 'version info eq? '(""))))
1223                 (printf "<td>~A</td>" (car (alist-ref 'release info eq? '(""))))
1224                 (printf "</tr>~%") ) ) )
1225           (delete-undocumented-extensions 
1226            rpath
1227            (sort (delete-duplicates
1228                   (grep "^[^.].*\\.*$" (map pathname-file (directory rpath))) string=?)
1229                  string<?) ) )
1230          (display "</tbody></table></body></font></html>\n") ) ) ) ) )
1231
1232;;; Output stuff
1233
1234(define (format-string str cols #!optional right (padc #\space))
1235  (let* ((len (string-length str))
1236         (pad (make-string (fxmax 0 (fx- cols len)) padc)) )
1237    (if right
1238        (string-append pad str)
1239        (string-append str pad) ) ) )
1240
1241(define get-terminal-width
1242  (let ((default-width 78)) ; Standard default terminal width
1243    (lambda ()
1244      (let ((cop (current-output-port)))
1245        (if (terminal-port? cop)
1246            (with-exception-handler
1247             (lambda (_) 
1248               default-width)
1249             (lambda ()
1250               (call-with-values
1251                   (lambda () (terminal-size cop))
1252                   (lambda (_ cols) cols))))
1253             default-width)))))
1254
1255(define (list-installed)
1256  (let* ((line-width (get-terminal-width))
1257         (eggs (sort (delete-duplicates
1258                      (grep "^[^.].*\\.*$"
1259                            (map pathname-file
1260                                 (directory (repository-path)))) string=?)
1261                     string<?)) 
1262         (version-number-width
1263          (fold
1264           (lambda (egg maxlen)
1265             (max maxlen
1266                  (or (and-let* ((info (extension-information egg))
1267                                 (v (assq 'version info)))
1268                                (string-length (->string (cadr v))))
1269                      0))) 0 eggs))
1270         (version-width (fx+ version-number-width 9))
1271         (release-width 22)
1272         (name-width (fxmax (- line-width version-width release-width 3) 12)))
1273    (for-each
1274     (lambda (f)
1275       (and-let* ((info (extension-information f)))
1276                 (print (format-string (->string f) name-width)
1277                        " "
1278                        (format-string 
1279                         (or (and-let*
1280                              ((v (assq 'version info)))
1281                              (sprintf "Version: ~A"
1282                                       (format-string (->string (cadr v))
1283                                                      version-number-width #t)))
1284                             "") 
1285                         version-width #t)
1286                        " "
1287                        (or (and-let* ((r (assq 'release info)))
1288                                      (sprintf "(Release ~a)" (cadr r)) )
1289                            "") ) ) )
1290     eggs)))
1291
1292
1293;;; Command line processing
1294
1295(define (main args)
1296  (define (parse-host host eggdir)
1297    (set! *repository-hosts*
1298      (cons (match (string-match "(.+)\\:([0-9]+)" host)
1299              ((_ host port) (list host (if eggdir *default-eggdir* "") (string->number port)))
1300              (_ (list host (if eggdir (conc *default-eggdir* "") 80)) ) )
1301            *repository-hosts*) )  )
1302  (setup-root-directory *base-directory*)
1303  (let ((uinst #f)
1304        (anydone #f))
1305    (let loop ((args args))
1306      (match args
1307        (((or "-help" "--help") . _) (usage))
1308        (("-uninstall" . more)
1309         (set! uinst #t)
1310         (loop more) )
1311        (("-list" more ...)
1312         (if (pair? more)
1313             (for-each
1314              (lambda (e)
1315                (let ((info (extension-information e)))
1316                  (cond (info
1317                         (print e ":\n")
1318                         (pp info) 
1319                         (newline) )
1320                        (else (print "Warning: No extension named `" e "' installed.\n")) ) ) )
1321              more)
1322             (list-installed) )
1323         (exit) )
1324        (("-run" fname . more)
1325         (load fname)
1326         (loop more) )
1327        (("-repository")
1328         (print (repository-path))
1329         (exit) )
1330        (("-repository" dir . more)
1331         (repository-path dir)
1332         (loop more) )
1333        (("-tree" file . more)
1334         (set! *repository-tree* (with-input-from-file file read))
1335         (loop more) )
1336        (("--" . more)
1337         (exit) )
1338        (("-program-path")
1339         (print (program-path))
1340         (exit) )
1341        (("-install-prefix" path . more)
1342         (installation-prefix path)
1343         (loop more) )
1344        (("-build-prefix" path . more)
1345         (setup-build-prefix path)
1346         (loop more) )
1347        (("-download-path" path . more)
1348         (setup-download-directory path)
1349         (loop more) )
1350        (("-program-path" dir . more)
1351         (program-path dir)
1352         (loop more) )
1353        (("-version" . _)
1354         (printf "chicken-setup - ~A~%" (chicken-version #t))
1355         (exit) )
1356        (("-release" . _)
1357         (print (chicken-version))
1358         (exit) )
1359        (("-script" filename . args)
1360         (command-line-arguments args)
1361         (load filename) 
1362         (exit) )
1363        (("-eval" expr . more)
1364         (eval `(begin ,@(with-input-from-string expr read-file))) 
1365         (set! anydone #t)
1366         (loop more) )
1367        (("-fetch" . more)
1368         (set! *fetch-only* #t)
1369         (set! *keep-stuff* #t)
1370         (loop more) )
1371        (("-host" host . more)
1372         (match (string-match "http://(.*)" host)
1373           ((_ host) (parse-host host #t) )
1374           (_ (parse-host host #t)) )
1375         (loop more) )
1376        (("-proxy" proxy . more)
1377         (match (string-match "(.+)\\:([0-9]+)" proxy)
1378           ((_ proxy port) (set! *proxy-host* proxy) (set! *proxy-port* (string->number port)))
1379           (_ (set! *proxy-host* proxy) (set! *proxy-port* 80)) )
1380         (loop more) )
1381        (("-keep" . more)
1382         (set! *keep-stuff* #t)
1383         (set! *csc-options* (append *csc-options* (list "-k")))
1384         (loop more) )
1385        (("-verbose" . more)
1386         (setup-verbose-flag #t)
1387         (set! *csc-options* (append *csc-options* (list "-v")))
1388         (loop more) )
1389        (("-csc-option" opt . more)
1390         (set! *csc-options* (append *csc-options* (list opt)))
1391         (loop more) )
1392        (("-ls" ext . more)
1393         (and-let* ((info (extension-information ext))
1394                    (files (assq 'files info)) )
1395           (for-each print (cdr files) ) )
1396         (exit) )
1397        (("-dont-ask" . more)
1398         (set! *dont-ask* #t)
1399         (loop more) )
1400        (("-no-install" . more)
1401         (setup-install-flag #f)
1402         (set! *keep-stuff* #t)
1403         (loop more) )
1404        (("-docindex" . more)
1405         (let ((di (doc-index #t)))
1406           (unless (file-exists? di)
1407             (build-doc-index) )
1408           (print di) ) )
1409        (("-debug" . more)
1410         (set! *debug* #t)
1411         (loop more) )
1412        (("-revision" rev . more)
1413         (set! *revision* rev)
1414         (loop more) )
1415        (("-svn" url . more)
1416         (set! *svn-repository* url)
1417         (set! *dont-ask* #t)
1418         (loop more) )
1419        (("-test" . more)
1420         (set! *run-tests* #t)
1421         (loop more) )
1422        (("-local" path . more)
1423         (set! *local-repository* path)
1424         (set! *dont-ask* #t)
1425         (loop more) )
1426        (("-create-tree" dir . more)
1427         (create-repository-file dir)
1428         (set! anydone #t)
1429         (loop more) )
1430        (("-fetch-tree" . more)
1431         (set! *fetch-tree-only* #t)
1432         (set! anydone #t)
1433         (loop more) )
1434        (("-host-extension" . more)
1435         (host-extension #t)
1436         (loop more) )
1437        (((or "-run" "-script" "-proxy" "-host" "-csc-option" "-ls" "-install-prefix" 
1438              "-tree" "-local" "-svn" "-eval" "-create-tree" "-build-prefix" "-download-dir"))
1439         (error "missing option argument" (car args)) )
1440        ((filename . more)
1441         (cond ((and (> (string-length filename) 0) (char=? #\- (string-ref filename 0)))
1442                (let ((os (string->list (substring filename 1))))
1443                  (if (every (cut memq <> short-options) os)
1444                      (loop 
1445                       (append
1446                        (map (lambda (s) (list-ref long-options (list-index (cut eq? <> s) short-options))) os)
1447                        more) )
1448                      (error "invalid option" filename) ) ) )
1449               (else
1450                (set! anydone #t)
1451                ((if uinst uninstall-extension install)
1452                 (match (string-match "http://([^/]+)/(.+)" filename)
1453                   ((_ host path)
1454                    (parse-host host #f)
1455                    (set! *dont-ask* #t)
1456                    (conc "/" path) )
1457                   (_ filename)) )
1458                (loop more) ) ) )
1459        (()
1460         (unless anydone
1461           (let ((setups (glob "*.setup")))
1462             (if (null? setups)
1463                 (printf "No setup scripts to process~%")
1464                 (for-each (if uinst uninstall-extension install) setups) ) ) )
1465         (when *fetch-tree-only*
1466           (download-repository-tree)
1467           (pp *repository-tree*) )
1468         (when *rebuild-doc-index*
1469           (when (setup-verbose-flag) (printf "Rebuilding documentation index...\n"))
1470           (build-doc-index) )
1471         (unless *keep-stuff*
1472           (for-each
1473            (lambda (f)
1474              (run (,*remove-command* ,(quotewrap f))) )
1475            *fetched-eggs*))
1476         #f) ) ) ) )
1477
1478(handle-exceptions ex 
1479    (begin
1480      (print-error-message ex)
1481      (exit -1) )
1482  (call/cc
1483   (lambda (return)
1484     (set! *abort-hook* return)
1485     (main (append (string-split (or (getenv "CHICKEN_SETUP_OPTIONS") ""))
1486                   (command-line-arguments) ) ) ) )
1487  (clear-builddir) )
Note: See TracBrowser for help on using the repository browser.