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

Last change on this file since 13138 was 13138, checked in by Kon Lovett, 11 years ago

Chgd "can not" to "cannot" - saves bytes you know ;-)

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