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

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

merged changes from trunk (rev 6579)

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