blob: eb9e11ab9031f7320c7210c8b93ef0b9d1aee769 (
about) (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
|
;;;; base.scm -- tests for (mcron base) module
;;; Copyright © 2018 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This file is part of GNU Mcron.
;;;
;;; GNU Mcron 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.
;;;
;;; GNU Mcron 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 GNU Mcron. If not, see <http://www.gnu.org/licenses/>.
(use-modules (srfi srfi-64)
(srfi srfi-111)
(mcron base))
(test-begin "base")
(setlocale LC_ALL "C")
(setenv "TZ" "UTC0")
;;; Import private procedures.
(define make-schedule (@@ (mcron base) make-schedule))
(define schedule-current (@@ (mcron base) schedule-current))
(define schedule-user (@@ (mcron base) schedule-user))
(define schedule-system (@@ (mcron base) schedule-system))
(define make-job (@@ (mcron base) make-job))
(define find-next-jobs (@@ (mcron base) find-next-jobs))
(define %user0 #("user0" "x" 0 0 "user0" "/var/empty" "/bin/sh"))
(define %user1 #("user1" "x" 1 1 "user1" "/var/empty" "/bin/sh"))
(define* (make-dummy-job #:optional (displayable "dummy")
#:key
(user (getpw))
(time-proc 1+)
(action (λ () "dummy action"))
(environment '())
(next-time 0))
(make-job user time-proc action environment displayable next-time))
;;; Check 'use-system-job-list' and 'use-user-job-list' effect
(let ((schdl (make-schedule '() '() 'user)))
(use-system-job-list #:schedule schdl)
(test-eq "use-system-job-list"
'system
(schedule-current schdl))
(use-user-job-list #:schedule schdl)
(test-eq "use-user-job-list"
'user
(schedule-current schdl)))
;;; Check that 'remove-user-jobs' with only one type of user job clears the
;;; schedule.
(let* ((job (make-dummy-job #:user %user0))
(schdl (make-schedule (list job) '() 'user)))
(remove-user-jobs %user0 #:schedule schdl)
(test-equal "remove-user-jobs: only one"
'()
(schedule-user schdl)))
;;; Check that 'remove-user-jobs' with only two types of user jobs keep the
;;; other user jobs in the schedule.
(let* ((job0 (make-dummy-job #:user %user0))
(job1 (make-dummy-job #:user %user1))
(schdl (make-schedule (list job0 job1) '() 'user)))
(remove-user-jobs %user0 #:schedule schdl)
(test-equal "remove-user-jobs: keep one"
(list job1)
(schedule-user schdl)))
;;; Check that 'clear-system-jobs' removes all system jobs and has no effect
;;; on the user jobs.
(let* ((job0 (make-dummy-job #:user %user0))
(job1 (make-dummy-job #:user %user1))
(schdl (make-schedule (list job0) (list job1) 'user)))
(clear-system-jobs #:schedule schdl)
(test-assert "clear-system-jobs: basic"
(and (equal? (list job0) (schedule-user schdl))
(equal? '() (schedule-system schdl)))))
;;; Check that 'add-job' adds a user job when the current schedule is 'user.
(let ((schdl (make-schedule '() '() 'user)))
(add-job 1+ (const #t) "job0" 0 "user" #:schedule schdl)
(test-assert "add-job: user schedule"
(and (= 1 (length (schedule-user schdl)))
(= 0 (length (schedule-system schdl))))))
;;; Check that 'add-job' adds a system job when the current schedule is
;;; 'system.
(let ((schdl (make-schedule '() '() 'system)))
(add-job 1+ (const #t) "job0" 0 "user" #:schedule schdl)
(test-assert "add-job: system schedule"
(and (= 0 (length (schedule-user schdl)))
(= 1 (length (schedule-system schdl))))))
;;; Check that 'find-next-jobs' find the soonest job.
(let* ((job0 (make-dummy-job #:user %user0 #:next-time 5))
(job1 (make-dummy-job #:user %user1 #:next-time 10))
(schdl (make-schedule (list job0) (list job1) 'user)))
(test-equal "find-next-jobs: basic"
(list 5 job0)
(find-next-jobs #:schedule schdl)))
;;; Check that 'find-next-jobs' can find multiple soonest jobs.
(let* ((job0 (make-dummy-job #:user %user0 #:next-time 5))
(job1 (make-dummy-job #:user %user1 #:next-time 5))
(schdl (make-schedule (list job0) (list job1) 'user)))
(test-equal "find-next-jobs: two jobs"
(list 5 job0 job1)
(find-next-jobs #:schedule schdl)))
;;; Check that 'find-next-jobs' returns #f when the schedule is empty.
(let ((schdl (make-schedule '() '() 'user)))
(test-equal "find-next-jobs: empty"
(list #f)
(find-next-jobs #:schedule schdl)))
;;; Check output of 'display-schedule' with a basic schedule.
(test-assert "display-schedule: basic"
(and (equal?
"Thu Jan 1 00:00:05 1970 +0000\ndummy\n\n"
(let* ((job0 (make-dummy-job #:user %user0 #:next-time 5))
(job1 (make-dummy-job #:user %user1 #:next-time 10))
(schdl (make-schedule (list job0) (list job1) 'user)))
(with-output-to-string
(λ () (display-schedule 1 #:schedule schdl)))))
(equal?
(string-append
"Thu Jan 1 00:00:05 1970 +0000\ndummy\n\n"
"Thu Jan 1 00:00:06 1970 +0000\ndummy\n\n")
(let* ((job0 (make-dummy-job #:user %user0 #:next-time 5))
(job1 (make-dummy-job #:user %user1 #:next-time 10))
(schdl (make-schedule (list job0) (list job1) 'user)))
(with-output-to-string
(λ () (display-schedule 2 #:schedule schdl)))))))
;;; Check output of 'display-schedule' with an empty schedule.
(let ((schdl (make-schedule '() '() 'user)))
(test-equal "display-schedule: empty"
""
(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!))
(define child-cleanup (@@ (mcron base) child-cleanup))
(define run-job (@@ (mcron base) run-job))
;;; Check 'number-children' initial value.
(test-equal "number-children: init"
0
(unbox number-children))
;;; Check 'update-number-children!' incrementation.
(test-equal "update-number-children!: 1+"
2
(begin
(update-number-children! 1+)
(update-number-children! 1+)
(unbox number-children)))
;;; Check 'update-number-children!' decrementation.
(test-equal "update-number-children!: 1-"
1
(begin
(update-number-children! 1-)
(unbox number-children)))
;;; Check 'update-number-children!' constant value.
(test-equal "update-number-children!: set value"
0
(begin
(update-number-children! (const 0))
(unbox number-children)))
;;; Check 'run-job' and 'child-cleanup'.
;;; XXX: Having to use the filesystem for a unit test is wrong.
(let* ((filename (tmpnam))
(action (λ () (close-port (open-output-file filename))))
(job (make-dummy-job #:user (getpw (getuid)) #:action action)))
(dynamic-wind
(const #t)
(λ ()
(sigaction SIGCHLD (const #t))
(run-job job)
;; Wait for the SIGCHLD signal sent when job exits.
(pause)
;; Check 'run-job' result and if the number of children is up-to-date.
(test-equal "run-job: basic"
1
(and (access? filename F_OK)
(unbox number-children)))
(child-cleanup)
;; Check that 'child-cleanup' updates the number of children.
(test-equal "child-cleanup: one" 0 (unbox number-children)))
(λ ()
(and (access? filename F_OK) (delete-file filename))
(sigaction SIGCHLD SIG_DFL))))
(test-end)
|
