diff options
Diffstat (limited to 'batch.scm')
| -rw-r--r-- | batch.scm | 151 |
1 files changed, 99 insertions, 52 deletions
@@ -36,74 +36,77 @@ (define (batch:port parms) (let ((bp (parameter-list-ref parms 'batch-port))) (cond ((or (not (pair? bp)) (not (output-port? (car bp)))) - ;;(slib:error 'batch-line "missing batch-port parameter" bp) + (slib:warn 'batch-line "missing batch-port parameter" bp) (current-output-port)) (else (car bp))))) (define (batch:dialect parms) ; was batch-family (car (parameter-list-ref parms 'batch-dialect))) -(define (batch:line-length-limit parms) - (let ((bl (parameter-list-ref parms 'batch-line-length-limit))) - (cond (bl (car bl)) - (else (case (batch:dialect parms) - ((unix) 1023) - ((dos) 127) - ((vms) 1023) - ((system) 1023) - ((*unknown*) -1)))))) - (define (write-batch-line str line-limit port) - (cond ((and line-limit (>= (string-length str) line-limit)) #f) + (cond ((and line-limit (>= (string-length str) line-limit)) + (slib:warn 'write-batch-line 'too-long + (string-length str) '> line-limit) + #f) (else (write-line str port) #t))) (define (batch-line parms str) (write-batch-line str (batch:line-length-limit parms) (batch:port parms))) ;;; add a Scheme batch-dialect? -(define (batch:apply-chop-to-fit proc . args) - (define args-but-last (butlast args 1)) +(define (batch:try-chopped-command parms . args) + (define args-but-last (batch:flatten (butlast args 1))) + (define line-limit (batch:line-length-limit parms)) (let loop ((fodder (car (last-pair args)))) - (let ((hlen (quotient (length fodder) 2))) - (cond ((apply proc (append args-but-last (list fodder)))) - ((not (positive? hlen)) - (slib:error 'batch:apply-chop-to-fit "can't split" - (cons proc (append args-but-last (list fodder))))) - (else (loop (nthcdr (+ 1 hlen) fodder)) - (loop (butlast fodder hlen))))))) - -(define (batch:try-system parms . strings) - (set! strings (batch:flatten strings)) + (let ((str (batch:glued-line parms + (batch:flatten + (append args-but-last (list fodder)))))) + (cond ((< (string-length str) line-limit) + (batch:try-command parms str)) + ((< (length fodder) 2) + (slib:warn 'batch:try-chopped-command "can't fit in " line-limit + (cons proc (append args-but-last (list fodder)))) + #f) + (else (let ((hlen (quotient (length fodder) 2))) + (and (loop (last fodder hlen)) + (loop (butlast fodder hlen))))))))) + +(define (batch:glued-line parms strings) (case (batch:dialect parms) - ((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) - (let ((port (batch:port parms)) - (str (apply string-join " " strings))) - (write `(system ,str) port) (newline port) - (and (provided? 'system) (system:success? (system str))))) - ((*unknown*) - (let ((port (batch:port parms)) - (str (apply string-join " " strings))) - (write `(system ,str) port) (newline port)) - #t) + ((vms) (apply string-join " " "$" strings)) + ((unix dos amigados system *unknown*) (apply string-join " " strings)) (else #f))) -(define (batch:system parms . strings) - (cond ((apply batch:try-system parms strings)) - (else (slib:error 'batch:system 'failed strings)))) +(define (batch:try-command parms . strings) + (set! strings (batch:flatten strings)) + (let ((line (batch:glued-line parms strings))) + (and line + (case (batch:dialect parms) + ((unix dos vms amigados) (batch-line parms line)) + ((system) + (let ((port (batch:port parms))) + (write `(system ,line) port) (newline port) + (and (provided? 'system) (system:success? (system line))))) + ((*unknown*) + (let ((port (batch:port parms))) + (write `(system ,line) port) (newline port) #t)) + (else #f))))) + +(define (batch:command parms . strings) + (cond ((apply batch:try-command parms strings)) + (else (slib:error 'batch:command 'failed strings)))) (define (batch:run-script parms name . strings) (case (batch:dialect parms strings) - ((vms) (batch:system parms (string-append "@" name) strings)) - (else (batch:system parms name strings)))) + ((vms) (batch:command parms (string-append "@" name) strings)) + (else (batch:command parms name strings)))) (define (batch:write-comment-line dialect line port) (case dialect ((unix) (write-batch-line (string-append "# " line) #f port)) ((dos) (write-batch-line (string-append "rem " line) #f port)) ((vms) (write-batch-line (string-append "$! " line) #f port)) + ((amigados) (write-batch-line (string-append "; " line) #f port)) ((system) (write-batch-line (string-append "; " line) #f port)) ((*unknown*) (write-batch-line (string-append ";;; " line) #f port) ;;(newline port) @@ -139,6 +142,24 @@ (every (lambda (string) (batch-line parms string)) lines) (batch-line parms (string-append "$EOD")))) + ((amigados) (batch-line parms (string-append "delete force " file)) + (every + (lambda (str) + (letrec ((star-quote + (lambda (str) + (if (equal? "" str) + str + (let* ((ch (string-ref str 0)) + (s (if (char=? ch #\") + (string #\* ch) + (string ch)))) + (string-append + s + (star-quote + (substring str 1 (string-length str))))))))) + (batch-line parms (string-append "echo \"" (star-quote str) + "\" >> " file)))) + lines)) ((system) (write `(delete-file ,file) port) (newline port) (delete-file file) (require 'pretty-print) @@ -174,6 +195,8 @@ #t) ((vms) (batch-line parms (string-append "$DELETE " file)) #t) + ((amigados) (batch-line parms (string-append "delete force " file)) + #t) ((system) (write `(delete-file ,file) port) (newline port) (delete-file file)) ; SLIB provides ((*unknown*) (write `(delete-file ,file) port) (newline port) @@ -186,6 +209,9 @@ ;;((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))) + ((amigados) (batch-line parms (string-join " " "failat 21")) + (batch-line parms (string-join " " "delete force" new-name)) + (batch-line parms (string-join " " "rename" old-name new-name))) ((system) (batch:extender 'rename-file batch:rename-file)) ((*unknown*) (write `(rename-file ,old-name ,new-name) port) (newline port) @@ -244,6 +270,17 @@ ;;(write-line "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port) (proc port)))) + ((amigados) ((cond ((and (string? name) (provided? 'system)) + (lambda (proc) + (let ((ans (call-with-output-file name proc))) + (system (string-append "protect " name " rswd")) + ans))) + ((output-port? name) (lambda (proc) (proc name))) + (else (lambda (proc) (proc (current-output-port))))) + (lambda (port) + (batch:write-header-comment dialect name port) + (proc port)))) + ((system) ((cond ((and (string? name) (provided? 'system)) (lambda (proc) (let ((ans (call-with-output-file name @@ -340,9 +377,12 @@ (delete-file file-name)))) (define batch:database #f) -(define (os->batch-dialect os) - ((((batch:database 'open-table) 'operating-system #f) - 'get 'os-family) os)) +(define os->batch-dialect #f) +(define batch-dialect->line-length-limit #f) + +(define (batch:line-length-limit parms) + (let ((bl (parameter-list-ref parms 'batch-line-length-limit))) + (if bl (car bl) (batch-dialect->line-length-limit (batch:dialect parms))))) (define (batch:initialize! database) (set! batch:database database) @@ -350,12 +390,13 @@ '(batch-dialect ((family atom)) - () - ((unix) - (dos) - (vms) - (system) - (*unknown*))) + ((line-length-limit number)) + ((unix 1023) + (dos 127) + (vms 1023) + (amigados 511) + (system 1023) + (*unknown* -1))) '(operating-system ((name symbol)) @@ -365,7 +406,7 @@ (acorn *unknown*) (aix unix) (alliant *unknown*) - (amiga *unknown*) + (amiga amigados) (apollo unix) (apple2 *unknown*) (arm *unknown*) @@ -378,6 +419,7 @@ (harris *unknown*) (hp-ux unix) (hp48 *unknown*) + (irix unix) (isis *unknown*) (linux unix) (mac *unknown*) @@ -404,4 +446,9 @@ ))) ((database 'add-domain) '(operating-system operating-system #f symbol #f)) + (set! os->batch-dialect (((batch:database 'open-table) 'operating-system #f) + 'get 'os-family)) + (set! batch-dialect->line-length-limit + (((batch:database 'open-table) 'batch-dialect #f) + 'get 'line-length-limit)) ) |