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

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

removed setup-utils (merged into setup-api)

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