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

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

actually removed the options

File size: 4.5 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
93EOF
94);|
95    (exit code))
96
97  (define *short-options* '(#\h #\f))
98
99  (define (main args)
100    (let ((files #f))
101      (let loop ((args args) (pats '()))
102        (if (null? args)
103            (let ((eggs (gather-eggs (if (null? pats) '(".*") pats))))
104              (if (null? eggs)
105                  (print "(none)")
106                  ((if files list-installed-files list-installed-eggs)
107                   eggs)))
108            (let ((arg (car args)))
109              (cond ((or (string=? arg "-help") 
110                         (string=? arg "-h")
111                         (string=? arg "--help"))
112                     (usage 0))
113                    ((or (string=? arg "-f") (string=? arg "-files"))
114                     (set! files #t)
115                     (loop (cdr args) pats))
116                    ((or (string=? arg "-v") (string=? arg "-version"))
117                     (print (chicken-version))
118                     (exit 0))
119                    ((and (positive? (string-length arg))
120                          (char=? #\- (string-ref arg 0)))
121                     (if (> (string-length arg) 2)
122                         (let ((sos (string->list (substring arg 1))))
123                           (if (null? (lset-intersection eq? *short-options* sos))
124                               (loop (append (map (cut string #\- <>) sos) (cdr args)) pats)
125                               (usage 1)))
126                         (usage 1)))
127                    (else (loop (cdr args) (cons arg pats)))))))))
128
129  (main (command-line-arguments))
130 
131 )
Note: See TracBrowser for help on using the repository browser.