source: project/chicken/branches/release/chicken-setup.scm @ 7931

Last change on this file since 7931 was 7931, checked in by felix winkelmann, 12 years ago

merged from prerelease branch rev. 7930 - release version 3.0.0; fixed wrong version numbers in some files

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