1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber, Robert Ransom
4
5; A test suite for the POSIX interface.
6
7(define-test-suite posix-core-tests)
8(define-test-suite disabled-posix-core-tests) ; signals
9
10; 1. get the process ID
11; 2. make a /tmp/s48-posix-test-<pid> directory
12; 3. go there and make files, etc.
13
14(define initial-wd (working-directory))
15
16; doesn't work on Mac OS X
17
18(define directory-name
19  (string-append "/tmp/s48-posix-test-"
20		 (number->string (process-id->integer (get-process-id)))))
21
22(define-test-case file-mode-predicates posix-core-tests
23  (let ((mode0 (file-mode set-uid owner-read group-write other-exec))
24	(mode1 (file-mode set-uid))
25	(mode2 (file-mode owner-read group-write))
26	(mode3 (file-mode set-uid other-exec)))
27
28    (check (file-mode? mode0))
29    (check (not (file-mode? 'mode0)))
30
31    (check (file-mode=? mode0 mode0))
32    (check (not (file-mode=? mode0 mode1)))
33
34    (check (file-mode<=? mode0 mode0))
35    (check (not (file-mode<=? mode0 mode1)))
36    (check (file-mode<=? mode1 mode0))
37
38    (check (file-mode>=? mode0 mode0))
39    (check (file-mode>=? mode0 mode1))
40    (check (not (file-mode>=? mode1 mode0)))
41
42    (for-each (lambda (x)
43		(check (file-mode=? x
44				    (integer->file-mode
45				     (file-mode->integer x)))))
46	      (list mode0 mode1 mode2 mode3))))
47
48(define-test-case file-modes posix-core-tests
49  (let ((mode0 (file-mode set-uid owner-read group-write other-exec))
50	(mode1 (file-mode set-uid))
51	(mode2 (file-mode owner-read group-write))
52	(mode3 (file-mode set-uid other-exec)))
53
54    (check (file-mode->integer mode0) => #o4421)
55    (check (file-mode->integer mode1) => #o4000)
56
57    (check (file-mode->integer (file-mode+)) => #o0000)
58    (check (file-mode->integer (file-mode+ mode1)) => #o4000)
59    (check (file-mode->integer (file-mode+ mode1 mode2 mode3)) => #o4421)
60
61    (check (file-mode->integer (file-mode- mode0 mode3)) => #o0420)
62
63    (check (file-mode->integer (file-mode other-exec)) => 1)
64    (check (file-mode->integer (file-mode other-write)) => 2)
65    (check (file-mode->integer (file-mode other-read)) => 4)
66    (check (file-mode->integer (file-mode group-exec)) => 8)
67    (check (file-mode->integer (file-mode group-write)) => 16)
68    (check (file-mode->integer (file-mode group-read)) => 32)
69    (check (file-mode->integer (file-mode owner-exec)) => 64)
70    (check (file-mode->integer (file-mode owner-write)) => 128)
71    (check (file-mode->integer (file-mode owner-read)) => 256)
72    (check (file-mode->integer (file-mode set-gid)) => 1024)
73    (check (file-mode->integer (file-mode set-uid)) => 2048)
74
75    (check (file-mode->integer (file-mode other)) => 7)
76    (check (file-mode->integer (file-mode group)) => 56)
77    (check (file-mode->integer (file-mode owner)) => 448)
78    (check (file-mode->integer (file-mode exec)) => 73)
79    (check (file-mode->integer (file-mode write)) => 146)
80    (check (file-mode->integer (file-mode read)) => 292)
81    (check (file-mode->integer (file-mode all)) => 511)))
82
83(define-test-case make-directory posix-core-tests
84  (check (begin
85	   (make-directory directory-name (integer->file-mode #o700))
86	   (file-info-type (get-file-info directory-name)))
87	 => (file-type directory)))
88
89(define-test-case time posix-core-tests
90  (sleep 3000)				; three seconds
91  (let ((now (current-time))
92	(dir-time (file-info-last-modification
93		   (get-file-info directory-name))))
94    (check (time? now))
95    (check (time? dir-time))
96    (check (not (time? 'now)))
97    (check (not (time? 20)))
98
99    (check (time=? now now))
100    (check (not (time=? now dir-time)))
101    (check (not (time=? dir-time now)))
102    (check (time=? dir-time dir-time))
103
104    (check (not (time<? now now)))
105    (check (not (time<? now dir-time)))
106    (check (time<? dir-time now))
107    (check (not (time<? dir-time dir-time)))
108
109    (check (not (time>? now now)))
110    (check (time>? now dir-time))
111    (check (not (time>? dir-time now)))
112    (check (not (time>? dir-time dir-time)))
113
114    (check (time<=? now now))
115    (check (not (time<=? now dir-time)))
116    (check (time<=? dir-time now))
117    (check (time<=? dir-time dir-time))
118
119    (check (time>=? now now))
120    (check (time>=? now dir-time))
121    (check (not (time>=? dir-time now)))
122    (check (time>=? dir-time dir-time))
123
124    (check (time-seconds now) => (time-seconds now))
125    (check (not (= (time-seconds now) (time-seconds dir-time))))
126
127    (check (time=? now (make-time (time-seconds now))))
128    (check (not (time=? now (make-time (time-seconds dir-time)))))
129    (check (not (time=? dir-time (make-time (time-seconds now)))))
130    (check (time=? dir-time (make-time (time-seconds dir-time))))
131
132    (check (string? (time->string now)))))
133
134(define-test-case set-working-directory! posix-core-tests
135  (set-working-directory! directory-name)
136  ;; On Mac OS X, /tmp is soft-linked to /private/tmp
137  (let ((normalized-wd (os-string->string (working-directory))))
138    (set-working-directory! normalized-wd)
139    (check (os-string->string (working-directory)) => normalized-wd)))
140
141(define-test-case i/o-flags posix-core-tests
142  (let* ((out (open-file "file0"
143			 (file-options create write-only)
144			 (integer->file-mode #o700)))
145	 (flags (i/o-flags out)))
146    (display "123456" out)
147    (newline out)
148    (close-output-port out)
149    (check (not (file-options-on? flags (file-options append))))
150    (check (not (file-options-on? flags (file-options synchronized-data))))
151    (check (file-options-on? flags (file-options nonblocking)))
152    (check (not (file-options-on? flags (file-options synchronized-read))))
153    (check (not (file-options-on? flags (file-options synchronized))))
154    (check (not (file-options-on? flags (file-options read-only))))
155    (check (not (file-options-on? flags (file-options read-write))))
156    (check (file-options-on? flags (file-options write-only)))))
157
158(define-test-case append-mode posix-core-tests
159  (let* ((old-size (file-info-size (get-file-info "file0")))
160	 (out (open-file "file0"
161			 (file-options append write-only))))
162    (display "123456" out)
163    (newline out)
164    (close-output-port out)
165    (check old-size => 7)
166    (check (file-info-size (get-file-info "file0")) => 14)))
167
168(define-test-case file-times posix-core-tests
169  (let ((old-info (get-file-info "file0")))
170    (sleep 3000)			; three seconds
171    (let ((in (open-file "file0"
172			 (file-options read-only))))
173      (read-char in)
174      (close-input-port in))
175    (let ((new-info (get-file-info "file0")))
176      (check-that (file-info-last-modification old-info)
177		  (is time=? (file-info-last-modification new-info)))
178      ;; On Linux, file-systems may be mounted using the "noatime"
179      ;; option.  That is, just reading the file does not necessarily
180      ;; update the access time.  Hence, we use TIME<=? instead of
181      ;; TIME<? (which makes this test less useful).
182      (check-that (file-info-last-access old-info)
183		  (is time<=? (file-info-last-access new-info))))))
184
185(define-test-case link posix-core-tests
186  (let ((old-link-count (file-info-link-count (get-file-info "file0"))))
187    (link "file0" "link-to-file0")
188    (check old-link-count => 1)
189    (check (file-info-link-count (get-file-info "file0")) => 2)))
190
191(define-test-case rename posix-core-tests
192  (let ((inode (file-info-inode (get-file-info "file0"))))
193    (rename "file0" "file1")
194    (check (file-info-inode (get-file-info "file1"))
195	   => inode)))
196
197(define-test-case listings0 posix-core-tests
198  (let ((directory (open-directory-stream directory-name)))
199    (let loop ((names '()))
200      (let ((next (read-directory-stream directory)))
201	(if next
202	    (loop (cons next names))
203	    (begin
204	      (close-directory-stream directory)
205	      (check
206	       (sort-list (map os-string->string names) string<=?)
207	       => '("file1" "link-to-file0"))))))))
208
209(define-test-case listings1 posix-core-tests
210  (check (sort-list (map os-string->string (list-directory ".")) string<=?)
211	 => '("file1" "link-to-file0")))
212
213(define-test-case unlink posix-core-tests
214  (unlink "link-to-file0")
215  (check (file-info-link-count (get-file-info "file1")) => 1))
216
217(define-test-case umask posix-core-tests
218  (let* ((old-mask (set-file-creation-mask! (integer->file-mode #o012)))
219	 (out (open-file "umask-file"
220			 (file-options create write-only)
221			 (integer->file-mode #o777))))
222    (display "123456" out)
223    (newline out)
224    (close-output-port out)
225    (let* ((my-mask (set-file-creation-mask! old-mask))
226	   (file-mode (file-info-mode (get-file-info "umask-file"))))
227      (check (file-mode->integer my-mask) => #o012)
228      (check (file-mode->integer file-mode) => #o765))))
229
230; This assumes that we are not running as root and that / is owned by root.
231
232(define-test-case users&groups posix-core-tests
233  (let ((my-info (get-file-info directory-name))
234	(root-info (get-file-info "/")))
235    (let ((my-user (user-id->user-info (file-info-owner my-info)))
236	  (root-user (user-id->user-info (file-info-owner root-info)))
237	  (my-group (group-id->group-info (file-info-group my-info)))
238	  (root-group (group-id->group-info (file-info-group root-info))))
239      (let ((my-other-user (name->user-info (user-info-name my-user)))
240	    (my-other-group (name->group-info (group-info-name my-group))))
241	(check-that (file-info-owner my-info)
242		    (is user-id=? (user-info-id my-user)))
243	(check-that (file-info-owner root-info)
244		    (opposite (is user-id=? (user-info-id my-user))))
245	(check-that (file-info-group my-info)
246		    (is group-id=? (group-info-id my-group)))
247	;; doesn't work reliably
248	;; (specifically, if the user is member of wheel)
249	;; (check (not (group-id=? (file-info-group root-info)
250	;;		(group-info-id my-group))))
251	(check-that (os-string->string (user-info-name root-user))
252		    (member-of '("root"
253				 "bin" ; AIX
254				 )))))))
255
256(define-test-case environment posix-core-tests
257  (let ((env (reverse (environment-alist))))
258    (if (not (null? env))
259	(check-that (lookup-environment-variable->string (caar env))
260		    (is (os-string->string (cdar env)))))
261    (for-each (lambda (x)
262		(check-that x (is pair?))
263		(check-that (car x) (is os-string?))
264		(check-that (cdr x) (is os-string?)))
265	      env))
266  (check-that (lookup-environment-variable->string "=") (is-false)))
267
268(define-test-case symlinks posix-core-tests
269  (let ((name (string-append directory-name "/blabla")))
270    (create-symbolic-link "foo" name)
271    (check (os-string->string (read-symbolic-link name)) => "foo")
272    (unlink name)))
273
274; This assumes that no other process will send us SIGUSR1 or SIGUSR2.
275
276; TODO - move to utility package
277(define-syntax if-let
278  (syntax-rules ()
279    ((if-let var test true-expr false-expr)
280     (let ((var test)) (if var true-expr false-expr)))
281    ((if-let var test true-expr)
282     (let ((var test)) (if var true-expr)))))
283
284(define-syntax spawn-named
285  (syntax-rules ()
286    ((spawn-named thunk-name)
287     (spawn thunk-name 'thunk-name))))
288
289(define-test-case signals disabled-posix-core-tests
290  (let* ((sigusr1 (signal usr1))
291         (sigusr2 (signal usr2))
292         (sigq (make-signal-queue (list sigusr1 sigusr2)))
293         (me (get-process-id))
294         (sigs-caught-queue (make-queue))
295         (sigs-caught-lists-ph (make-placeholder)))
296    (define (send-signal! sig)
297      (signal-process me sig)
298      ; FIXME - make the VM check for and handle all interrupts here
299      (sleep 100)
300      (let loop ((sigs-caught-rev '()))
301        (if-let maybe-sig (maybe-dequeue! sigs-caught-queue)
302                (loop (cons maybe-sig sigs-caught-rev))
303                (reverse sigs-caught-rev))))
304    (define (send-signals!)
305      (placeholder-set! sigs-caught-lists-ph
306                        (map send-signal!
307                             (list sigusr1
308                                   sigusr2
309                                   sigusr1
310                                   sigusr2
311                                   sigusr1))))
312    (define (catch-signals!)
313      (let loop ()
314        (let ((sig (dequeue-signal! sigq)))
315          (enqueue! sigs-caught-queue sig))
316        (loop)))
317    (define (signal-list=? l1 l2)
318      (srfi-1:list= signal=? l1 l2))
319    (define (signal-list-list=? l1 l2)
320      (srfi-1:list= signal-list=? l1 l2))
321    (let* ((catch-thread (spawn-named catch-signals!))
322           (send-thread (spawn-named send-signals!))
323           (signals-received (placeholder-value sigs-caught-lists-ph))) ;blocks
324      (check-that signals-received
325                  (is signal-list-list=? (list (list sigusr1)
326                                               (list sigusr2)
327                                               (list sigusr1)
328                                               (list sigusr2)
329                                               (list sigusr1))))
330      (terminate-thread! catch-thread))))
331
332(define (fork-spawn thunk)
333  (or (fork)
334      (begin (thunk)
335             (exit 0))))
336
337(define-syntax fork-and-run
338  (syntax-rules ()
339    ((fork-and-run body ...)
340     (fork-spawn (lambda () body ...)))))
341
342(define-test-case wait-for-child-process posix-core-tests
343  (let* ((n-waiters 50)
344         (waiter-results (make-vector n-waiters #f))
345         (child-pid (fork-and-run (sleep 5000)))
346         (waiter-threads
347          (map (lambda (i)
348                 (spawn (lambda ()
349                          (wait-for-child-process child-pid)
350                          (vector-set! waiter-results i #t))))
351               (srfi-1:iota n-waiters))))
352    (sleep 10000)
353    (check waiter-results => (make-vector n-waiters #t))))
354
355; This should be last, because it removes the directory.
356
357(define-test-case rmdir posix-core-tests
358  (let ((before (accessible? directory-name (access-mode exists))))
359    (for-each unlink (list-directory "."))
360    (set-working-directory! initial-wd)
361    (remove-directory directory-name)
362    (check before)
363    (check (not (accessible? directory-name (access-mode exists))))))
364