summaryrefslogtreecommitdiffstats
path: root/batch.scm
diff options
context:
space:
mode:
Diffstat (limited to 'batch.scm')
-rw-r--r--batch.scm177
1 files changed, 71 insertions, 106 deletions
diff --git a/batch.scm b/batch.scm
index 88684c0..7749451 100644
--- a/batch.scm
+++ b/batch.scm
@@ -34,7 +34,11 @@
;;(trace system system:success? exit quit slib:exit)
(define (batch:port parms)
- (car (parameter-list-ref parms 'batch-port)))
+ (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)
+ (current-output-port))
+ (else (car bp)))))
(define (batch:dialect parms) ; was batch-family
(car (parameter-list-ref parms 'batch-dialect)))
@@ -49,13 +53,11 @@
((system) 1023)
((*unknown*) -1))))))
+(define (write-batch-line str line-limit port)
+ (cond ((and line-limit (>= (string-length str) line-limit)) #f)
+ (else (write-line str port) #t)))
(define (batch-line parms str)
- (let ((bp (parameter-list-ref parms 'batch-port))
- (ln (batch:line-length-limit parms)))
- (cond ((not bp) (slib:error 'batch-line "missing batch-port parameter"
- parms))
- ((>= (string-length str) ln) #f)
- (else (write-line str (car bp)) #t))))
+ (write-batch-line str (batch:line-length-limit parms) (batch:port parms)))
;;; add a Scheme batch-dialect?
@@ -70,56 +72,50 @@
(else (loop (nthcdr (+ 1 hlen) fodder))
(loop (butlast fodder hlen)))))))
-(define (batch:system parms . 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))
(set! strings (batch:flatten 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) (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)))
+ ((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)
+ (else #f)))
+
+(define (batch:system parms . strings)
+ (cond ((apply batch:try-system parms strings))
+ (else (slib:error 'batch:system '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))))
+(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))
+ ((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))
(set! lines (batch:flatten lines))
- (case (batch:dialect parms)
- ((unix) (every (lambda (line)
- (batch-line parms (string-append "# " line)))
- lines))
- ((dos) (every (lambda (line)
- (batch-line parms
- (string-append
- "rem" (if (equal? " " line) ".") line)))
- lines))
- ((vms) (every (lambda (line)
- (batch-line parms (string-append "$! " line)))
- lines))
- ((system) (every (lambda (line)
- (batch-line parms (string-append "; " line)))
- lines))
- ((*unknown*) (for-each (lambda (line)
- (batch-line parms (string-append ";;; " line))
- (newline port))
- lines)
- #f)))
+ (every (lambda (line)
+ (batch:write-comment-line dialect line port))
+ lines))
(define (batch:lines->file parms file . lines)
(define port (batch:port parms))
@@ -195,61 +191,57 @@
(newline port)
#f)))
+(define (batch:write-header-comment dialect name port)
+ (batch:write-comment-line
+ dialect
+ (string-append (if (string? name)
+ (string-append "\"" name "\"")
+ (case dialect
+ ((system *unknown*) "Scheme")
+ ((vms) "VMS")
+ ((dos) "DOS")
+ ((default-for-platform) "??")
+ (else (symbol->string dialect))))
+ " script created by SLIB/batch "
+ (cond ((provided? 'bignum)
+ (require 'posix-time)
+ (let ((ct (ctime (current-time))))
+ (substring ct 0 (+ -1 (string-length ct)))))
+ (else "")))
+ port))
+
(define (batch:call-with-output-script parms name proc)
- (case (batch:dialect parms)
+ (define dialect (batch:dialect parms))
+ (case dialect
((unix) ((cond ((and (string? name) (provided? 'system))
(lambda (proc)
(let ((ans (call-with-output-file name proc)))
(system (string-append "chmod +x " name))
ans)))
((output-port? name) (lambda (proc) (proc name)))
- (else (lambda (proc) (proc (current-output-port)))))
+ (else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
(write-line "#!/bin/sh" port)
- (cond
- ((and (string? name) (provided? 'bignum))
- (require 'posix-time)
- (write-line
- (string-append
- "# \"" name "\" build script created "
- (ctime (current-time)))
- port)))
+ (batch:write-header-comment dialect name port)
(proc port))))
((dos) ((cond ((string? name)
(lambda (proc)
(call-with-output-file (string-append name ".bat") proc)))
((output-port? name) (lambda (proc) (proc name)))
- (else (lambda (proc) (proc (current-output-port)))))
+ (else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
- (cond
- ((and (string? name) (provided? 'bignum))
- (require 'posix-time)
- (write-line
- (string-append
- "rem " name
- " build script created "
- (ctime (current-time)))
- port)))
+ (batch:write-header-comment dialect name port)
(proc port))))
((vms) ((cond ((string? name)
(lambda (proc)
(call-with-output-file (string-append name ".COM") proc)))
((output-port? name) (lambda (proc) (proc name)))
- (else (lambda (proc) (proc (current-output-port)))))
+ (else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
- (cond
- ((and (string? name) (provided? 'bignum))
- (require 'posix-time)
- ;;(write-line
- ;; "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port)
- (write-line
- (string-append
- "$! " name
- " build script created "
- (ctime (current-time)))
- port)))
+ (batch:write-header-comment dialect name port)
+ ;;(write-line "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port)
(proc port))))
((system) ((cond ((and (string? name) (provided? 'system))
@@ -259,16 +251,9 @@
(system (string-append "chmod +x " name))
ans)))
((output-port? name) (lambda (proc) (proc name)))
- (else (lambda (proc) (proc (current-output-port)))))
+ (else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
- (cond
- ((and (string? name) (provided? 'bignum))
- (require 'posix-time)
- (write-line
- (string-append
- ";;; \"" name
- "\" build script created " (ctime (current-time)))
- port)))
+ (batch:write-header-comment dialect name port)
(proc port))))
((*unknown*) ((cond ((and (string? name) (provided? 'system))
@@ -278,18 +263,10 @@
(system (string-append "chmod +x " name))
ans)))
((output-port? name) (lambda (proc) (proc name)))
- (else (lambda (proc) (proc (current-output-port)))))
+ (else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
- (cond
- ((and (string? name) (provided? 'bignum))
- (require 'posix-time)
- (write-line
- (string-append
- ";;; \"" name
- "\" build script created " (ctime (current-time)))
- port)))
- (proc port)))
- #f)))
+ (batch:write-header-comment dialect name port)
+ (proc port))))))
;;; This little ditty figures out how to use a Scheme extension or
;;; SYSTEM to execute a command that is not available in the batch
@@ -328,17 +305,6 @@
((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))
- (re (- len (string-length old))))
- (cond ((string-ci=? old (substring str re len))
- (string-append (substring str 0 re) new))
- (else
- (slib:error 'replace-suffix "suffix doens't match:"
- old str)))))
- (if (string? str) (cs str) (map cs 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)))
@@ -439,4 +405,3 @@
((database 'add-domain) '(operating-system operating-system #f symbol #f))
)
-