source: project/chicken/branches/hygienic/chicken-setup.scm @ 11646

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

merged with trunk rev. 11635; compiler bugfix; added files import lib

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