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 | ) |
---|