~ salmonella-environment-setup (master) 386bd0d65111d8f8d01afdb7dd51a2ba00fc5eec

commit 386bd0d65111d8f8d01afdb7dd51a2ba00fc5eec
Author:     Mario Domenech Goulart <mario@parenteses.org>
AuthorDate: Fri May 25 11:24:48 2018 +0200
Commit:     Mario Domenech Goulart <mario@parenteses.org>
CommitDate: Fri May 25 11:28:09 2018 +0200

    Add kill-orphan.scm
    
    At the moment it only works on Linux, but I believe it should work on
    FreeBSD with some cond-expand to handle the FreeBSD specific code
    related to /proc (that's why it is in the `common' directory).
    
    Eventually salmonella-run-publish should be able to deal with hanging
    process better (maybe by using process groups, as suggested by John
    Cowan).

diff --git a/scripts/common/kill-orphan.scm b/scripts/common/kill-orphan.scm
new file mode 100644
index 0000000..7dfb7e5
--- /dev/null
+++ b/scripts/common/kill-orphan.scm
@@ -0,0 +1,44 @@
+(use extras posix srfi-1 srfi-13)
+
+(define salmonella-home
+  ;; Change this to the directory where salmonella builds run.  This
+  ;; is the path on the Linux machines.
+  "/home/chicken/salmonella/build/salmonella-run-publish/")
+
+(define max-attempts-to-kill 10)
+
+(define (get-pids)
+  (filter-map string->number (directory "/proc")))
+
+(let ((pids (get-pids)))
+  (for-each
+   (lambda (pid)
+     (handle-exceptions exn
+        #f ;; ignore
+        (let* ((status-file (sprintf "/proc/~a/status" pid))
+               (parent-pid
+                (let loop ((lines (with-input-from-file status-file
+                                    read-lines)))
+                  (if (null? lines)
+                      #f
+                      (let ((line (car lines)))
+                        (if (string-prefix? "PPid:" line)
+                            (string->number (cadr (string-split line)))
+                            (loop (cdr lines)))))))
+               (command-line
+                (with-input-from-file (sprintf "/proc/~a/cmdline" pid)
+                  read-line)))
+          (if (and (eq? parent-pid 1)
+                   (string-prefix? salmonella-home command-line))
+              (let loop ((i 1))
+                (if (> i max-attempts-to-kill)
+                    (printf "Giving up at attempting to kill ~a\n" pid)
+                    (begin
+                      (printf "Killing ~a: ~a [cwd: ~a] (attempt ~a out of ~a)\n"
+                              command-line
+                              (read-symbolic-link (sprintf "/proc/~a/cwd" pid))
+                              pid i max-attempts-to-kill)
+                      (process-signal pid signal/kill)
+                      (when (memv pid (get-pids))
+                            (loop (fx+ i 1))))))))))
+   pids))