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

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

applied readline-speedup patch by Jim Ursetto; chicken-install -prefix should work better

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