source: project/chicken/branches/beyond-hope/chicken-setup.scm @ 10439

Last change on this file since 10439 was 10439, checked in by felix winkelmann, 13 years ago

painfully slowly debugging compiler

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