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