;;======================================================================
;; Copyright 2017, 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 debugprint))
(declare (uses commonmod))
(use srfi-69)
(module processmod
(
process:children
process:cmd-run->list
process:alive?
run-n-wait
process:cmd-run-with-stderr-and-exitcode->list
process:alive-on-host?
process:get-sub-pids
)
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
(prefix sqlite3 sqlite3:)
data-structures
directory-utils
extras
files
matchable
md5
message-digest
pathname-expand
posix
posix-extras
regex
regex-case
srfi-1
srfi-18
srfi-69
typed-records
debugprint
commonmod
)
(use srfi-69))
(chicken-5
(import (prefix sqlite3 sqlite3:)
;; data-structures
;; extras
;; files
;; posix
;; posix-extras
chicken.base
chicken.condition
chicken.file
chicken.file.posix
chicken.io
chicken.pathname
chicken.port
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
chicken.time.posix
matchable
md5
message-digest
pathname-expand
regex
regex-case
srfi-1
srfi-18
srfi-69
typed-records
system-information
debugprint
commonmod
)))
(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
(debug:print 0 *default-log-port* "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
(common: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)))
(common:generic-ssh
cmd
;;
;; handle-exceptions
;; exn
;; (begin
;; (debug:print 0 *default-log-port* "failed to identify if process " pid ", on host " host " is alive. exn=" 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))))))
#f
(lambda ()
(debug:print 0 *default-log-port* "failed to identify if process "
pid", on host "host" is alive.")))))
(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))))))))
)