batch.scm

;;; "batch.scm" Group and execute commands on various systems.
;Copyright (C) 1994, 1995, 1997, 2004 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;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.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;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 'string-port)
(require 'pretty-print)
(require 'multiarg-apply)
(require 'common-list-functions)
(require-if '(and bignum compiling) 'posix-time)

(define system
  (if (provided? 'system)
      system
      (lambda (str) 1)))
(define system:success?
  (case (software-type)
    ((vms) (lambda (int) (eqv? 1 int)))
    (else zero?)))
;;(trace system system:success? exit quit slib:exit)

(define (batch:port parms)
  (let ((bp (parameter-list-ref parms 'batch-port)))
    (cond ((or (not (pair? bp)) (not (output-port? (car 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:operating-system parms)
  (car (parameter-list-ref parms 'operating-system)))

(define (batch-line parms str)
  (define line-limit (batch:line-length-limit parms))
  (define port (batch:port parms))
  (cond ((and line-limit (>= (string-length str) line-limit))
	 (let ((msg (string-append "batch line is too long "
				   (number->string (string-length str))
				   " > "
				   (number->string line-limit))))
	   (batch:comment parms (string-append "WARN: " msg))
	   (if (not (eq? port (current-output-port))) (slib:warn msg)))))
  (write-line str port)
  #t)

;;; 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))
  (let loop ((fodder (car (last-pair args))))
    (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
			(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)
    ((vms) (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 amigaos) (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)
    ((vms) (batch:command parms (string-append "@" name) strings))
    (else (batch:command parms name strings))))

(define (batch:comment-prefix dialect)
  (case dialect
    ((unix)      "# ")
    ((dos)       "rem ")
    ((vms)       "$! ")
    ((amigaos)   "; ")
    ((system)    "; ")
    ((*unknown*) ";;; ")))

;;; Comment lines usually don't have a length limit.
(define (batch:write-comment-line dialect line port)
  (write-line (string-append (batch:comment-prefix dialect) line) port)
  #t)
;@
(define (batch:comment parms . lines)
  (define port (batch:port parms))
  (define dialect (batch:dialect parms))
  (set! lines (batch:flatten lines))
  (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))
  (case (or (batch:dialect parms) '*unknown*)
    ((unix) (batch-line parms (string-append "rm -f " file))
	    (every
	     (lambda (string)
	       (batch-line parms (string-append "echo '" string "'>>" file)))
	     lines))
    ((dos) (batch-line parms (string-append "DEL " file))
	   (every
	    (lambda (string)
	      (batch-line parms
			  (string-append "ECHO" (if (equal? "" string) "." " ")
					 string ">>" file)))
	    lines))
    ((vms) (and (batch-line parms (string-append "$DELETE " file))
		(batch-line parms (string-append "$CREATE " file))
		(batch-line parms (string-append "$DECK"))
		(every (lambda (string) (batch-line parms string))
		       lines)
		(batch-line parms (string-append "$EOD"))))
    ((amigaos) (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)
	      (pretty-print `(call-with-output-file ,file
			       (lambda (fp)
				 (for-each
				  (lambda (string) (write-line string fp))
				  ',lines)))
			    port)
	      (call-with-output-file file
		(lambda (fp) (for-each (lambda (string) (write-line string fp))
				       lines)))
	      #t)
    ((*unknown*)
     (write `(delete-file ,file) port) (newline port)
     (pretty-print
      `(call-with-output-file ,file
	 (lambda (fp)
	   (for-each
	    (lambda (string)
	      (write-line string fp))
	    ,lines)))
      port)
     #f)))
;@
(define (batch:delete-file parms file)
  (define port (batch:port parms))
  (case (batch:dialect parms)
    ((unix) (batch-line parms (string-append "rm -f " file))
	    #t)
    ((dos) (batch-line parms (string-append "DEL " file))
	   #t)
    ((vms) (batch-line parms (string-append "$DELETE " file))
	   #t)
    ((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)
    ((unix) (batch-line parms (string-join " " "mv -f" old-name new-name)))
    ;;((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)))
    ((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 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)
		      (string-append "\"" name "\"")
		      (case dialect
			((system *unknown*) "Scheme")
			((vms) "VMS")
			((dos) "DOS")
			((default-for-platform) "??")
			(else (symbol->string dialect))))
		  " (" (symbol->string operating-system) ")"
		  " 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)
  (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)
		      (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)))))
	     (lambda (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)
		   (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)))))
	    (lambda (port)
	      (batch:write-header-comment parms 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)))))
	    (lambda (port)
	      (batch:write-header-comment parms name port)
	      ;;(write-line "$DEFINE/USER SYS$OUTPUT BUILD.LOG" 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)
			(let ((ans (call-with-output-file name
				     (lambda (port) (proc name)))))
			  (system (string-append "chmod +x " name))
			  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))))

    ((*unknown*) ((cond ((and (string? name) (provided? 'system))
			 (lambda (proc)
			   (let ((ans (call-with-output-file name
					(lambda (port) (proc name)))))
			     (system (string-append "chmod +x " name))
			     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))))))

;;; This little ditty figures out how to use a Scheme extension or
;;; SYSTEM to execute a command that is not available in the batch
;;; mode chosen.

(define (batch:extender NAME BATCHER)
  (lambda (parms . args)
    (define port (batch:port parms))
    (cond
     ((provided? 'i/o-extensions)	; SCM specific
      (write `(,NAME ,@args) port)
      (newline port)
      (apply (slib:eval NAME) args))
     ((not (provided? 'system)) #f)
     (else
      (let ((pl (make-parameter-list (map car parms))))
	(adjoin-parameters!
	 pl (cons 'batch-dialect
		  (os->batch-dialect
		   (parameter-list-ref parms 'operating-system))))
	(system
	 (call-with-output-string
	  (lambda (port)
	    (batch:call-with-output-script
	     parms
	     port
	     (lambda (batch-port)
	       (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)))
	((or (zero? i) (memv (string-ref str (+ -1 i)) chars))
	 (substring str i (string-length str)))))
  (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
	     (car args)
	     (map (lambda (s) (string-append joiner s)) (cdr args)))))

(define (batch:flatten strings)
  (apply
   append (map
	   (lambda (obj)
	     (cond ((eq? "" obj) '())
		   ((string? obj) (list obj))
		   ((eq? #f obj) '())
		   ((null? obj) '())
		   ((list? obj) (batch:flatten obj))
		   (else (slib:error 'batch:flatten "unexpected type"
				     obj "in" strings))))
	   strings)))

(define batch:database #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

    '(batch-dialect
      ((family atom))
      ((line-length-limit number))
      ((unix 1023)
       (dos 127)
       (vms 1023)
       (amigaos 511)
       (system 1023)
       (*unknown* -1)))

    '(operating-system
      ((name symbol))
      ((os-family batch-dialect))
      (;;(3b1		*unknown*)
       (*unknown*	*unknown*)
       (acorn		*unknown*)
       (aix		unix)
       (alliant		*unknown*)
       (amiga		amigaos)
       (apollo		unix)
       (apple2		*unknown*)
       (arm		*unknown*)
       (atari.st	*unknown*)
       (atari-st	*unknown*)
       (cdc		*unknown*)
       (celerity	*unknown*)
       (concurrent	*unknown*)
       (convex		*unknown*)
       (darwin		unix)
       (encore		*unknown*)
       (harris		*unknown*)
       (hp-ux		unix)
       (hp48		*unknown*)
       (irix		unix)
       (isis		*unknown*)
       (linux		unix)
       (mac		*unknown*)
       (masscomp	unix)
       (mips		*unknown*)
       (ms-dos		dos)
       (ncr		*unknown*)
       (newton		*unknown*)
       (next		unix)
       (novell		*unknown*)
       (os/2		dos)
       (osf1		unix)
       (plan9		unix)
       (prime		*unknown*)
       (psion		*unknown*)
       (pyramid		*unknown*)
       (sequent		*unknown*)
       (sgi		*unknown*)
       (stratus		*unknown*)
       (sunos		unix)
       (transputer	*unknown*)
       (unicos		unix)
       (unix		unix)
       (vms		vms)
       )))

  (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))))