~ chicken-core (master) /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\x00;embedded-NUL"))
 35(assert-error (set-environment-variable! "with\x00;embedded-NUL" "blabla"))
 36(assert-error (set-environment-variable! "blabla" "with\x00;embedded-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\x00;123"))
 41(assert-error (process-execute "false" '("1" "123\x00;456")))
 42(assert-error (process-execute "false" '("123\x00;456") '(("foo\x00;bar" . "blabla") '("lalala" . "qux\x00;mooh"))))
 43
 44(let ((p (process csi-path '("-n" "-I" ".." "-e"
 45                        "(write 'err (current-error-port)) (write 'ok)"))))
 46  (assert (equal? 'ok (read (process-output-port p))))
 47  (newline (current-error-port)))
 48
 49(let ((p (process* csi-path '("-n" "-I" ".." "-e"
 50                         "(write 'err (current-error-port)) (write 'ok)"))))
 51  (assert (equal? 'ok (read (process-output-port p))))
 52  (assert (equal? 'err (read (process-error-port p)))))
 53
 54;; delete-directory
 55(let* ((t (create-temporary-directory))
 56       (t/a (make-pathname t "a"))
 57       (t/a/file (make-pathname t/a "file"))
 58       (t/b (make-pathname t "b"))
 59       (t/b/c (make-pathname t/b "c"))
 60       (t/b/c/link (make-pathname t/b/c "link"))
 61       (t/b/c/.file (make-pathname t/b/c ".file")))
 62  ;; Create file under a:
 63  (create-directory t/a)
 64  (with-output-to-file t/a/file void)
 65  ;; Create directories under b:
 66  (create-directory t/b/c/.file 'recursively)
 67  (assert (directory? t/b/c/.file))
 68  (when (or (feature? #:unix) (feature? #:cygwin))
 69    (create-symbolic-link t/a t/b/c/link)
 70    (assert (directory? t/b/c/link)))
 71  ;; Delete directory tree at b:
 72  (delete-directory t/b 'recursively)
 73  (assert (not (directory? t/b/c/.file)))
 74  (assert (not (directory? t/b/c/link)))
 75  (assert (not (directory? t/b/c)))
 76  (assert (not (directory? t/b)))
 77  ;; Make sure symlink wasn't followed:
 78  (assert (directory? t/a))
 79  (assert (regular-file? t/a/file))
 80  ;; Clean up temporary directory:
 81  (delete-directory t 'recursively)
 82  (assert (not (directory? t))))
 83
 84;; unset-environment-variable!
 85(set-environment-variable! "FOO" "bar")
 86(assert (equal? (get-environment-variable "FOO") "bar"))
 87(unset-environment-variable! "FOO")
 88(assert (not (get-environment-variable "FOO")))
 89
 90;; file creation and umask interaction
 91
 92;; For windows, the file must be writable before it can be deleted!
 93(define (delete-maybe-readonly-file filename)
 94  (cond-expand
 95    (windows (when (file-exists? filename)
 96	       (set-file-permissions! filename #o666)))
 97    (else))
 98  (delete-file* filename))
 99
100#+(not windows)
101(letrec-syntax ((test (syntax-rules ()
102                        ((test umask expected)
103                         (test umask "expected" expected "given"))
104                        ((test umask given expected)
105                         (test umask "expected" expected "given" given))
106                        ((test umask "expected" expected "given" given ...)
107                         (let ((mode (file-creation-mode)))
108                           (set! (file-creation-mode) umask)
109                           (delete-file* "posix-tests.out")
110                           (file-close (file-open "posix-tests.out" open/creat given ...))
111                           (assert (equal? (file-permissions "posix-tests.out") expected))
112                           (set! (file-creation-mode) mode))))))
113  ;; default file mode
114  (test #o000 #o666)
115  (test #o002 #o664)
116  (test #o020 #o646)
117  (test #o022 #o644)
118  (test #o027 #o640)
119  (test #o072 #o604)
120  (test #o077 #o600)
121  (test #o777 #o000)
122  ;; explicit file mode argument
123  (test #o000 #o644 #o644)
124  (test #o002 #o644 #o644)
125  (test #o020 #o644 #o644)
126  (test #o022 #o644 #o644)
127  (test #o027 #o644 #o640)
128  (test #o072 #o644 #o604)
129  (test #o077 #o644 #o600)
130  (test #o777 #o644 #o000)
131  (test #o000 #o777 #o777)
132  (test #o002 #o777 #o775)
133  (test #o020 #o777 #o757)
134  (test #o022 #o777 #o755)
135  (test #o027 #o777 #o750)
136  (test #o072 #o777 #o705)
137  (test #o077 #o777 #o700)
138  (test #o777 #o777 #o000))