From 526ce502e5b7bce1e3577696b2c41564f7248920 Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin <mthl@gnu.org>
Date: Sat, 24 Mar 2018 14:03:54 +0100
Subject: base: Box 'number-children'

* src/mcron/base.scm (number-children): Box it using SRFI-111 to be
explicit about the mutability of this object.
(update-number-children!): New procedure.
(run-job, child-cleanup): Use it.
* tests/base.scm ("update-number-children!: 1+")
("number-children: init", "update-number-children!: 1-"): New tests.
---
 src/mcron/base.scm | 21 +++++++++++++++------
 tests/base.scm     | 32 ++++++++++++++++++++++++++++++++
 2 files changed, 47 insertions(+), 6 deletions(-)

diff --git a/src/mcron/base.scm b/src/mcron/base.scm
index 2f1c060..17ddd5c 100644
--- a/src/mcron/base.scm
+++ b/src/mcron/base.scm
@@ -32,6 +32,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-111)
   #:export (add-job
             remove-user-jobs
             display-schedule
@@ -157,10 +158,18 @@ unusable."
                    jobs))))
     (display-schedule (- count 1) port #:schedule schedule)))
 
-;; For proper housekeeping, it is necessary to keep a record of the number of
-;; child processes we fork off to run the jobs.
+;;;
+;;; Running jobs
+;;;
+
+(define number-children
+  ;; For proper housekeeping, it is necessary to keep a record of the number
+  ;; of child processes we fork off to run the jobs.
+  (box 0))
 
-(define number-children 0)
+(define (update-number-children! proc)
+  ;; Apply PROC to the value stored in 'number-children'.
+  (set-box! number-children (proc (unbox number-children))))
 
 (define (run-job job)
   "Run JOB in a separate process. The process is run as JOB user with the
@@ -178,16 +187,16 @@ next value."
         (λ ()
           (primitive-exit 0)))
       (begin                            ;parent
-        (set! number-children (+ number-children 1))
+        (update-number-children! 1+)
         (job:next-time-set! job ((job:next-time-function job)
                                  (current-time))))))
 
 (define (child-cleanup)
   ;; Give any zombie children a chance to die, and decrease the number known
   ;; to exist.
-  (unless (or (<= number-children 0)
+  (unless (or (<= (unbox number-children) 0)
               (= (car (waitpid WAIT_ANY WNOHANG)) 0))
-    (set! number-children (- number-children 1))
+    (update-number-children! 1-)
     (child-cleanup)))
 
 (define* (run-job-loop #:optional fd-list #:key (schedule %global-schedule))
diff --git a/tests/base.scm b/tests/base.scm
index 89b7349..d7a2dbd 100644
--- a/tests/base.scm
+++ b/tests/base.scm
@@ -17,6 +17,7 @@
 ;;; along with GNU Mcron.  If not, see <http://www.gnu.org/licenses/>.
 
 (use-modules (srfi srfi-64)
+             (srfi srfi-111)
              (mcron base))
 
 (test-begin "base")
@@ -148,4 +149,35 @@
     (with-output-to-string
       (λ () (display-schedule 1 #:schedule schdl)))))
 
+;;;
+;;; Running jobs
+;;;
+
+;;; Import private global.
+(define number-children (@@ (mcron base) number-children))
+
+;;; Import private procedures.
+(define update-number-children! (@@ (mcron base) update-number-children!))
+
+;;; Check 'number-children' initial value.
+(let ((schdl (make-schedule '() '() 'user)))
+  (test-equal "number-children: init"
+    0
+    (unbox number-children)))
+
+;;; Check 'update-number-children!' incrementation.
+(let ((schdl (make-schedule '() '() 'user)))
+  (update-number-children! 1+)
+  (update-number-children! 1+)
+  (test-equal "update-number-children!: 1+"
+    2
+    (unbox number-children)))
+
+;;; Check 'update-number-children!' decrementation.
+(let ((schdl (make-schedule '() '() 'user)))
+  (update-number-children! 1-)
+  (test-equal "update-number-children!: 1-"
+    1
+    (unbox number-children)))
+
 (test-end)
-- 
cgit v1.2.3