diff options
Diffstat (limited to 'batch.scm')
| -rw-r--r-- | batch.scm | 145 |
1 files changed, 87 insertions, 58 deletions
@@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -17,11 +17,14 @@ ;promotional, or sales literature without prior written consent in ;each case. +(require 'tree) (require 'line-i/o) ;Just for write-line +(require 'databases) (require 'parameters) -(require 'database-utilities) (require 'string-port) -(require 'tree) +(require 'pretty-print) +(require 'common-list-functions) +(require-if '(and bignum compiling) 'posix-time) (define system (if (provided? 'system) @@ -43,6 +46,9 @@ (define (batch:dialect parms) ; was batch-family (car (parameter-list-ref parms 'batch-dialect))) +(define (batch:operating-system parms) + (car (parameter-list-ref parms 'operating-system))) + (define (write-batch-line str line-limit port) (cond ((and line-limit (>= (string-length str) line-limit)) (slib:warn 'write-batch-line 'too-long @@ -53,7 +59,7 @@ (write-batch-line str (batch:line-length-limit parms) (batch:port parms))) ;;; add a Scheme batch-dialect? - +;@ (define (batch:try-chopped-command parms . args) (define args-but-last (batch:flatten (butlast args 1))) (define line-limit (batch:line-length-limit parms)) @@ -65,7 +71,7 @@ (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)))) + (append args-but-last (list fodder))) #f) (else (let ((hlen (quotient (length fodder) 2))) (and (loop (last fodder hlen)) @@ -74,15 +80,15 @@ (define (batch:glued-line parms strings) (case (batch:dialect parms) ((vms) (apply string-join " " "$" strings)) - ((unix dos amigados system *unknown*) (apply string-join " " strings)) + ((unix dos amigaos system *unknown*) (apply string-join " " strings)) (else #f))) - +;@ (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)) + ((unix dos vms amigaos) (batch-line parms line)) ((system) (let ((port (batch:port parms))) (write `(system ,line) port) (newline port) @@ -91,11 +97,11 @@ (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:command parms (string-append "@" name) strings)) @@ -106,12 +112,12 @@ ((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)) + ((amigaos) (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) #f))) - +;@ (define (batch:comment parms . lines) (define port (batch:port parms)) (define dialect (batch:dialect parms)) @@ -119,7 +125,7 @@ (every (lambda (line) (batch:write-comment-line dialect line port)) lines)) - +;@ (define (batch:lines->file parms file . lines) (define port (batch:port parms)) (set! lines (batch:flatten lines)) @@ -142,7 +148,7 @@ (every (lambda (string) (batch-line parms string)) lines) (batch-line parms (string-append "$EOD")))) - ((amigados) (batch-line parms (string-append "delete force " file)) + ((amigaos) (batch-line parms (string-append "delete force " file)) (every (lambda (str) (letrec ((star-quote @@ -162,7 +168,6 @@ lines)) ((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 @@ -175,7 +180,6 @@ #t) ((*unknown*) (write `(delete-file ,file) port) (newline port) - (require 'pretty-print) (pretty-print `(call-with-output-file ,file (lambda (fp) @@ -185,7 +189,7 @@ ,lines))) port) #f))) - +;@ (define (batch:delete-file parms file) (define port (batch:port parms)) (case (batch:dialect parms) @@ -195,13 +199,13 @@ #t) ((vms) (batch-line parms (string-append "$DELETE " file)) #t) - ((amigados) (batch-line parms (string-append "delete force " file)) + ((amigaos) (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) #f))) - +;@ (define (batch:rename-file parms old-name new-name) (define port (batch:port parms)) (case (batch:dialect parms) @@ -209,15 +213,18 @@ ;;((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))) + ((amigaos) (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) #f))) -(define (batch:write-header-comment dialect name port) +(define (batch:write-header-comment parms name port) + (define dialect (batch:dialect parms)) + (define operating-system + (or (batch:operating-system parms) *operating-system*)) (batch:write-comment-line dialect (string-append (if (string? name) @@ -228,6 +235,7 @@ ((dos) "DOS") ((default-for-platform) "??") (else (symbol->string dialect)))) + " (" (symbol->string operating-system) ")" " script created by SLIB/batch " (cond ((provided? 'bignum) (require 'posix-time) @@ -235,9 +243,11 @@ (substring ct 0 (+ -1 (string-length ct))))) (else ""))) port)) - +;@ (define (batch:call-with-output-script parms name proc) (define dialect (batch:dialect parms)) + (define operating-system + (or (batch:operating-system parms) *operating-system*)) (case dialect ((unix) ((cond ((and (string? name) (provided? 'system)) (lambda (proc) @@ -247,8 +257,11 @@ ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (write-line "#!/bin/sh" port) - (batch:write-header-comment dialect name port) + (write-line (if (eq? 'plan9 operating-system) + "#! /bin/rc" + "#! /bin/sh") + port) + (batch:write-header-comment parms name port) (proc port)))) ((dos) ((cond ((string? name) @@ -257,7 +270,7 @@ ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (batch:write-header-comment dialect name port) + (batch:write-header-comment parms name port) (proc port)))) ((vms) ((cond ((string? name) @@ -266,20 +279,20 @@ ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (batch:write-header-comment dialect name port) + (batch:write-header-comment parms name port) ;;(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)))) + ((amigaos) ((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 parms name port) + (proc port)))) ((system) ((cond ((and (string? name) (provided? 'system)) (lambda (proc) @@ -290,7 +303,7 @@ ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (batch:write-header-comment dialect name port) + (batch:write-header-comment parms name port) (proc port)))) ((*unknown*) ((cond ((and (string? name) (provided? 'system)) @@ -302,7 +315,7 @@ ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (batch:write-header-comment dialect name port) + (batch:write-header-comment parms name port) (proc port)))))) ;;; This little ditty figures out how to use a Scheme extension or @@ -321,8 +334,9 @@ (else (let ((pl (make-parameter-list (map car parms)))) (adjoin-parameters! - pl (cons 'batch-dialect (os->batch-dialect - (parameter-list-ref parms 'platform)))) + pl (cons 'batch-dialect + (os->batch-dialect + (parameter-list-ref parms 'operating-system)))) (system (call-with-output-string (lambda (port) @@ -332,7 +346,7 @@ (define new-parms (copy-tree pl)) (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))) @@ -341,15 +355,15 @@ (cond ((char? chars) (set! chars (list chars))) ((string? chars) (set! chars (string->list chars)))) (if (string? str) (tut str) (map tut str))) - +;@ (define (must-be-first firsts lst) (append (remove-if-not (lambda (i) (member i lst)) firsts) (remove-if (lambda (i) (member i firsts)) lst))) - +;@ (define (must-be-last lst lasts) (append (remove-if (lambda (i) (member i lasts)) lst) (remove-if-not (lambda (i) (member i lst)) lasts))) - +;@ (define (string-join joiner . args) (if (null? args) "" (apply string-append @@ -369,21 +383,15 @@ obj "in" strings)))) strings))) -(define batch:platform (software-type)) -(cond ((and (eq? 'unix batch:platform) (provided? 'system)) - (let ((file-name (tmpnam))) - (system (string-append "uname > " file-name)) - (set! batch:platform (call-with-input-file file-name read)) - (delete-file file-name)))) - (define batch:database #f) -(define os->batch-dialect #f) (define batch-dialect->line-length-limit #f) +;@ +(define os->batch-dialect #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) (define-tables database @@ -394,7 +402,7 @@ ((unix 1023) (dos 127) (vms 1023) - (amigados 511) + (amigaos 511) (system 1023) (*unknown* -1))) @@ -406,7 +414,7 @@ (acorn *unknown*) (aix unix) (alliant *unknown*) - (amiga amigados) + (amiga amigaos) (apollo unix) (apple2 *unknown*) (arm *unknown*) @@ -415,6 +423,7 @@ (celerity *unknown*) (concurrent *unknown*) (convex *unknown*) + (darwin unix) (encore *unknown*) (harris *unknown*) (hp-ux unix) @@ -432,6 +441,7 @@ (novell *unknown*) (os/2 dos) (osf1 unix) + (plan9 unix) (prime *unknown*) (psion *unknown*) (pyramid *unknown*) @@ -445,10 +455,29 @@ (vms vms) ))) - ((database 'add-domain) '(operating-system operating-system #f symbol #f)) + (define-domains database '(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)) ) +;@ +(define *operating-system* + (cond ((and (eq? 'unix (software-type)) (provided? 'system)) + (let* ((file-name (tmpnam)) + (uname (and (system (string-append "uname > " file-name)) + (call-with-input-file file-name read))) + (ustr (and (symbol? uname) (symbol->string uname)))) + (delete-file file-name) + (cond ((and ustr + (> (string-length ustr) 5) + (string-ci=? "cygwin" (substring ustr 0 6))) + 'gnu-win32) + ((and ustr + (> (string-length ustr) 4) + (string-ci=? "mingw" (substring ustr 0 5))) + 'gnu-win32) + (ustr uname) + (else (software-type))))) + (else (software-type)))) |