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

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

Merged with trunk up to r9887 (dev snapshot 3.0.10).

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