source: project/chicken/trunk/setup-api.scm @ 15000

Last change on this file since 15000 was 15000, checked in by felix winkelmann, 11 years ago

renamed setup-{install,verbose}-flag to ...-mode; old names are still available, but deprecated

File size: 25.1 KB
Line 
1;;;; setup-api.scm - build + installation API for eggs
2;
3; Copyright (c) 2008-2009, The Chicken Team
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
27(require-library srfi-1 regex utils posix srfi-13 extras ports data-structures files)
28
29; This code is partially quite messy and the API is not overly consistent,
30; mainly because it has grown "organically" while the old chicken-setup program
31; evolved. The code was extracted and put into this module, without much
32; cleaning up. Nevertheless, it should work.
33
34(module setup-api
35
36    (move-file 
37     (run execute)
38     compile
39     make make/proc
40     host-extension
41     install-extension install-program install-script
42     setup-verbose-mode setup-install-mode
43     setup-verbose-flag setup-install-flag                      ; DEPRECATED
44     installation-prefix chicken-prefix 
45     find-library find-header 
46     program-path remove-file* 
47     patch yes-or-no? abort-setup
48     setup-root-directory create-directory/parents
49     test-compile try-compile copy-file run-verbose
50     required-chicken-version required-extension-version cross-chicken
51     sudo-install keep-intermediates
52     version>=?
53     extension-name-and-version
54     extension-name
55     extension-version
56     create-temporary-directory
57     remove-directory
58     remove-extension
59     read-info
60     shellpath)
61 
62  (import scheme chicken foreign
63          regex utils posix ports extras data-structures
64          srfi-1 srfi-13 files)
65
66;;; Constants, variables and parameters
67
68(define-constant setup-file-extension "setup-info")
69
70(define *installed-executables* 
71  `(("chicken" . ,(foreign-value "C_CHICKEN_PROGRAM" c-string))
72    ("csc" . ,(foreign-value "C_CSC_PROGRAM" c-string))
73    ("csi" . ,(foreign-value "C_CSI_PROGRAM" c-string))
74    ("chicken-bug" . ,(foreign-value "C_CHICKEN_BUG_PROGRAM" c-string))))
75
76(define *cc* (foreign-value "C_TARGET_CC" c-string))
77(define *cxx* (foreign-value "C_TARGET_CXX" c-string))
78(define *target-cflags* (foreign-value "C_TARGET_CFLAGS" c-string))
79(define *target-libs* (foreign-value "C_TARGET_MORE_LIBS" c-string))
80(define *target-lib-home* (foreign-value "C_TARGET_LIB_HOME" c-string))
81(define *sudo* #f)
82(define *windows-shell* (foreign-value "C_WINDOWS_SHELL" bool))
83
84(define *windows*
85  (and (eq? (software-type) 'windows) 
86       (build-platform) ) )
87
88(register-feature! 'chicken-setup)
89
90(define host-extension (make-parameter #f))
91
92(define *chicken-bin-path*
93  (or (and-let* ((p (getenv "CHICKEN_PREFIX")))
94        (make-pathname p "bin") )
95      (foreign-value "C_INSTALL_BIN_HOME" c-string) ) )
96
97(define *doc-path*
98  (or (and-let* ((p (getenv "CHICKEN_PREFIX")))
99        (make-pathname p "share/chicken/doc") )
100      (make-pathname
101       (foreign-value "C_INSTALL_SHARE_HOME" c-string) 
102       "doc")))
103
104(define chicken-prefix
105  (or (getenv "CHICKEN_PREFIX")
106      (let ((m (string-match "(.*)/bin/?" *chicken-bin-path*)))
107        (if m
108            (cadr m)
109            "/usr/local") ) ) )
110
111(define (shellpath str)
112  (qs (normalize-pathname str)))
113
114(define (cross-chicken) (##sys#fudge 39))
115
116(define *csc-options* '())
117(define *base-directory* (current-directory))
118
119(define setup-root-directory      (make-parameter *base-directory*))
120(define setup-verbose-mode        (make-parameter #f))
121(define setup-install-mode        (make-parameter #t))
122(define setup-verbose-flag setup-verbose-mode) ; DEPRECATED
123(define setup-install-flag setup-install-mode) ; DEPRECATED
124(define program-path              (make-parameter *chicken-bin-path*))
125(define keep-intermediates (make-parameter #f))
126
127; Setup shell commands
128
129(define *copy-command*)
130(define *remove-command*)
131(define *move-command*)
132(define *chmod-command*)
133(define *ranlib-command*)
134
135(define (windows-user-install-setup)
136  (set! *copy-command*        'copy)
137  (set! *remove-command*      "del /Q /S")
138  (set! *move-command*        'move)
139  (set! *chmod-command*       "chmod")
140  (set! *ranlib-command*      "ranlib") )
141
142(define (unix-user-install-setup)
143  (set! *copy-command*        "cp -r")
144  (set! *remove-command*      "rm -fr")
145  (set! *move-command*        'mv)
146  (set! *chmod-command*       "chmod")
147  (set! *ranlib-command*      "ranlib") )
148
149(define (windows-sudo-install-setup)
150  (set! *sudo* #f)
151  (print "Warning: cannot install as superuser with Windows") )
152
153(define (unix-sudo-install-setup)
154  (set! *copy-command*        "sudo cp -r")
155  (set! *remove-command*      "sudo rm -fr")
156  (set! *move-command*        "sudo mv")
157  (set! *chmod-command*       "sudo chmod")
158  (set! *ranlib-command*      "sudo ranlib") )
159
160(define (user-install-setup)
161  (set! *sudo* #f)
162  (if *windows-shell*
163      (windows-user-install-setup)
164      (unix-user-install-setup) ) )
165
166(define (sudo-install-setup)
167  (set! *sudo* #t)
168  (if *windows-shell*
169      (windows-sudo-install-setup)
170      (unix-sudo-install-setup) ) )
171
172(define (sudo-install . args)
173  (cond ((null? args)   *sudo*)
174        ((car args)     (sudo-install-setup))
175        (else           (user-install-setup)) ) )
176
177; User setup by default
178(user-install-setup)
179
180
181(define create-directory/parents
182  (let ()
183    (define create-directory-0
184      (let ([create-directory create-directory])
185        (lambda (dir)
186          (let loop ([dir dir])
187            (when (and dir (not (directory? dir)))
188              (loop (pathname-directory dir))
189              (create-directory dir))) ) ) )
190    (define (verb dir)
191      (when (setup-verbose-mode) (printf "  creating directory `~a'~%~!" dir)) )
192    (if *windows-shell*
193        (lambda (dir)
194          (verb dir)
195          (create-directory-0 dir) ) 
196        (lambda (dir)
197          (verb dir)
198          ($system (sprintf "mkdir -p ~a" (shellpath dir) ) ) ) ) ) )
199
200(define abort-setup (make-parameter exit))
201
202(define (yes-or-no? str #!key default (abort (abort-setup)))
203  (let loop ()
204    (printf "~%~A (yes/no/abort) " str)
205    (when default (printf "[~A] " default))
206    (flush-output)
207    (let ((ln (read-line)))
208      (cond ((eof-object? ln) (set! ln "abort"))
209            ((and default (string=? "" ln)) (set! ln default)) )
210      (cond ((string-ci=? "yes" ln) #t)
211            ((string-ci=? "no" ln) #f)
212            ((string-ci=? "abort" ln) (abort))
213            (else
214             (printf "~%Please enter \"yes\", \"no\" or \"abort\".~%")
215             (loop) ) ) ) ) )
216 
217(define (patch which rx subst)
218  (when (setup-verbose-mode) (printf "patching ~A ...~%" which))
219  (if (list? which)
220      (with-output-to-file (cadr which)
221       (lambda ()
222         (with-input-from-file (car which)
223           (lambda ()
224             (let loop ()
225               (let ((ln (read-line)))
226                 (unless (eof-object? ln)
227                   (write-line (string-substitute rx subst ln #t)) 
228                   (loop) ) ) ) ) ) ) )
229      (let ((tmp (create-temporary-file)))
230        (patch (list tmp tmp) rx subst)
231        ($system 
232         (sprintf "~A ~A ~A" *move-command* (shellpath tmp)
233                  (shellpath which))))))
234
235(define run-verbose (make-parameter #t))
236
237(define (fixpath prg)
238  (cond ((string=? prg "csc")
239         (string-intersperse 
240          (cons* (shellpath
241                  (make-pathname 
242                   *chicken-bin-path*
243                   (cdr (assoc prg *installed-executables*))))
244                 "-feature" "compiling-extension"
245                 (if (keep-intermediates) "-k" "")
246                 (if (host-extension) "-host" "")
247                 *csc-options*) 
248          " ") )
249        ((assoc prg *installed-executables*) =>
250         (lambda (a) (shellpath (make-pathname *chicken-bin-path* (cdr a)))))
251        (else prg) ) )
252
253(define (fixmaketarget file)
254  (if (and (equal? "so" (pathname-extension file))
255           (not (string=? "so" ##sys#load-dynamic-extension)) )
256      (pathname-replace-extension file ##sys#load-dynamic-extension)
257      file) )
258
259(define (execute explist)
260  (define (smooth lst)
261    (let ((slst (map ->string lst)))
262      (string-intersperse (cons (fixpath (car slst)) (cdr slst)) " ") ) )
263  (for-each
264   (lambda (cmd)
265     (when (run-verbose) (printf "  ~A~%~!" cmd))
266     ($system cmd))
267   (map smooth explist) ) )
268
269(define-syntax run
270  (syntax-rules ()
271    ((_ exp ...)
272     (execute (list `exp ...)))))
273
274(define-syntax compile
275  (syntax-rules ()
276    ((_ exp ...)
277     (run (csc exp ...)))))
278
279
280;;; "make" functionality
281
282(define (make:find-matching-line str spec)
283  (let ((match? (lambda (s) (string=? s str))))
284    (let loop ((lines spec))
285      (cond
286       ((null? lines) #f)
287       (else (let* ((line (car lines))
288                    (names (if (string? (car line))
289                               (list (car line))
290                               (car line))))
291               (if (any match? names)
292                   line
293                   (loop (cdr lines)))))))))
294
295(define (make:form-error s p) (error (sprintf "~a: ~s" s p)))
296(define (make:line-error s p n) (error (sprintf "~a: ~s for line: ~a" s p n)))
297
298(define (make:check-spec spec)
299  (and (or (list? spec) (make:form-error "specification is not a list" spec))
300       (or (pair? spec) (make:form-error "specification is an empty list" spec))
301       (every
302        (lambda (line)
303          (and (or (and (list? line) (<= 2 (length line) 3))
304                   (make:form-error "list is not a list with 2 or 3 parts" line))
305               (or (or (string? (car line))
306                       (and (list? (car line))
307                            (every string? (car line))))
308                   (make:form-error "line does not start with a string or list of strings" line))
309               (let ((name (car line)))
310                 (or (list? (cadr line))
311                     (make:line-error "second part of line is not a list" (cadr line) name)
312                     (every (lambda (dep)
313                               (or (string? dep)
314                                   (make:form-error "dependency item is not a string" dep)))
315                             (cadr line)))
316                 (or (null? (cddr line))
317                     (procedure? (caddr line))
318                     (make:line-error "command part of line is not a thunk" (caddr line) name)))))
319        spec)))
320
321(define (make:check-argv argv)
322  (or (string? argv)
323      (every string? argv)
324      (error "argument is not a string or string list" argv)))
325
326(define (make:make/proc/helper spec argv)
327  (when (vector? argv) (set! argv (vector->list argv)))
328  (make:check-spec spec)
329  (make:check-argv argv)
330  (letrec ((made '())
331           (exn? (condition-predicate 'exn))
332           (exn-message (condition-property-accessor 'exn 'message))
333           (make-file
334            (lambda (s indent)
335              (let* ((line (make:find-matching-line s spec))
336                     (s2 (fixmaketarget s)) 
337                     (date (and (file-exists? s2)
338                                (file-modification-time s2))))
339                (when (setup-verbose-mode)
340                  (printf "make: ~achecking ~a~%" indent s2))
341                (if line
342                    (let ((deps (cadr line)))
343                      (for-each (let ((new-indent (string-append " " indent)))
344                                  (lambda (d) (make-file d new-indent)))
345                                deps)
346                      (let ((reason
347                             (or (not date)
348                                 (any (lambda (dep)
349                                          (let ((dep2 (fixmaketarget dep)))
350                                            (unless (file-exists? dep2)
351                                              (error (sprintf "dependancy ~a was not made~%" dep2)))
352                                            (and (> (file-modification-time dep2) date)
353                                                 dep2)) )
354                                        deps))))
355                        (when reason
356                          (let ((l (cddr line)))
357                            (unless (null? l)
358                              (set! made (cons s made))
359                              (when (setup-verbose-mode)
360                                (printf "make: ~amaking ~a~a~%"
361                                        indent
362                                        s2
363                                        (cond
364                                         ((not date)
365                                          (string-append " because " s2 " does not exist"))
366                                         ((string? reason)
367                                          (string-append " because " reason " changed"))
368                                         (else
369                                          (string-append (sprintf " just because (reason: ~a date: ~a)" 
370                                                                  reason date)))) ) )
371                              (handle-exceptions exn
372                                  (begin
373                                    (printf "make: Failed to make ~a: ~a~%"
374                                            (car line)
375                                            (if (exn? exn)
376                                                (exn-message exn)
377                                                exn))
378                                    (signal exn) )
379                                ((car l))))))))
380                    (unless date
381                      (error (sprintf "don't know how to make ~a" s2))))))))
382    (cond
383     ((string? argv) (make-file argv ""))
384     ((null? argv) (make-file (caar spec) ""))
385     (else (for-each (lambda (f) (make-file f "")) argv)))
386    (when (setup-verbose-mode)
387      (for-each (lambda (item)
388                  (printf "make: made ~a~%" item))
389        (reverse made)))) )
390
391(define make/proc
392  (case-lambda
393   ((spec) (make:make/proc/helper spec '()))
394   ((spec argv)
395    (make:make/proc/helper
396     spec
397     (if (vector? argv)
398         (vector->list argv)
399         argv) ) ) ) )
400
401(define-syntax make
402  ;;XXX use er-macro-transformer
403  (lambda (form r c)
404    (##sys#check-syntax 'make form '(_ _ . #(_ 0 1)))
405    (let ((spec (cadr form))
406          (%list (r 'list))
407          (%lambda (r 'lambda)))
408      (let ((form-error (lambda (s . p) (apply error s spec p))))
409        (and (or (list? spec) (form-error "illegal specification (not a sequence)"))
410             (or (pair? spec) (form-error "empty specification"))
411             (every
412              (lambda (line)
413                (and (or (and (list? line) (>= (length line) 2))
414                         (form-error "clause does not have at least 2 parts" line))
415                     (let ((name (car line)))
416                       (or (list? (cadr line))
417                           (make:line-error "second part of clause is not a sequence" (cadr line) name)))))
418              spec))
419        `(,(r 'make/proc)
420          (list ,@(map (lambda (line)
421                         `(,%list ,(car line)
422                                  (,%list ,@(cadr line))
423                                  ,@(let ((l (cddr line)))
424                                      (if (null? l)
425                                          '()
426                                          `((,%lambda () ,@l))))))
427                       spec))
428          ,@(if (null? (cddr form))
429                '('())
430                (cddr form)))))))
431
432
433;;; Processing setup scripts
434
435(define (make-setup-info-pathname fn #!optional (rpath (repository-path)))
436  (make-pathname rpath fn setup-file-extension) )
437
438(define installation-prefix
439  (make-parameter (or (getenv "CHICKEN_INSTALL_PREFIX") #f)))
440
441(define (write-info id files info)
442  (let ((info `((files ,@files) 
443                ,@info)) )
444    (when (setup-verbose-mode) (printf "writing info ~A -> ~S ...~%" id info))
445    (let* ((sid (->string id))
446           (setup-file (make-setup-info-pathname sid (repo-path #t))))
447      (cond (*sudo*
448             (let ((tmp (create-temporary-file)))
449               (with-output-to-file tmp (cut pp info))
450               (run (,*move-command* ,(shellpath tmp) ,(shellpath setup-file)))))
451            (else (with-output-to-file setup-file (cut pp info))))
452      (unless *windows-shell* (run (,*chmod-command* a+r ,(shellpath setup-file)))))))
453
454(define (copy-file from to #!optional (err #t) (prefix (installation-prefix)))
455  ;;XXX the prefix handling is completely bogus
456  (let ((from (if (pair? from) (car from) from))
457        (to (let ((to-path (if (pair? from) (make-pathname to (cadr from)) to)))
458              (if (and prefix (not (string-prefix? prefix to-path)))
459                  (make-pathname prefix to-path) 
460                  to-path))))
461    (ensure-directory to)
462    (cond ((or (glob? from) (file-exists? from))
463           (begin
464             (run (,*copy-command* ,(shellpath from) ,(shellpath to))) 
465             to))
466          (err (error "file does not exist" from))
467          (else (warning "file does not exist" from)))))
468
469(define (move-file from to)
470  (let ((from  (if (pair? from) (car from) from))
471        (to    (if (pair? from) (make-pathname to (cadr from)) to)))
472    (ensure-directory to)
473    (run (,*move-command* ,(shellpath from) ,(shellpath to)) ) ) )
474
475(define (remove-file* dir)
476  (run (,*remove-command* ,(shellpath dir)) ) )
477
478(define (make-dest-pathname path file)
479  (if (list? file)
480      (make-dest-pathname path (cadr file))
481      (if (absolute-pathname? file)
482          file
483          (make-pathname path file) ) ) )
484
485(define (check-filelist flist)
486  (map (lambda (f)
487         (cond ((string? f) f)
488               ((and (list? f) (every string? f)) f)
489               ((and (pair? f) (list (car f) (cdr f))))
490               (else (error "invalid file-specification" f)) ) )
491       flist) )
492
493(define (translate-extension f #!optional default)
494  (pathname-replace-extension f
495   (let ((ext (pathname-extension f)))
496     (cond ((not ext) default)
497           ((equal? "so" ext) ##sys#load-dynamic-extension)
498           ((equal? "a" ext) (if *windows-shell* "lib" "a"))
499           (else ext)))))
500
501
502;;; Installation
503
504(define (install-extension id files #!optional (info '()))
505  (when (setup-install-mode)
506    (let* ((files (check-filelist (if (list? files) files (list files))))
507           (rpath (repo-path))
508           (rpathd (repo-path #t))
509           (dests (map (lambda (f)
510                         (let ((from (if (pair? f) (car f) f))
511                               (to (make-dest-pathname rpathd f)) )
512                           (when (and (not *windows*) 
513                                      (equal? "so" (pathname-extension to)))
514                             (run (,*remove-command* ,(shellpath to)) ))
515                           (copy-file from to)
516                           (unless *windows-shell*
517                             (run (,*chmod-command* a+r ,(shellpath to))))
518                           (and-let* ((static (assq 'static info)))
519                             (when (and (eq? (software-version) 'macosx)
520                                        (equal? (cadr static) from) 
521                                        (equal? (pathname-extension to) "a"))
522                               (run (,*ranlib-command* ,(shellpath to)) ) ))
523                           (make-dest-pathname rpath f)))
524                       files) ) 
525           (pre (installation-prefix))
526           (docpath (if pre
527                        (ensure-directory (make-pathname pre "share/chicken/doc"))
528                        *doc-path*)))
529      (and-let* ((docs (assq 'documentation info)))
530        (print "\n* Installing documentation files in " docpath ":")
531        (for-each
532         (lambda (f)
533           (copy-file f (make-pathname docpath f) #f) )
534         (cdr docs))
535        (newline))
536      (and-let* ((exs (assq 'examples info)))
537        (print "\n* Installing example files in " docpath ":")
538        (for-each
539         (lambda (f)
540           (let ((destf (make-pathname docpath f)))
541             (copy-file f destf #f)
542             (unless *windows-shell*
543               (run (,*chmod-command* a+rx ,destf)) ) ))
544         (cdr exs))
545        (newline))
546      (write-info id dests info) ) ) )
547
548(define (install-program id files #!optional (info '()))
549  (define (exify f)
550    (translate-extension
551     f
552     (if *windows-shell* "exe" #f) ) )
553  (when (setup-install-mode)
554    (let* ((files (check-filelist (if (list? files) files (list files))))
555           (ppath ((lambda (pre)
556                     (if pre 
557                         (ensure-directory (make-pathname pre "bin"))
558                         (program-path)))
559                   (installation-prefix)))
560           (files (if *windows*
561                      (map (lambda (f)
562                             (if (list? f) 
563                                 (list (exify (car f)) (exify (cadr f)))
564                                 (exify f) ) )
565                           files)
566                      files) ) 
567           (dests (map (lambda (f)
568                         (let ((from (if (pair? f) (car f) f))
569                               (to (make-dest-pathname ppath f)) )
570                           (copy-file from to) 
571                           (unless *windows-shell*
572                                   (run (,*chmod-command* a+r ,(shellpath to))))
573                           to) )
574                       files) ) )
575      (write-info id dests info) ) ) )
576
577(define (install-script id files #!optional (info '()))
578  (when (setup-install-mode)
579    (let* ((files (check-filelist (if (list? files) files (list files))))
580           (ppath ((lambda (pre) 
581                     (if pre
582                         (ensure-directory (make-pathname pre "bin"))
583                         (program-path)))
584                   (installation-prefix)))
585           (pfiles (map (lambda (f)
586                          (let ((from (if (pair? f) (car f) f))
587                                (to (make-dest-pathname ppath f)) )
588                            (copy-file from to) 
589                            (unless *windows-shell*
590                                    (run (,*chmod-command* a+r ,(shellpath to))))
591                            to) )
592                        files) ) )
593      (unless *windows-shell*
594        (run (,*chmod-command* a+rx ,(string-intersperse pfiles " "))) )
595      (write-info id pfiles info) ) ) )
596
597
598;;; More helper stuff
599
600(define (repo-path #!optional ddir?)
601  (let ((p (if (and ddir? (installation-prefix))
602               (make-pathname 
603                (installation-prefix) 
604                (sprintf "lib/chicken/~a" (##sys#fudge 42)))
605               (repository-path))) )
606    (ensure-directory p)
607    p) )
608
609(define (ensure-directory path)
610  (and-let* ((dir (pathname-directory path)))
611    (if (file-exists? dir)
612        (unless (directory? dir)
613          (error "cannot create directory: a file with the same name already exists") )
614        (begin
615          (create-directory/parents dir)
616          (unless *windows-shell*
617                  (run (,*chmod-command* a+x ,(shellpath dir)))))))
618  path)
619
620(define (try-compile code #!key c++ (cc (if c++ *cxx* *cc*)) (cflags "") (ldflags "") 
621                     (verb (setup-verbose-mode)) (compile-only #f))
622  (let* ((fname (create-temporary-file "c"))
623         (oname (pathname-replace-extension fname "o"))
624         (r (begin
625              (with-output-to-file fname (cut display code))
626              (system 
627               (let ((cmd (conc
628                           cc " "
629                           (if compile-only "-c" "") " "
630                           cflags " " *target-cflags* " "
631                           fname " "
632                           (if compile-only
633                               "" 
634                               (conc "-L" *target-lib-home* " " ldflags " " *target-libs*) )
635                           " >/dev/null "
636                           (if verb "" "2>&1") ) ) )
637                 (when verb (print cmd " ..."))
638                 cmd) ) ) ) )
639    (when verb (print (if (zero? r) "succeeded." "failed.")))
640    ($system (sprintf "~A ~A" *remove-command* (shellpath fname)))
641    (zero? r) ) )
642
643(define (required-chicken-version v)
644  (when (version>=? v (chicken-version) ) 
645    (error (sprintf "CHICKEN version ~a or higher is required" v)) ) )
646
647(define (upgrade-message ext msg)
648  (error
649   (sprintf
650    "the required extension `~s' ~a - please run~%~%  chicken-install ~a~%~%and repeat the current installation operation."
651    ext msg ext) ) )
652
653(define (required-extension-version . args)
654  (let loop ((args args))
655    (cond ((null? args) #f)
656          ((and (list? args) (>= (length args) 2))
657           (let* ((ext (car args))
658                  (version (cadr args))
659                  (more (cddr args))
660                  (info (extension-information ext)))
661             (if info
662                 (let ((ver (and (assq 'version info) (cadr (assq 'version info)))))
663                   (cond ((not ver) (upgrade-message ext "has no associated version information"))
664                         ((and (version>=? version ver) (not (string=? (->string version) (->string ver))))
665                          (upgrade-message 
666                           ext
667                           (sprintf "is older than ~a, which is what this extension requires"
668                                    version) ) )
669                         (else (loop more)) ) ) 
670                 (upgrade-message ext "is not installed") ) ) )
671          (else
672           (error 'required-extension-information "bad argument format" args)) ) ) )
673
674(define test-compile try-compile)
675
676(define (find-library name proc)
677  (test-compile 
678   (sprintf "#ifdef __cplusplus~%extern \"C\"~%#endif~%char ~a();~%int main() { ~a(); return 0; }~%" proc proc)
679   ldflags: (conc "-l" name) ) )
680
681(define (find-header name)
682  (test-compile
683   (sprintf "#include <~a>\nint main() { return 0; }\n" name)
684   compile-only: #t) )
685
686(define (version>=? v1 v2)
687  (define (version->list v)
688    (map (lambda (x) (or (string->number x) x))
689         (string-split-fields "[-\\._]" (->string v) #:infix)))
690  (let loop ((p1 (version->list v1))
691             (p2 (version->list v2)))
692    (cond ((null? p1) (null? p2))
693          ((null? p2))
694          ((number? (car p1))
695           (and (number? (car p2))
696                (or (> (car p1) (car p2))
697                    (and (= (car p1) (car p2))
698                         (loop (cdr p1) (cdr p2))))))
699          ((number? (car p2)))
700          ((string>? (car p1) (car p2)))
701          (else
702           (and (string=? (car p1) (car p2))
703                (loop (cdr p1) (cdr p2)))))))
704
705(define extension-name-and-version
706  (make-parameter '("" "")
707    (lambda (x)
708      (cond [(or (not x) (null? x))
709             '("" "") ]
710            [(and (list? x) (= 2 (length x)))
711             (let ([nam (car x)]
712                   [ver (cadr x)]
713                   [ensure-string (lambda (x) (if (or (not x) (null? x)) "" (->string x)))])
714               (list (ensure-string nam) (ensure-string ver)) ) ]
715            [else
716             (warning "invalid extension-name-and-version" x)
717             (extension-name-and-version) ] ) ) ) )
718
719(define (extension-name)
720  (car (extension-name-and-version)) )
721
722(define (extension-version #!optional defver)
723  (let ([ver (cadr (extension-name-and-version))])
724    (if (string-null? ver)
725        (and defver (->string defver))
726        ver ) ) )
727
728(define (read-info egg)
729  (with-input-from-file
730      (make-pathname (repository-path) egg ".setup-info")
731    read))
732
733(define (create-temporary-directory)
734  (let ((dir (or (getenv "TMPDIR") (getenv "TEMP") (getenv "TMP") "/tmp")))
735    (let loop ()
736      (let* ((n (##sys#fudge 16))       ; current milliseconds
737             (pn (make-pathname dir (string-append "chicken-install-" (number->string n 16)) "tmp")))
738        (cond ((file-exists? pn) (loop))
739              (else (create-directory pn) pn))))))
740
741(define (remove-directory dir #!optional (strict #t))
742  (cond ((not (file-exists? dir))
743         (if strict
744             (error 'remove-directory "cannot remove - directory not found" dir)
745             #f))
746        (*sudo*
747         ($system (sprintf "sudo rm -fr ~a" (shellpath dir))))
748        (else
749         (let walk ((dir dir))
750           (let ((files (directory dir #t)))
751             (for-each
752              (lambda (f)
753                (unless (or (string=? "." f) (string=? ".." f))
754                  (let ((p (make-pathname dir f)))
755                    (if (directory? p)
756                        (walk p) 
757                        (delete-file p)))))
758              files)
759             (delete-directory dir)))) ))
760
761(define (remove-extension egg)
762  (and-let* ((files (assq 'files (read-info egg))))
763    (for-each remove-file* (cdr files)))
764  (remove-file* (make-pathname (repository-path) egg "setup-info")))
765
766(define ($system str)
767  (let ((r (system
768            (if *windows-shell*
769                (string-append "\"" str "\"")   ; double quotes, yes - thanks to Matthew Flatt
770                str))))
771    (unless (zero? r)
772      (error "shell command failed with nonzero exit status" r str))))
773
774)
Note: See TracBrowser for help on using the repository browser.