source: project/chicken/trunk/chicken-status.scm @ 12819

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

build bugfixes (thanks to Wietse Jacobs); added -repository option to setup tools

File size: 4.7 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-api srfi-1 posix data-structures utils ports regex files)
28
29
30(module main ()
31 
32  (import scheme chicken)
33  (import srfi-1 posix data-structures utils ports regex
34          files setup-api)
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 (format-string str cols #!optional right (padc #\space))
44    (let* ((len (string-length str))
45           (pad (make-string (fxmax 0 (fx- cols len)) padc)) )
46      (if right
47          (string-append pad str)
48          (string-append str pad) ) ) )
49
50  (define get-terminal-width
51    (let ((default-width 80))        ; Standard default terminal width
52      (lambda ()
53        (let ((cop (current-output-port)))
54          (if (terminal-port? cop)
55              (let ((w (nth-value 1 (terminal-size cop))))
56                (if (zero? w) default-width w))
57              default-width)))))
58
59  (define (list-installed-eggs eggs)
60    (let ((w (quotient (- (get-terminal-width) 2) 2)))
61      (for-each
62       (lambda (egg)
63         (let ((version (assq 'version (read-info egg))))
64           (if version
65               (print
66                (format-string (string-append egg " ") w #f #\.)
67                (format-string 
68                 (string-append " version: " (->string (cadr version)))
69                 w #t #\.))
70               (print egg))))
71       (sort eggs string<?))))
72
73  (define (list-installed-files eggs)
74    (for-each
75     print
76     (sort
77      (append-map
78       (lambda (egg)
79         (let ((files (assq 'files (read-info egg))))
80           (if files
81               (cdr files)
82               '())))
83       eggs)
84      string<?)))
85
86  (define (usage code)
87    (print #<<EOF
88usage: chicken-status [OPTION | PATTERN] ...
89
90  -h   -help                    show this message
91  -v   -version                 show version and exit
92  -f   -files                   list installed files
93  -r   -repository DIRECTORY    specify alternative extension repository
94EOF
95);|
96    (exit code))
97
98  (define *short-options* '(#\h #\f))
99
100  (define (main args)
101    (let ((files #f))
102      (let loop ((args args) (pats '()))
103        (if (null? args)
104            (let ((eggs (gather-eggs (if (null? pats) '(".*") pats))))
105              (if (null? eggs)
106                  (print "(none)")
107                  ((if files list-installed-files list-installed-eggs)
108                   eggs)))
109            (let ((arg (car args)))
110              (cond ((or (string=? arg "-help") 
111                         (string=? arg "-h")
112                         (string=? arg "--help"))
113                     (usage 0))
114                    ((or (string=? arg "-f") (string=? arg "-files"))
115                     (set! files #t)
116                     (loop (cdr args) pats))
117                    ((or (string=? arg "-r") (string=? arg "-repository"))
118                     (if (pair? (cdr args))
119                         (repository-path (cadr args))
120                         (usage 1)))
121                    ((or (string=? arg "-v") (string=? arg "-version"))
122                     (print (chicken-version))
123                     (exit 0))
124                    ((and (positive? (string-length arg))
125                          (char=? #\- (string-ref arg 0)))
126                     (if (> (string-length arg) 2)
127                         (let ((sos (string->list (substring arg 1))))
128                           (if (null? (lset-intersection eq? *short-options* sos))
129                               (loop (append (map (cut string #\- <>) sos) (cdr args)) pats)
130                               (usage 1)))
131                         (usage 1)))
132                    (else (loop (cdr args) (cons arg pats)))))))))
133
134  (main (command-line-arguments))
135 
136 )
Note: See TracBrowser for help on using the repository browser.