;;======================================================================
;; Copyright 2019, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit processmod))
;; (declare (uses commonmod))
(module processmod
*
(import scheme chicken data-structures extras)
(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))))))))
)