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

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

setup-utils removal was quite incomplete; added -ignore-repository; msvc Makefile fix (thanks to Ivan Shcheklein); lots of mindless hacking

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