| 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 | ) |