~ chicken-core (chicken-5) /tests/posix-tests.scm

  1(import (chicken bitwise)
  2	(chicken pathname)
  3        (chicken file)
  4        (chicken file posix)
  5        (chicken platform)
  6        (chicken process)
  7        (chicken process-context)
  8        (chicken memory representation))
  9
 10(include "programs-path.scm")
 11
 12(define-syntax assert-error
 13  (syntax-rules ()
 14    ((_ expr) 
 15     (assert (handle-exceptions _ #t expr #f)))))
 16
 17(define-constant SOME-POS 123456)
 18
 19(let ((tnpfilpn (create-temporary-file)))
 20  (let ((tmpfilno (file-open tnpfilpn (+ open/rdwr open/creat open/text))))
 21    (set-file-position! tmpfilno SOME-POS seek/end)
 22    (assert (= SOME-POS (file-position tmpfilno)))
 23    (file-close tmpfilno)
 24    (delete-file* tnpfilpn) ) )
 25
 26(let ((tnpfilpn (create-temporary-file)))
 27  (let ((tmpfilno (file-open tnpfilpn (+ open/rdwr open/creat open/text))))
 28    (let ((port (open-output-file* tmpfilno)))
 29      (set-file-position! port SOME-POS seek/end)
 30      (assert (= SOME-POS (file-position port)))
 31      (close-output-port port)
 32      (delete-file* tnpfilpn) ) ) )
 33
 34(assert-error (get-environment-variable "with\x00embedded-NUL"))
 35(assert-error (set-environment-variable! "with\x00embedded-NUL" "blabla"))
 36(assert-error (set-environment-variable! "blabla" "with\x00embedded-NUL"))
 37(assert-error (system "echo this is \x00 not okay"))
 38;; Use "false" to signal to the calling script that there was an error,
 39;; even if the process will get called
 40(assert-error (process-execute "false\x00123"))
 41(assert-error (process-execute "false" '("1" "123\x00456")))
 42(assert-error (process-execute "false" '("123\x00456") '("foo\x00bar" "blabla") '("lalala" "qux\x00mooh")))
 43
 44(receive (in out pid)
 45    (process csi-path '("-n" "-I" ".." "-e"
 46                        "(write 'err (current-error-port)) (write 'ok)"))
 47  (assert (equal? 'ok (read in)))
 48  (newline (current-error-port)))
 49
 50(receive (in out pid err)
 51    (process* csi-path '("-n" "-I" ".." "-e"
 52                         "(write 'err (current-error-port)) (write 'ok)"))
 53  (assert (equal? 'ok (read in)))
 54  (assert (equal? 'err (read err))))
 55
 56;; delete-directory
 57(let* ((t (create-temporary-directory))
 58       (t/a (make-pathname t "a"))
 59       (t/a/file (make-pathname t/a "file"))
 60       (t/b (make-pathname t "b"))
 61       (t/b/c (make-pathname t/b "c"))
 62       (t/b/c/link (make-pathname t/b/c "link"))
 63       (t/b/c/.file (make-pathname t/b/c ".file")))
 64  ;; Create file under a:
 65  (create-directory t/a)
 66  (with-output-to-file t/a/file void)
 67  ;; Create directories under b:
 68  (create-directory t/b/c/.file 'recursively)
 69  (assert (directory? t/b/c/.file))
 70  (when (or (feature? #:unix) (feature? #:cygwin))
 71    (create-symbolic-link t/a t/b/c/link)
 72    (assert (directory? t/b/c/link)))
 73  ;; Delete directory tree at b:
 74  (delete-directory t/b 'recursively)
 75  (assert (not (directory? t/b/c/.file)))
 76  (assert (not (directory? t/b/c/link)))
 77  (assert (not (directory? t/b/c)))
 78  (assert (not (directory? t/b)))
 79  ;; Make sure symlink wasn't followed:
 80  (assert (directory? t/a))
 81  (assert (regular-file? t/a/file))
 82  ;; Clean up temporary directory:
 83  (delete-directory t 'recursively)
 84  (assert (not (directory? t))))
 85
 86;; unset-environment-variable!
 87(set-environment-variable! "FOO" "bar")
 88(assert (equal? (get-environment-variable "FOO") "bar"))
 89(unset-environment-variable! "FOO")
 90(assert (not (get-environment-variable "FOO")))
 91
 92;; file creation and umask interaction
 93
 94;; For windows, the file must be writable before it can be deleted!
 95(define (delete-maybe-readonly-file filename)
 96  (cond-expand
 97    (windows (when (file-exists? filename)
 98	       (set-file-permissions! filename #o666)))
 99    (else))
100  (delete-file* filename))
101
102#+(not windows)
103(letrec-syntax ((test (syntax-rules ()
104                        ((test umask expected)
105                         (test umask "expected" expected "given"))
106                        ((test umask given expected)
107                         (test umask "expected" expected "given" given))
108                        ((test umask "expected" expected "given" given ...)
109                         (let ((mode (file-creation-mode)))
110                           (set! (file-creation-mode) umask)
111                           (delete-file* "posix-tests.out")
112                           (file-close (file-open "posix-tests.out" open/creat given ...))
113                           (assert (equal? (file-permissions "posix-tests.out") expected))
114                           (set! (file-creation-mode) mode))))))
115  ;; default file mode
116  (test #o000 #o666)
117  (test #o002 #o664)
118  (test #o020 #o646)
119  (test #o022 #o644)
120  (test #o027 #o640)
121  (test #o072 #o604)
122  (test #o077 #o600)
123  (test #o777 #o000)
124  ;; explicit file mode argument
125  (test #o000 #o644 #o644)
126  (test #o002 #o644 #o644)
127  (test #o020 #o644 #o644)
128  (test #o022 #o644 #o644)
129  (test #o027 #o644 #o640)
130  (test #o072 #o644 #o604)
131  (test #o077 #o644 #o600)
132  (test #o777 #o644 #o000)
133  (test #o000 #o777 #o777)
134  (test #o002 #o777 #o775)
135  (test #o020 #o777 #o757)
136  (test #o022 #o777 #o755)
137  (test #o027 #o777 #o750)
138  (test #o072 #o777 #o705)
139  (test #o077 #o777 #o700)
140  (test #o777 #o777 #o000))