Megatest

(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
	format ports srfi-1 matchable regex directory-utils)
;; (import commonmod)
;; (use (prefix ulex ulex:))

(include "common_records.scm")

;; 
;; 
;; ;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) 
;; ;;   execute thunk in context of environment modified as per this list
;; ;;   restore env to prior state then return value of eval'd thunk.
;; ;;   ** this is not thread safe **
;; (define (common:with-env-vars delta-env-alist-or-hash-table thunk)
;;   (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
;;                               (hash-table->alist delta-env-alist-or-hash-table)
;;                               delta-env-alist-or-hash-table))
;;          (restore-thunks
;;           (filter
;;            identity
;;            (map (lambda (env-pair)
;;                   (let* ((env-var     (car env-pair))
;;                          (new-val     (let ((tmp (cdr env-pair)))
;;                                         (if (list? tmp) (car tmp) tmp)))
;;                          (current-val (get-environment-variable env-var))
;;                          (restore-thunk
;;                           (cond
;;                            ((not current-val) (lambda () (unsetenv env-var)))
;;                            ((not (string? new-val)) #f)
;;                            ((eq? current-val new-val) #f)
;;                            (else 
;;                             (lambda () (setenv env-var current-val))))))
;;                     ;;(when (not (string? new-val))
;;                     ;;    (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist)
;;                     ;;    (pp delta-env-alist)
;;                     ;;    (exit 1))
;;                         
;;                     
;;                     (cond
;;                      ((not new-val)  ;; modify env here
;;                       (unsetenv env-var))
;;                      ((string? new-val)
;;                       (setenv env-var new-val)))
;;                     restore-thunk))
;;                 delta-env-alist))))
;;     (let ((rv (thunk)))
;;       (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
;;       rv)))
;; 
;; (define (process:conservative-read port)
;;   (let loop ((res ""))
;;     (if (not (eof-object? (peek-char port)))
;; 	(loop (conc res (read-char port)))
;; 	res)))
;; 
;; (define (process:cmd-run-with-stderr->list cmd . params)
;;   ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
;; ;;  (handle-exceptions
;; ;;   exn
;; ;;   (begin
;; ;;     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
;; ;;     (print "       " ((condition-property-accessor 'exn 'message) exn))
;; ;;     #f)
;;    (let-values (((fh fho pid fhe) (if (null? params)
;; 				      (process* cmd)
;; 				      (process* cmd params))))
;;        (let loop ((curr (read-line fh))
;; 		  (result  '()))
;; 	 (let ((errstr (process:conservative-read fhe)))
;; 	   (if (not (string=? errstr ""))
;; 	       (set! result (append result (list errstr)))))
;;        (if (not (eof-object? curr))
;; 	   (loop (read-line fh)
;; 		 (append result (list curr)))
;; 	   (begin
;; 	     (close-input-port fh)
;; 	     (close-input-port fhe)
;; 	     (close-output-port fho)
;; 	     result))))) ;; )
;; 
;; (define (process:cmd-run-with-stderr-and-exitcode->list cmd . params)
;;   ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
;; ;;  (handle-exceptions
;; ;;   exn
;; ;;   (begin
;; ;;     (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
;; ;;     (print "       " ((condition-property-accessor 'exn 'message) exn))
;; ;;     #f)
;;    (let-values (((fh fho pid fhe) (if (null? params)
;; 				      (process* cmd)
;; 				      (process* cmd params))))
;;        (let loop ((curr (read-line fh))
;; 		  (result  '()))
;; 	 (let ((errstr (process:conservative-read fhe)))
;; 	   (if (not (string=? errstr ""))
;; 	       (set! result (append result (list errstr)))))
;;        (if (not (eof-object? curr))
;; 	   (loop (read-line fh)
;; 		 (append result (list curr)))
;; 	   (begin
;;              (let-values (((anotherpid normalexit? exitstatus)  (process-wait pid)))
;; 	     (close-input-port fh)
;; 	     (close-input-port fhe)
;; 	     (close-output-port fho)
;;                (list result (if normalexit? exitstatus -1))))))))
;; 
;; (define (process:cmd-run-proc-each-line cmd proc . params)
;;   ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
;;   (handle-exceptions
;;    exn
;;    (begin
;;      (print "ERROR:  Failed to run command: " cmd " " (string-intersperse params " "))
;;      (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
;;      (debug:print 5 *default-log-port* "exn=" (condition->list exn))
;;      #f)
;;    (let-values (((fh fho pid) (if (null? params)
;; 				  (process cmd)
;; 				  (process cmd params))))
;;        (let loop ((curr (read-line fh))
;; 		(result  '()))
;;        (if (not (eof-object? curr))
;; 	   (loop (read-line fh)
;; 		 (append result (list (proc curr))))
;; 	   (begin
;; 	     (close-input-port fh)
;; 	     ;; (close-input-port fhe)
;; 	     (close-output-port fho)
;; 	     result))))))
;; 
;; (define (process:cmd-run-proc-each-line-alt cmd proc)
;;   (let* ((fh (open-input-pipe cmd))
;;          (res (port-proc->list fh proc))
;;          (status (close-input-pipe fh)))
;;     (if (eq? status 0) res #f)))
;; 
;; (define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))
;;   (common:with-env-vars
;;    delta-env-alist-or-hash-table
;;    (lambda ()
;;      (let* ((fh (open-input-pipe cmd))
;;             (res (port->list fh))
;;             (status (close-input-pipe fh)))
;;        (list res status)))))
;;    
;; (define (port->list fh)
;;   (if (eof-object? fh) #f
;;       (let loop ((curr (read-line fh))
;;                  (result '()))
;;         (if (not (eof-object? curr))
;;             (loop (read-line fh)
;;                   (append result (list curr)))
;;             result))))
;; 
;; (define (port-proc->list fh proc)
;;   (if (eof-object? fh) #f
;;       (let loop ((curr (proc (read-line fh)))
;;                  (result '()))
;;         (if (not (eof-object? curr))
;;             (loop (let ((l (read-line fh)))
;;                     (if (eof-object? l) l (proc l)))
;;                   (append result (list curr)))
;;             result))))
;; 
;; ;; here is an example line where the shell is sh or bash
;; ;; "find / -print 2&>1 > findall.log"
;; (define (run-n-wait cmdline #!key (params #f)(print-cmd #f)(run-dir #f))
;;   (if print-cmd 
;;       (debug:print 0 *default-log-port* 
;; 		   (if (string? print-cmd)
;; 		       print-cmd
;; 		       "")
;; 		   (if run-dir (conc "Run in " run-dir ";") "")
;; 		   cmdline
;; 		   (if params
;; 		       (conc " " (string-intersperse params " "))
;; 		       "")))
;;   (if (and run-dir
;; 	   (directory-exists? run-dir))
;;       (push-directory run-dir))
;;   (let ((pid (if params
;; 		 (process-run cmdline params)
;; 		 (process-run cmdline))))
;;     (let loop ((i 0))
;;       (let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
;;          (if (eq? pid-val 0)
;; 	     (begin
;; 	       (thread-sleep! 2)
;; 	       (loop (+ i 1)))
;; 	     (begin
;; 	       (if (and run-dir
;; 			(directory-exists? run-dir))
;; 		   (pop-directory))
;; 	       (values pid-val exit-status exit-code)))))))
;;   
;; ;;======================================================================
;; ;; MISC PROCESS RELATED STUFF
;; ;;======================================================================
;; 
;; (define (process:children proc)
;;   (with-input-from-pipe
;;    (conc "ps h --ppid " (current-process-id) " -o pid")
;;    (lambda ()
;;      (let loop ((inl (read-line))
;; 		(res '()))
;;        (if (eof-object? inl)
;; 	   (reverse res)
;; 	   (let ((pid (string->number inl)))
;; 	     (if proc (proc pid))
;; 	     (loop (read-line) (cons pid res))))))))
;; 
;; (define (process:alive? pid)
;;   (handle-exceptions
;;    exn
;;    ;; possibly pid is a process not a child, look in /proc to see if it is running still
;;    (file-exists? (conc "/proc/" pid))
;;    (let-values (((rpid exit-type exit-signal)(process-wait pid #t)))
;;        (and (number? rpid)
;; 	    (equal? rpid pid)))))
;; 
;; (define (process:alive-on-host? host pid)
;;   (let ((cmd (conc "ssh " host " ps -o pid= -p " pid)))
;;     (handle-exceptions
;;      exn
;;      #f ;; anything goes wrong - assume the process in NOT running.
;;      (with-input-from-pipe 
;;       cmd
;;       (lambda ()
;; 	(let loop ((inl (read-line)))
;; 	  (if (eof-object? inl)
;; 	      #f
;; 	      (let* ((clean-str (string-substitute "^[^\\d]*([0-9]+)[^\\d]*$" "\\1" inl))
;; 		     (innum     (string->number clean-str)))
;; 		(and innum
;; 		     (eq? pid innum))))))))))
;; 
;; (define (process:get-sub-pids pid)
;;   (with-input-from-pipe
;;    (conc "pstree -A -p " pid) ;; | tr 'a-z\\-+`()\\.' ' ' " pid)
;;    (lambda ()
;;      (let loop ((inl (read-line))
;; 		(res '()))
;;        (if (eof-object? inl)
;; 	   (reverse res)
;; 	   (let ((nums (map string->number
;; 			    (string-split-fields "\\d+" inl))))
;; 	     (loop (read-line)
;; 		   (append res nums))))))))

)