aboutsummaryrefslogtreecommitdiffstats
path: root/batch.scm
diff options
context:
space:
mode:
Diffstat (limited to 'batch.scm')
-rw-r--r--batch.scm151
1 files changed, 99 insertions, 52 deletions
diff --git a/batch.scm b/batch.scm
index 7749451..d77519d 100644
--- a/batch.scm
+++ b/batch.scm
@@ -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))
)