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

Last change on this file since 12608 was 12608, checked in by Kon Lovett, 12 years ago

Bug fix for sudo install mode - inconsitent signature for 'sudo-install' & didn't set the *sudo* flag.

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