diff options
Diffstat (limited to 'batch.scm')
-rw-r--r-- | batch.scm | 177 |
1 files changed, 71 insertions, 106 deletions
@@ -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)) ) - |