source: project/chicken/branches/prerelease/utils.scm @ 13240

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

merged trunk svn rev. 13239 into prerelease

File size: 7.9 KB
Line 
1;;;; utils.scm - Utilities for scripting and file stuff
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29  (unit utils)
30  (uses regex data-structures extras files srfi-13)
31  (usual-integrations)
32  (fixnum)
33  (hide chop-pds)
34  (disable-interrupts) )
35
36(cond-expand
37 [paranoia]
38 [else
39  (declare
40    (always-bound
41      ##sys#windows-platform)
42    (bound-to-procedure
43      string-search string-match regexp regexp-escape
44      ##sys#symbol-has-toplevel-binding? ##sys#environment-symbols
45      ##sys#hash-table-for-each ##sys#macro-environment
46      ##sys#string-append reverse port? read-string with-input-from-file command-line-arguments
47      for-each-line ##sys#check-port read-line getenv make-pathname file-exists? call-with-output-file
48      decompose-pathname absolute-pathname? string-append ##sys#substring
49      delete-file system)
50    (no-procedure-checks-for-usual-bindings)
51    (no-bound-checks))] )
52
53(include "unsafe-declarations.scm")
54
55(register-feature! 'utils)
56
57
58;;; Environment utilities
59
60(define ##sys#apropos-interned)
61(define ##sys#apropos-macros)
62(let ([string-search string-search]
63      [regexp regexp]
64      [regexp-escape regexp-escape])
65  (let ([makpat
66         (lambda (patt)
67           (when (symbol? patt)
68             (set! patt (symbol->string patt)))
69           (when (string? patt)
70             (set! patt (regexp (regexp-escape patt))))
71           patt)])
72
73    (set! ##sys#apropos-interned
74      (lambda (patt env)
75        (set! patt (makpat patt))
76        (##sys#environment-symbols env
77          (lambda (sym)
78            (and (string-search patt (symbol->string sym))
79                 (##sys#symbol-has-toplevel-binding? sym) ) ) ) ) )
80
81    (set! ##sys#apropos-macros
82      (lambda (patt env) ; env is currently ignored
83        (set! patt (makpat patt))
84        (let ([ms '()])
85          (for-each
86           (lambda (a)
87             (let ((key (car a)))
88               (when (string-search patt (symbol->string key))
89                 (set! ms (cons key ms)) ) ) )
90           (##sys#macro-environment))
91          ms ) ) ) ) )
92
93(define (##sys#apropos patt env #!optional macf)
94  (let ([ts (##sys#apropos-interned patt env)])
95    (if macf
96        (##sys#append ts (##sys#apropos-macros patt env))
97        ts ) ) )
98
99(define apropos-list)
100(define apropos)
101(let ([%apropos-list
102        (lambda (loc patt args) ; #!optional (env (interaction-environment)) #!key macros?
103          (let ([env (interaction-environment)]
104                [macros? #f])
105            ; Handle extended lambda list optional & rest w/ keywords
106            (let loop ([args args])
107              (when (pair? args)
108                (let ([arg (car args)])
109                  (if (eq? #:macros? arg)
110                      (begin
111                        (set! macros? (cadr args))
112                        (loop (cddr args)) )
113                      (begin
114                        (set! env arg)
115                        (loop (cdr args)) ) ) ) ) )
116            (##sys#check-structure env 'environment loc)
117            (unless (or (string? patt) (symbol? patt) (regexp? patt))
118              (##sys#signal-hook #:type-error loc "bad argument type - not a string, symbol, or regexp" patt))
119            (##sys#apropos patt env macros?) ) )]
120      [disp-proc
121        (lambda (proc labl)
122          (let ([info (procedure-information proc)])
123            (cond [(pair? info) (display (cons labl (cdr info)))]
124                  [info         (display labl)]
125                  [else         (display labl) ] ) ) ) ]
126      [symlen
127        (lambda (sym)
128          (let ([len (##sys#size (##sys#symbol->qualified-string sym))])
129            (if (keyword? sym)
130                (fx- len 2) ; compensate for leading '###' when only a ':' is printed
131                len ) ) )])
132
133  (set! apropos-list
134    (lambda (patt . rest)
135      (%apropos-list 'apropos-list patt rest)))
136
137  (set! apropos
138    (lambda (patt . rest)
139      (let ([ss (%apropos-list 'apropos patt rest)]
140            [maxlen 0])
141        (for-each
142          (lambda (sym)
143            (set! maxlen (fxmax maxlen (symlen sym))))
144          ss)
145        (for-each
146          (lambda (sym)
147            (display sym)
148            (do ([i (fx- maxlen (symlen sym)) (fx- i 1)])
149                [(fx<= i 0)]
150              (display #\space))
151            (display #\space) (display #\:) (display #\space)
152            (if (macro? sym)
153                ;FIXME want to display macro lambda arguments
154                (display 'macro)
155                (let ([bnd (##core#inline "C_retrieve" sym)])
156                  (cond [(procedure? bnd)
157                          (disp-proc bnd 'procedure)]
158                        [else
159                          (display 'variable)]) ) )
160            (newline) )
161          ss)))) )
162
163
164;;; Like `system', but allows format-string and bombs on nonzero return code:
165
166(define system*
167  (let ([sprintf sprintf]
168        [system system] )
169    (lambda (fstr . args)
170      (let* ([str (apply sprintf fstr args)]
171             [n (system str)] )
172        (unless (zero? n)
173          (##sys#error "shell invocation failed with non-zero return status" str n) ) ) ) ) )
174
175
176;;; Handy I/O procedures:
177
178(define for-each-line
179  (let ([read-line read-line])
180    (lambda (proc . port)
181      (let ([port (if (pair? port) (car port) ##sys#standard-input)])
182        (##sys#check-port port 'for-each-line)
183        (let loop ()
184          (let ([ln (read-line port)])
185            (unless (eof-object? ln)
186              (proc ln)
187              (loop) ) ) ) ) ) ) )
188
189
190;; This one is from William Annis:
191
192(define (for-each-argv-line thunk)
193  (define (file-iterator file thunk)
194    (if (string=? file "-")
195        (for-each-line thunk)
196        (with-input-from-file file (cut for-each-line thunk) ) ) )
197  (let ((args (command-line-arguments)))
198    (if (null? args)
199        ;; If no arguments, take from stdin,
200        (for-each-line thunk)
201        ;; otherwise, hit each file named in argv.
202        (for-each (lambda (arg) (file-iterator arg thunk)) args))))
203
204
205;;; Read file as string from given filename or port:
206
207(define (read-all . file)
208  (let ([file (optional file ##sys#standard-input)])
209    (if (port? file)
210        (read-string #f file)
211        (with-input-from-file file (cut read-string #f)) ) ) )
212
213
214;;; Quote string for shell
215
216(define (qs str #!optional (platform (build-platform)))
217  (case platform
218    ((mingw32 msvc)
219     (string-append "\"" str "\""))
220    (else
221     (if (zero? (string-length str))
222         "''"
223         (string-concatenate
224          (map (lambda (c)
225                 (if (or (char-whitespace? c)
226                         (memq c '(#\# #\" #\' #\` # #\~ #\& #\% #\$ #\! #\* #\; #\< #\> #\\
227                                   #\( #\) #\[ #\] #\{ #\})))
228                     (string #\\ c)
229                     (string c)))
230               (string->list str)))))))
Note: See TracBrowser for help on using the repository browser.