Commit | Line | Data |
---|---|---|
9ddacf86 KN |
1 | ;;; "batch.scm" Group and execute commands on various systems. |
2 | ;Copyright (C) 1994, 1995, 1997 Aubrey Jaffer | |
3 | ; | |
4 | ;Permission to copy this software, to redistribute it, and to use it | |
5 | ;for any purpose is granted, subject to the following restrictions and | |
6 | ;understandings. | |
7 | ; | |
8 | ;1. Any copy made of this software must include this copyright notice | |
9 | ;in full. | |
10 | ; | |
11 | ;2. I have made no warrantee or representation that the operation of | |
12 | ;this software will be error-free, and I am under no obligation to | |
13 | ;provide any services, by way of maintenance, update, or otherwise. | |
14 | ; | |
15 | ;3. In conjunction with products arising from the use of this | |
16 | ;material, there shall be no use of my name in any advertising, | |
17 | ;promotional, or sales literature without prior written consent in | |
18 | ;each case. | |
19 | ||
20 | (require 'line-i/o) ;Just for write-line | |
21 | (require 'parameters) | |
22 | (require 'database-utilities) | |
23 | (require 'string-port) | |
24 | (require 'tree) | |
25 | ||
26 | (define system | |
27 | (if (provided? 'system) | |
28 | system | |
29 | (lambda (str) 1))) | |
30 | (define system:success? | |
31 | (case (software-type) | |
32 | ((VMS) (lambda (int) (eqv? 1 int))) | |
33 | (else zero?))) | |
34 | ;;(trace system system:success? exit quit slib:exit) | |
35 | ||
36 | (define (batch:port parms) | |
37 | (let ((bp (parameter-list-ref parms 'batch-port))) | |
38 | (cond ((or (not (pair? bp)) (not (output-port? (car bp)))) | |
39 | (slib:warn 'batch-line "missing batch-port parameter" bp) | |
40 | (current-output-port)) | |
41 | (else (car bp))))) | |
42 | ||
43 | (define (batch:dialect parms) ; was batch-family | |
44 | (car (parameter-list-ref parms 'batch-dialect))) | |
45 | ||
46 | (define (write-batch-line str line-limit port) | |
47 | (cond ((and line-limit (>= (string-length str) line-limit)) | |
48 | (slib:warn 'write-batch-line 'too-long | |
49 | (string-length str) '> line-limit) | |
50 | #f) | |
51 | (else (write-line str port) #t))) | |
52 | (define (batch-line parms str) | |
53 | (write-batch-line str (batch:line-length-limit parms) (batch:port parms))) | |
54 | ||
55 | ;;; add a Scheme batch-dialect? | |
56 | ||
57 | (define (batch:try-chopped-command parms . args) | |
58 | (define args-but-last (batch:flatten (butlast args 1))) | |
59 | (define line-limit (batch:line-length-limit parms)) | |
60 | (let loop ((fodder (car (last-pair args)))) | |
61 | (let ((str (batch:glued-line parms | |
62 | (batch:flatten | |
63 | (append args-but-last (list fodder)))))) | |
64 | (cond ((< (string-length str) line-limit) | |
65 | (batch:try-command parms str)) | |
66 | ((< (length fodder) 2) | |
67 | (slib:warn 'batch:try-chopped-command "can't fit in " line-limit | |
68 | (cons proc (append args-but-last (list fodder)))) | |
69 | #f) | |
70 | (else (let ((hlen (quotient (length fodder) 2))) | |
71 | (and (loop (last fodder hlen)) | |
72 | (loop (butlast fodder hlen))))))))) | |
73 | ||
74 | (define (batch:glued-line parms strings) | |
75 | (case (batch:dialect parms) | |
76 | ((vms) (apply string-join " " "$" strings)) | |
77 | ((unix dos amigados system *unknown*) (apply string-join " " strings)) | |
78 | (else #f))) | |
79 | ||
80 | (define (batch:try-command parms . strings) | |
81 | (set! strings (batch:flatten strings)) | |
82 | (let ((line (batch:glued-line parms strings))) | |
83 | (and line | |
84 | (case (batch:dialect parms) | |
85 | ((unix dos vms amigados) (batch-line parms line)) | |
86 | ((system) | |
87 | (let ((port (batch:port parms))) | |
88 | (write `(system ,line) port) (newline port) | |
89 | (and (provided? 'system) (system:success? (system line))))) | |
90 | ((*unknown*) | |
91 | (let ((port (batch:port parms))) | |
92 | (write `(system ,line) port) (newline port) #t)) | |
93 | (else #f))))) | |
94 | ||
95 | (define (batch:command parms . strings) | |
96 | (cond ((apply batch:try-command parms strings)) | |
97 | (else (slib:error 'batch:command 'failed strings)))) | |
98 | ||
99 | (define (batch:run-script parms name . strings) | |
100 | (case (batch:dialect parms strings) | |
101 | ((vms) (batch:command parms (string-append "@" name) strings)) | |
102 | (else (batch:command parms name strings)))) | |
103 | ||
104 | (define (batch:write-comment-line dialect line port) | |
105 | (case dialect | |
106 | ((unix) (write-batch-line (string-append "# " line) #f port)) | |
107 | ((dos) (write-batch-line (string-append "rem " line) #f port)) | |
108 | ((vms) (write-batch-line (string-append "$! " line) #f port)) | |
109 | ((amigados) (write-batch-line (string-append "; " line) #f port)) | |
110 | ((system) (write-batch-line (string-append "; " line) #f port)) | |
111 | ((*unknown*) (write-batch-line (string-append ";;; " line) #f port) | |
112 | ;;(newline port) | |
113 | #f))) | |
114 | ||
115 | (define (batch:comment parms . lines) | |
116 | (define port (batch:port parms)) | |
117 | (define dialect (batch:dialect parms)) | |
118 | (set! lines (batch:flatten lines)) | |
119 | (every (lambda (line) | |
120 | (batch:write-comment-line dialect line port)) | |
121 | lines)) | |
122 | ||
123 | (define (batch:lines->file parms file . lines) | |
124 | (define port (batch:port parms)) | |
125 | (set! lines (batch:flatten lines)) | |
126 | (case (or (batch:dialect parms) '*unknown*) | |
127 | ((unix) (batch-line parms (string-append "rm -f " file)) | |
128 | (every | |
129 | (lambda (string) | |
130 | (batch-line parms (string-append "echo '" string "'>>" file))) | |
131 | lines)) | |
132 | ((dos) (batch-line parms (string-append "DEL " file)) | |
133 | (every | |
134 | (lambda (string) | |
135 | (batch-line parms | |
136 | (string-append "ECHO" (if (equal? "" string) "." " ") | |
137 | string ">>" file))) | |
138 | lines)) | |
139 | ((vms) (and (batch-line parms (string-append "$DELETE " file)) | |
140 | (batch-line parms (string-append "$CREATE " file)) | |
141 | (batch-line parms (string-append "$DECK")) | |
142 | (every (lambda (string) (batch-line parms string)) | |
143 | lines) | |
144 | (batch-line parms (string-append "$EOD")))) | |
145 | ((amigados) (batch-line parms (string-append "delete force " file)) | |
146 | (every | |
147 | (lambda (str) | |
148 | (letrec ((star-quote | |
149 | (lambda (str) | |
150 | (if (equal? "" str) | |
151 | str | |
152 | (let* ((ch (string-ref str 0)) | |
153 | (s (if (char=? ch #\") | |
154 | (string #\* ch) | |
155 | (string ch)))) | |
156 | (string-append | |
157 | s | |
158 | (star-quote | |
159 | (substring str 1 (string-length str))))))))) | |
160 | (batch-line parms (string-append "echo \"" (star-quote str) | |
161 | "\" >> " file)))) | |
162 | lines)) | |
163 | ((system) (write `(delete-file ,file) port) (newline port) | |
164 | (delete-file file) | |
165 | (require 'pretty-print) | |
166 | (pretty-print `(call-with-output-file ,file | |
167 | (lambda (fp) | |
168 | (for-each | |
169 | (lambda (string) (write-line string fp)) | |
170 | ',lines))) | |
171 | port) | |
172 | (call-with-output-file file | |
173 | (lambda (fp) (for-each (lambda (string) (write-line string fp)) | |
174 | lines))) | |
175 | #t) | |
176 | ((*unknown*) | |
177 | (write `(delete-file ,file) port) (newline port) | |
178 | (require 'pretty-print) | |
179 | (pretty-print | |
180 | `(call-with-output-file ,file | |
181 | (lambda (fp) | |
182 | (for-each | |
183 | (lambda (string) | |
184 | (write-line string fp)) | |
185 | ,lines))) | |
186 | port) | |
187 | #f))) | |
188 | ||
189 | (define (batch:delete-file parms file) | |
190 | (define port (batch:port parms)) | |
191 | (case (batch:dialect parms) | |
192 | ((unix) (batch-line parms (string-append "rm -f " file)) | |
193 | #t) | |
194 | ((dos) (batch-line parms (string-append "DEL " file)) | |
195 | #t) | |
196 | ((vms) (batch-line parms (string-append "$DELETE " file)) | |
197 | #t) | |
198 | ((amigados) (batch-line parms (string-append "delete force " file)) | |
199 | #t) | |
200 | ((system) (write `(delete-file ,file) port) (newline port) | |
201 | (delete-file file)) ; SLIB provides | |
202 | ((*unknown*) (write `(delete-file ,file) port) (newline port) | |
203 | #f))) | |
204 | ||
205 | (define (batch:rename-file parms old-name new-name) | |
206 | (define port (batch:port parms)) | |
207 | (case (batch:dialect parms) | |
208 | ((unix) (batch-line parms (string-join " " "mv -f" old-name new-name))) | |
209 | ;;((dos) (batch-line parms (string-join " " "REN" old-name new-name))) | |
210 | ((dos) (batch-line parms (string-join " " "MOVE" "/Y" old-name new-name))) | |
211 | ((vms) (batch-line parms (string-join " " "$RENAME" old-name new-name))) | |
212 | ((amigados) (batch-line parms (string-join " " "failat 21")) | |
213 | (batch-line parms (string-join " " "delete force" new-name)) | |
214 | (batch-line parms (string-join " " "rename" old-name new-name))) | |
215 | ((system) (batch:extender 'rename-file batch:rename-file)) | |
216 | ((*unknown*) (write `(rename-file ,old-name ,new-name) port) | |
217 | (newline port) | |
218 | #f))) | |
219 | ||
220 | (define (batch:write-header-comment dialect name port) | |
221 | (batch:write-comment-line | |
222 | dialect | |
223 | (string-append (if (string? name) | |
224 | (string-append "\"" name "\"") | |
225 | (case dialect | |
226 | ((system *unknown*) "Scheme") | |
227 | ((vms) "VMS") | |
228 | ((dos) "DOS") | |
229 | ((default-for-platform) "??") | |
230 | (else (symbol->string dialect)))) | |
231 | " script created by SLIB/batch " | |
232 | (cond ((provided? 'bignum) | |
233 | (require 'posix-time) | |
234 | (let ((ct (ctime (current-time)))) | |
235 | (substring ct 0 (+ -1 (string-length ct))))) | |
236 | (else ""))) | |
237 | port)) | |
238 | ||
239 | (define (batch:call-with-output-script parms name proc) | |
240 | (define dialect (batch:dialect parms)) | |
241 | (case dialect | |
242 | ((unix) ((cond ((and (string? name) (provided? 'system)) | |
243 | (lambda (proc) | |
244 | (let ((ans (call-with-output-file name proc))) | |
245 | (system (string-append "chmod +x " name)) | |
246 | ans))) | |
247 | ((output-port? name) (lambda (proc) (proc name))) | |
248 | (else (lambda (proc) (proc (current-output-port))))) | |
249 | (lambda (port) | |
250 | (write-line "#!/bin/sh" port) | |
251 | (batch:write-header-comment dialect name port) | |
252 | (proc port)))) | |
253 | ||
254 | ((dos) ((cond ((string? name) | |
255 | (lambda (proc) | |
256 | (call-with-output-file (string-append name ".bat") proc))) | |
257 | ((output-port? name) (lambda (proc) (proc name))) | |
258 | (else (lambda (proc) (proc (current-output-port))))) | |
259 | (lambda (port) | |
260 | (batch:write-header-comment dialect name port) | |
261 | (proc port)))) | |
262 | ||
263 | ((vms) ((cond ((string? name) | |
264 | (lambda (proc) | |
265 | (call-with-output-file (string-append name ".COM") proc))) | |
266 | ((output-port? name) (lambda (proc) (proc name))) | |
267 | (else (lambda (proc) (proc (current-output-port))))) | |
268 | (lambda (port) | |
269 | (batch:write-header-comment dialect name port) | |
270 | ;;(write-line "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port) | |
271 | (proc port)))) | |
272 | ||
273 | ((amigados) ((cond ((and (string? name) (provided? 'system)) | |
274 | (lambda (proc) | |
275 | (let ((ans (call-with-output-file name proc))) | |
276 | (system (string-append "protect " name " rswd")) | |
277 | ans))) | |
278 | ((output-port? name) (lambda (proc) (proc name))) | |
279 | (else (lambda (proc) (proc (current-output-port))))) | |
280 | (lambda (port) | |
281 | (batch:write-header-comment dialect name port) | |
282 | (proc port)))) | |
283 | ||
284 | ((system) ((cond ((and (string? name) (provided? 'system)) | |
285 | (lambda (proc) | |
286 | (let ((ans (call-with-output-file name | |
287 | (lambda (port) (proc name))))) | |
288 | (system (string-append "chmod +x " name)) | |
289 | ans))) | |
290 | ((output-port? name) (lambda (proc) (proc name))) | |
291 | (else (lambda (proc) (proc (current-output-port))))) | |
292 | (lambda (port) | |
293 | (batch:write-header-comment dialect name port) | |
294 | (proc port)))) | |
295 | ||
296 | ((*unknown*) ((cond ((and (string? name) (provided? 'system)) | |
297 | (lambda (proc) | |
298 | (let ((ans (call-with-output-file name | |
299 | (lambda (port) (proc name))))) | |
300 | (system (string-append "chmod +x " name)) | |
301 | ans))) | |
302 | ((output-port? name) (lambda (proc) (proc name))) | |
303 | (else (lambda (proc) (proc (current-output-port))))) | |
304 | (lambda (port) | |
305 | (batch:write-header-comment dialect name port) | |
306 | (proc port)))))) | |
307 | ||
308 | ;;; This little ditty figures out how to use a Scheme extension or | |
309 | ;;; SYSTEM to execute a command that is not available in the batch | |
310 | ;;; mode chosen. | |
311 | ||
312 | (define (batch:extender NAME BATCHER) | |
313 | (lambda (parms . args) | |
314 | (define port (batch:port parms)) | |
315 | (cond | |
316 | ((provided? 'i/o-extensions) ; SCM specific | |
317 | (write `(,NAME ,@args) port) | |
318 | (newline port) | |
319 | (apply (slib:eval NAME) args)) | |
320 | ((not (provided? 'system)) #f) | |
321 | (else | |
322 | (let ((pl (make-parameter-list (map car parms)))) | |
323 | (adjoin-parameters! | |
324 | pl (cons 'batch-dialect (os->batch-dialect | |
325 | (parameter-list-ref parms 'platform)))) | |
326 | (system | |
327 | (call-with-output-string | |
328 | (lambda (port) | |
329 | (batch:call-with-output-script | |
330 | port | |
331 | (lambda (batch-port) | |
332 | (define new-parms (copy-tree pl)) | |
333 | (adjoin-parameters! new-parms (list 'batch-port batch-port)) | |
334 | (apply BATCHER new-parms args))))))))))) | |
335 | ||
336 | (define (truncate-up-to str chars) | |
337 | (define (tut str) | |
338 | (do ((i (string-length str) (+ -1 i))) | |
339 | ((or (zero? i) (memv (string-ref str (+ -1 i)) chars)) | |
340 | (substring str i (string-length str))))) | |
341 | (cond ((char? chars) (set! chars (list chars))) | |
342 | ((string? chars) (set! chars (string->list chars)))) | |
343 | (if (string? str) (tut str) (map tut str))) | |
344 | ||
345 | (define (must-be-first firsts lst) | |
346 | (append (remove-if-not (lambda (i) (member i lst)) firsts) | |
347 | (remove-if (lambda (i) (member i firsts)) lst))) | |
348 | ||
349 | (define (must-be-last lst lasts) | |
350 | (append (remove-if (lambda (i) (member i lasts)) lst) | |
351 | (remove-if-not (lambda (i) (member i lst)) lasts))) | |
352 | ||
353 | (define (string-join joiner . args) | |
354 | (if (null? args) "" | |
355 | (apply string-append | |
356 | (car args) | |
357 | (map (lambda (s) (string-append joiner s)) (cdr args))))) | |
358 | ||
359 | (define (batch:flatten strings) | |
360 | (apply | |
361 | append (map | |
362 | (lambda (obj) | |
363 | (cond ((eq? "" obj) '()) | |
364 | ((string? obj) (list obj)) | |
365 | ((eq? #f obj) '()) | |
366 | ((null? obj) '()) | |
367 | ((list? obj) (batch:flatten obj)) | |
368 | (else (slib:error 'batch:flatten "unexpected type" | |
369 | obj "in" strings)))) | |
370 | strings))) | |
371 | ||
372 | (define batch:platform (software-type)) | |
373 | (cond ((and (eq? 'unix batch:platform) (provided? 'system)) | |
374 | (let ((file-name (tmpnam))) | |
375 | (system (string-append "uname > " file-name)) | |
376 | (set! batch:platform (call-with-input-file file-name read)) | |
377 | (delete-file file-name)))) | |
378 | ||
379 | (define batch:database #f) | |
380 | (define os->batch-dialect #f) | |
381 | (define batch-dialect->line-length-limit #f) | |
382 | ||
383 | (define (batch:line-length-limit parms) | |
384 | (let ((bl (parameter-list-ref parms 'batch-line-length-limit))) | |
385 | (if bl (car bl) (batch-dialect->line-length-limit (batch:dialect parms))))) | |
386 | ||
387 | (define (batch:initialize! database) | |
388 | (set! batch:database database) | |
389 | (define-tables database | |
390 | ||
391 | '(batch-dialect | |
392 | ((family atom)) | |
393 | ((line-length-limit number)) | |
394 | ((unix 1023) | |
395 | (dos 127) | |
396 | (vms 1023) | |
397 | (amigados 511) | |
398 | (system 1023) | |
399 | (*unknown* -1))) | |
400 | ||
401 | '(operating-system | |
402 | ((name symbol)) | |
403 | ((os-family batch-dialect)) | |
404 | (;;(3b1 *unknown*) | |
405 | (*unknown* *unknown*) | |
406 | (acorn *unknown*) | |
407 | (aix unix) | |
408 | (alliant *unknown*) | |
409 | (amiga amigados) | |
410 | (apollo unix) | |
411 | (apple2 *unknown*) | |
412 | (arm *unknown*) | |
413 | (atari.st *unknown*) | |
414 | (cdc *unknown*) | |
415 | (celerity *unknown*) | |
416 | (concurrent *unknown*) | |
417 | (convex *unknown*) | |
418 | (encore *unknown*) | |
419 | (harris *unknown*) | |
420 | (hp-ux unix) | |
421 | (hp48 *unknown*) | |
422 | (irix unix) | |
423 | (isis *unknown*) | |
424 | (linux unix) | |
425 | (mac *unknown*) | |
426 | (masscomp unix) | |
427 | (mips *unknown*) | |
428 | (ms-dos dos) | |
429 | (ncr *unknown*) | |
430 | (newton *unknown*) | |
431 | (next unix) | |
432 | (novell *unknown*) | |
433 | (os/2 dos) | |
434 | (osf1 unix) | |
435 | (prime *unknown*) | |
436 | (psion *unknown*) | |
437 | (pyramid *unknown*) | |
438 | (sequent *unknown*) | |
439 | (sgi *unknown*) | |
440 | (stratus *unknown*) | |
441 | (sunos unix) | |
442 | (transputer *unknown*) | |
443 | (unicos unix) | |
444 | (unix unix) | |
445 | (vms vms) | |
446 | ))) | |
447 | ||
448 | ((database 'add-domain) '(operating-system operating-system #f symbol #f)) | |
449 | (set! os->batch-dialect (((batch:database 'open-table) 'operating-system #f) | |
450 | 'get 'os-family)) | |
451 | (set! batch-dialect->line-length-limit | |
452 | (((batch:database 'open-table) 'batch-dialect #f) | |
453 | 'get 'line-length-limit)) | |
454 | ) |