source: project/chicken/branches/hygienic/chicken-status.scm @ 11966

Last change on this file since 11966 was 11966, checked in by felix winkelmann, 11 years ago

bugfix in setup-download module

File size: 3.9 KB
Line 
1;;;; chicken-status.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 files)
28
29
30(module main ()
31 
32  (import scheme chicken)
33  (import setup-utils srfi-1 posix data-structures utils ports regex
34          files)
35
36  (define (gather-eggs patterns)
37    (let ((eggs (map pathname-file 
38                     (glob (make-pathname (repository-path) "*" "setup-info")))))
39      (delete-duplicates
40       (concatenate (map (cut grep <> eggs) patterns))
41       string=?)))
42
43  (define (list-installed-eggs eggs)
44    (let ((w (quotient (- (get-terminal-width) 2) 2)))
45      (for-each
46       (lambda (egg)
47         (let ((version (assq 'version (read-info egg))))
48           (if version
49               (print
50                (format-string (string-append egg " ") w #f #\.)
51                (format-string 
52                 (string-append " version: " (->string (cadr version)))
53                 w #t #\.))
54               (print egg))))
55       (sort eggs string<?))))
56
57  (define (list-installed-files eggs)
58    (for-each
59     print
60     (sort
61      (append-map
62       (lambda (egg)
63         (let ((files (assq 'files (read-info egg))))
64           (if files
65               (cdr files)
66               '())))
67       eggs)
68      string<?)))
69
70  (define (usage code)
71    (print #<<EOF
72usage: chicken-status [OPTION | PATTERN] ...
73
74  -h   -help                    show this message
75  -v   -version                 show version and exit
76  -f   -files                   list installed files
77EOF
78);|
79    (exit code))
80
81  (define *short-options* '(#\h #\f))
82
83  (define (main args)
84    (let ((files #f))
85      (let loop ((args args) (pats '()))
86        (if (null? args)
87            (let ((eggs (gather-eggs (if (null? pats) '(".*") pats))))
88              (if (null? eggs)
89                  (print "(none)")
90                  ((if files list-installed-files list-installed-eggs)
91                   eggs)))
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 "-f") (string=? arg "-files"))
98                     (set! files #t)
99                     (loop (cdr args) pats))
100                    ((or (string=? arg "-v") (string=? arg "-version"))
101                     (print (chicken-version))
102                     (exit 0))
103                    ((and (positive? (string-length arg))
104                          (char=? #\- (string-ref arg 0)))
105                     (if (> (string-length arg) 2)
106                         (let ((sos (string->list (substring arg 1))))
107                           (if (null? (lset-intersection eq? *short-options* sos))
108                               (loop (append (map (cut string #\- <>) sos) (cdr args)) pats)
109                               (usage 1)))
110                         (usage 1)))
111                    (else (loop (cdr args) (cons arg pats)))))))))
112
113  (main (command-line-arguments))
114 
115 )
Note: See TracBrowser for help on using the repository browser.