source: project/chicken/trunk/setup-utils.scm @ 12700

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

removed remaining support for DJGPP, Metrowerks and Watcom

File size: 4.8 KB
Line 
1;;;; setup-utils.scm
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 regex utils ports tcp extras posix files
28                 srfi-1 srfi-13 data-structures)
29
30
31(module setup-utils (version>=?
32                     create-temporary-directory
33                     remove-directory
34                     yes-or-no?
35                     get-terminal-width
36                     format-string
37                     remove-file
38                     remove-extension
39                     read-info)
40 
41  (import scheme chicken)
42  (import regex utils ports tcp extras posix srfi-1 srfi-13 
43          data-structures files)
44
45  (define (version>=? v1 v2)
46    (define (version->list v)
47      (map (lambda (x) (or (string->number x) x))
48           (string-split-fields "[-\\._]" v #:infix)))
49    (let loop ((p1 (version->list v1))
50               (p2 (version->list v2)))
51      (cond ((null? p1) (null? p2))
52            ((null? p2))
53            ((number? (car p1))
54             (and (if (number? (car p2))
55                      (>= (car p1) (car p2))
56                      (string>=? (number->string (car p1)) (car p2)))
57                  (loop (cdr p1) (cdr p2))))
58            ((number? (car p2))
59             (and (string>=? (car p1) (number->string (car p2)))
60                  (loop (cdr p1) (cdr p2))))
61            ((string>=? (car p1) (car p2)) (loop (cdr p1) (cdr p2)))
62            (else #f))))
63
64  (define (format-string str cols #!optional right (padc #\space))
65    (let* ((len (string-length str))
66           (pad (make-string (fxmax 0 (fx- cols len)) padc)) )
67      (if right
68          (string-append pad str)
69          (string-append str pad) ) ) )
70
71  (define get-terminal-width
72    (let ((default-width 80))        ; Standard default terminal width
73      (lambda ()
74        (let ((cop (current-output-port)))
75          (if (terminal-port? cop)
76              (let ((w (nth-value 1 (terminal-size cop))))
77                (if (zero? w) default-width w))
78              default-width)))))
79
80  (define (read-info egg)
81    (with-input-from-file
82     (make-pathname (repository-path) egg ".setup-info")
83     read))
84
85  (define (create-temporary-directory)
86    (let ((dir (or (getenv "TMPDIR") (getenv "TEMP") (getenv "TMP") "/tmp")))
87      (let loop ()
88        (let* ((n (##sys#fudge 16))     ; current milliseconds
89               (pn (make-pathname dir (string-append "setup-" (number->string n 16)) "tmp")))
90          (cond ((file-exists? pn) (loop))
91                (else (create-directory pn) pn))))))
92
93  (define (remove-directory dir #!optional sudo)
94    (if sudo
95        (system* "sudo rm -fr '~a'" dir)
96        (let walk ((dir dir))
97          (let ((files (directory dir #t)))
98            (for-each
99             (lambda (f)
100               (unless (or (string=? "." f) (string=? ".." f))
101                 (let ((p (make-pathname dir f)))
102                   (if (directory? p)
103                       (walk p) 
104                       (delete-file p)))))
105             files)
106            (delete-directory dir)))) )
107
108  (define (yes-or-no? str #!key default (abort (cut signal 'aborted)))
109    (let loop ()
110      (printf "~%~A (yes/no/abort) " str)
111      (when default (printf "[~A] " default))
112      (flush-output)
113      (let ((ln (read-line)))
114        (cond ((eof-object? ln) (set! ln "abort"))
115              ((and default (string=? "" ln)) (set! ln default)) )
116        (cond ((string-ci=? "yes" ln) #t)
117              ((string-ci=? "no" ln) #f)
118              ((string-ci=? "abort" ln) (abort))
119              (else
120               (printf "~%Please enter \"yes\", \"no\" or \"abort\".~%")
121               (loop) ) ) ) ) )
122 
123  (define (remove-extension egg #!optional sudo)
124    (and-let* ((files (assq 'files (read-info egg))))
125      (for-each (cut remove-file <> sudo) (cdr files)))
126    (remove-file (make-pathname (repository-path) egg "setup-info") sudo))
127
128  (define (remove-file path #!optional sudo)
129    (if sudo
130        (system* "sudo rm -f '~a'" path)
131        (delete-file* path)))
132
133)
Note: See TracBrowser for help on using the repository browser.