source: project/chicken/branches/inlining/setup-api.scm @ 15323

Last change on this file since 15323 was 15323, checked in by felix winkelmann, 10 years ago

more intelligent inlining; standard-extension procedure in setup-api

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