15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
;;
;; 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 commonmod))
;; (declare (uses debugprint))
typed-records)
(use srfi-69))
(chicken-5
(import (prefix sqlite3 sqlite3:)
;; data-structures
;; extras
;; files
;; posix
|
|
>
|
>
>
>
|
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
|
;;
;; 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 commonmod))
(declare (uses debugprint))
(use srfi-69)
(module commonmod
*
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
(prefix sqlite3 sqlite3:)
data-structures
extras
files
matchable
md5
message-digest
pathname-expand
posix
posix-extras
regex
regex-case
srfi-1
srfi-18
srfi-69
typed-records
debugprint
)
(use srfi-69))
(chicken-5
(import (prefix sqlite3 sqlite3:)
;; data-structures
;; extras
;; files
;; posix
|
695
696
697
698
699
700
701
702
703
|
(else exe)))))
'("../../" "../")))))
(if (null? res)
(begin
;; (debug:print 0 *default-log-port* "Failed to find this executable! Using what can be found on the path")
progname)
(car res))))
)
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
|
(else exe)))))
'("../../" "../")))))
(if (null? res)
(begin
;; (debug:print 0 *default-log-port* "Failed to find this executable! Using what can be found on the path")
progname)
(car res))))
(define (common:generic-ssh ssh-command proc default #!optional (msg-proc #f))
(let ((inp #f))
(handle-exceptions
exn
(begin
(close-input-port inp)
(if msg-proc
(msg-proc)
(debug:print 0 *default-log-port* "Command: \""ssh-command"\" failed. exn="exn))
default)
(set! inp (open-input-pipe ssh-command))
(with-input-from-port inp
(lambda ()
(let ((res (proc)))
(close-input-port inp)
res))))))
;; this is a close duplicate of:
;; process:alist-on-host?
;; process:alive
;;
(define (commonmod:is-test-alive host pid)
(let* ((same-host (equal? host (get-host-name)))
(cmd (conc
(if same-host "" (conc "ssh "host" "))
"pstree -A "pid)))
(if (and host pid
(not (equal? host "n/a")))
(let* ((output (if same-host
(with-input-from-pipe cmd read-lines)
(common:generic-ssh cmd read-lines '())))) ;; (with-input-from-pipe cmd read-lines)))
(debug:print 2 *default-log-port* "Running " cmd " received " output)
(if (eq? (length output) 0)
#f
#t))
#t))) ;; assuming bad query is about a live test is likely not the right thing to do?
)
|