diff options
Diffstat (limited to 'batch.scm')
| -rw-r--r-- | batch.scm | 67 |
1 files changed, 46 insertions, 21 deletions
@@ -1,5 +1,5 @@ ;;; "batch.scm" Group and execute commands on various systems. -;Copyright (C) 1994, 1995 Aubrey Jaffer +;Copyright (C) 1994, 1995, 1997 Aubrey Jaffer ; ;Permission to copy this software, to redistribute it, and to use it ;for any purpose is granted, subject to the following restrictions and @@ -20,8 +20,18 @@ (require 'line-i/o) ;Just for write-line (require 'parameters) (require 'database-utilities) - -;;(define (batch parms op . args) ??) +(require 'string-port) +(require 'tree) + +(define system + (if (provided? 'system) + system + (lambda (str) 1))) +(define system:success? + (case (software-type) + ((VMS) (lambda (int) (eqv? 1 int))) + (else zero?))) +;;(trace system system:success? exit quit slib:exit) (define (batch:port parms) (car (parameter-list-ref parms 'batch-port))) @@ -61,8 +71,10 @@ (loop (butlast fodder hlen))))))) (define (batch:system parms . strings) - (or (apply batch:try-system parms strings) - (slib:error 'batch:system 'failed strings))) + (cond ((not (provided? 'system)) + (slib:error 'batch:system 'system "procedure not supported.")) + ((apply batch:try-system parms strings)) + (else (slib:error 'batch:system 'failed strings)))) (define (batch:try-system parms . strings) (define port (batch:port parms)) @@ -71,21 +83,19 @@ ((unix) (batch-line parms (apply string-join " " strings))) ((dos) (batch-line parms (apply string-join " " strings))) ((vms) (batch-line parms (apply string-join " " "$" strings))) - ((system) (write `(system ,(apply string-join " " strings)) port) - (newline port) - (zero? (system (apply string-join " " strings)))) + ((system) (cond ((provided? 'system) + (write `(system ,(apply string-join " " strings)) port) + (newline port) + (system:success? (system (apply string-join " " strings)))) + (else #f))) ((*unknown*) (write `(system ,(apply string-join " " strings)) port) (newline port) #f))) -(define (batch:run-script parms . strings) +(define (batch:run-script parms name . strings) (case (batch:dialect parms strings) - ((unix) (batch:system parms strings name)) - ((dos) (batch:system parms strings name)) - ((vms) (batch:system parms (cons #\@ strings))) - ((system) (batch:system parms strings name)) - ((*unknown*) (batch:system parms strings name) - #f))) + ((vms) (batch:system parms (string-append "@" name) strings)) + (else (batch:system parms name strings)))) (define (batch:comment parms . lines) (define port (batch:port parms)) @@ -135,6 +145,7 @@ (batch-line parms (string-append "$EOD")))) ((system) (write `(delete-file ,file) port) (newline port) (delete-file file) + (require 'pretty-print) (pretty-print `(call-with-output-file ,file (lambda (fp) (for-each @@ -147,6 +158,7 @@ #t) ((*unknown*) (write `(delete-file ,file) port) (newline port) + (require 'pretty-print) (pretty-print `(call-with-output-file ,file (lambda (fp) @@ -175,6 +187,7 @@ (define port (batch:port parms)) (case (batch:dialect parms) ((unix) (batch-line parms (string-join " " "mv -f" old-name new-name))) + ;;((dos) (batch-line parms (string-join " " "REN" old-name new-name))) ((dos) (batch-line parms (string-join " " "MOVE" "/Y" old-name new-name))) ((vms) (batch-line parms (string-join " " "$RENAME" old-name new-name))) ((system) (batch:extender 'rename-file batch:rename-file)) @@ -184,7 +197,7 @@ (define (batch:call-with-output-script parms name proc) (case (batch:dialect parms) - ((unix) ((cond ((string? name) + ((unix) ((cond ((and (string? name) (provided? 'system)) (lambda (proc) (let ((ans (call-with-output-file name proc))) (system (string-append "chmod +x " name)) @@ -239,7 +252,7 @@ port))) (proc port)))) - ((system) ((cond ((string? name) + ((system) ((cond ((and (string? name) (provided? 'system)) (lambda (proc) (let ((ans (call-with-output-file name (lambda (port) (proc name))))) @@ -258,7 +271,7 @@ port))) (proc port)))) - ((*unknown*) ((cond ((string? name) + ((*unknown*) ((cond ((and (string? name) (provided? 'system)) (lambda (proc) (let ((ans (call-with-output-file name (lambda (port) (proc name))))) @@ -290,6 +303,7 @@ (write `(,NAME ,@args) port) (newline port) (apply (slib:eval NAME) args)) + ((not (provided? 'system)) #f) (else (let ((pl (make-parameter-list (map car parms)))) (adjoin-parameters! @@ -305,6 +319,15 @@ (adjoin-parameters! new-parms (list 'batch-port batch-port)) (apply BATCHER new-parms args))))))))))) +(define (truncate-up-to str chars) + (define (tut str) + (do ((i (string-length str) (+ -1 i))) + ((or (zero? i) (memv (string-ref str (+ -1 i)) chars)) + (substring str i (string-length str))))) + (cond ((char? chars) (set! chars (list chars))) + ((string? chars) (set! chars (string->list chars)))) + (if (string? str) (tut str) (map tut str))) + (define (replace-suffix str old new) (define (cs str) (let* ((len (string-length str)) @@ -372,6 +395,7 @@ ((name symbol)) ((os-family batch-dialect)) (;;(3b1 *unknown*) + (*unknown* *unknown*) (acorn *unknown*) (aix unix) (alliant *unknown*) @@ -392,26 +416,27 @@ (linux unix) (mac *unknown*) (masscomp unix) - (ms-dos dos) (mips *unknown*) + (ms-dos dos) (ncr *unknown*) (newton *unknown*) (next unix) (novell *unknown*) (os/2 dos) + (osf1 unix) (prime *unknown*) (psion *unknown*) (pyramid *unknown*) (sequent *unknown*) (sgi *unknown*) (stratus *unknown*) - (sun-os unix) + (sunos unix) (transputer *unknown*) (unicos unix) (unix unix) (vms vms) - (*unknown* *unknown*) ))) ((database 'add-domain) '(operating-system operating-system #f symbol #f)) ) + |