1 | ;;;; chicken-uninstall.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 setup-utils srfi-1 posix data-structures utils ports regex srfi-13 |
---|
28 | files) |
---|
29 | |
---|
30 | |
---|
31 | (module main () |
---|
32 | |
---|
33 | (import scheme chicken) |
---|
34 | (import setup-utils srfi-1 posix data-structures utils ports regex srfi-13 files) |
---|
35 | |
---|
36 | (define *force* #f) |
---|
37 | (define *sudo* #f) |
---|
38 | |
---|
39 | (define (gather-eggs patterns) |
---|
40 | (let ((eggs (map pathname-file |
---|
41 | (glob (make-pathname (repository-path) "*" "setup-info"))))) |
---|
42 | (delete-duplicates |
---|
43 | (concatenate (map (cut grep <> eggs) patterns)) |
---|
44 | string=?))) |
---|
45 | |
---|
46 | (define (quit code) |
---|
47 | (print "aborted.") |
---|
48 | (exit code)) |
---|
49 | |
---|
50 | (define (ask eggs) |
---|
51 | (handle-exceptions ex |
---|
52 | (if (eq? ex 'aborted) |
---|
53 | (quit 1) |
---|
54 | (signal ex)) |
---|
55 | (yes-or-no? |
---|
56 | (string-concatenate |
---|
57 | (append |
---|
58 | '("About to delete the following extensions:\n\n") |
---|
59 | (map (cut string-append " " <> "\n") eggs) |
---|
60 | '("\nDo you want to proceed?"))) |
---|
61 | default: "no"))) |
---|
62 | |
---|
63 | (define (uninstall pats) |
---|
64 | (let ((eggs (gather-eggs pats))) |
---|
65 | (cond ((null? eggs) |
---|
66 | (print "nothing to remove.") ) |
---|
67 | ((or *force* (equal? eggs pats) (ask eggs)) |
---|
68 | (for-each |
---|
69 | (lambda (e) |
---|
70 | (print "removing " e) |
---|
71 | (remove-extension e *sudo*) ) |
---|
72 | eggs))))) |
---|
73 | |
---|
74 | (define (usage code) |
---|
75 | (print #<<EOF |
---|
76 | usage: chicken-uninstall [OPTION | PATTERN] ... |
---|
77 | |
---|
78 | -h -help show this message and exit |
---|
79 | -v -version show version and exit |
---|
80 | -force don't ask, delete whatever matches |
---|
81 | -s -sudo use sudo(1) for deleting files |
---|
82 | EOF |
---|
83 | );| |
---|
84 | (exit code)) |
---|
85 | |
---|
86 | (define *short-options* '(#\h #\s)) |
---|
87 | |
---|
88 | (define (main args) |
---|
89 | (let loop ((args args) (pats '())) |
---|
90 | (if (null? args) |
---|
91 | (uninstall (if (null? pats) (usage 1) (reverse pats))) |
---|
92 | (let ((arg (car args))) |
---|
93 | (cond ((or (string=? arg "-help") |
---|
94 | (string=? arg "-h") |
---|
95 | (string=? arg "--help")) |
---|
96 | (usage 0)) |
---|
97 | ((or (string=? arg "-v") (string=? arg "-version")) |
---|
98 | (print (chicken-version)) |
---|
99 | (exit 0)) |
---|
100 | ((string=? arg "-force") |
---|
101 | (set! *force* #t) |
---|
102 | (loop (cdr args) pats)) |
---|
103 | ((or (string=? arg "-s") (string=? arg "-sudo")) |
---|
104 | (set! *sudo* #t) |
---|
105 | (loop (cdr args) pats)) |
---|
106 | ((and (positive? (string-length arg)) |
---|
107 | (char=? #\- (string-ref arg 0))) |
---|
108 | (if (> (string-length arg) 2) |
---|
109 | (let ((sos (string->list (substring arg 1)))) |
---|
110 | (if (null? (lset-intersection eq? *short-options* sos)) |
---|
111 | (loop (append (map (cut string #\- <>) sos) (cdr args)) pats) |
---|
112 | (usage 1))) |
---|
113 | (usage 1))) |
---|
114 | (else (loop (cdr args) (cons arg pats)))))))) |
---|
115 | |
---|
116 | (main (command-line-arguments)) |
---|
117 | |
---|
118 | ) |
---|