summaryrefslogtreecommitdiffstats
path: root/batch.scm
diff options
context:
space:
mode:
Diffstat (limited to 'batch.scm')
-rw-r--r--batch.scm145
1 files changed, 87 insertions, 58 deletions
diff --git a/batch.scm b/batch.scm
index 45b404c..bef29cc 100644
--- a/batch.scm
+++ b/batch.scm
@@ -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))))