1;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*-
2;;;;
3;;;; Copyright 2003, 2004, 2006, 2007 Free Software Foundation, Inc.
4;;;;
5;;;; This program is free software; you can redistribute it and/or modify
6;;;; it under the terms of the GNU General Public License as published by
7;;;; the Free Software Foundation; either version 2, or (at your option)
8;;;; any later version.
9;;;;
10;;;; This program is distributed in the hope that it will be useful,
11;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13;;;; GNU General Public License for more details.
14;;;;
15;;;; You should have received a copy of the GNU General Public License
16;;;; along with this software; see the file COPYING.  If not, write to
17;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
18;;;; Boston, MA 02110-1301 USA
19
20(define-module (test-suite test-posix)
21  :use-module (test-suite lib))
22
23
24;; FIXME: The following exec tests are disabled since on an i386 debian with
25;; glibc 2.3.2 they seem to interact badly with threads.test, the latter
26;; dies with signal 32 (one of the SIGRTs).  Don't know how or why, or who's
27;; at fault (though it seems to happen with or without the recent memory
28;; leak fix in these error cases).
29
30;;
31;; execl
32;;
33
34;; (with-test-prefix "execl"
35;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
36;;     (execl "./nosuchprog" "./nosuchprog" "some arg")))
37
38;;
39;; execlp
40;;
41
42;; (with-test-prefix "execlp"
43;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
44;;     (execlp "./nosuchprog" "./nosuchprog" "some arg")))
45
46;;
47;; execle
48;;
49
50;; (with-test-prefix "execle"
51;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
52;;     (execle "./nosuchprog" '() "./nosuchprog" "some arg"))
53;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
54;;     (execle "./nosuchprog" '("FOO=1" "BAR=2") "./nosuchprog" "some arg")))
55
56
57;;
58;; mkstemp!
59;;
60
61(with-test-prefix "mkstemp!"
62
63  ;; the temporary names used in the tests here are kept to 8 characters so
64  ;; they'll work on a DOS 8.3 file system
65
66  (define (string-copy str)
67    (list->string (string->list str)))
68
69  (pass-if-exception "number arg" exception:wrong-type-arg
70    (mkstemp! 123))
71
72  (pass-if "filename string modified"
73    (let* ((template "T-XXXXXX")
74	   (str      (string-copy template))
75	   (port     (mkstemp! str))
76	   (result   (not (string=? str template))))
77      (delete-file str)
78      result)))
79
80;;
81;; putenv
82;;
83
84(with-test-prefix "putenv"
85
86  (pass-if "something"
87    (putenv "FOO=something")
88    (equal? "something" (getenv "FOO")))
89
90  (pass-if "replacing"
91    (putenv "FOO=one")
92    (putenv "FOO=two")
93    (equal? "two" (getenv "FOO")))
94
95  (pass-if "empty"
96    (putenv "FOO=")
97    (equal? "" (getenv "FOO")))
98
99  (pass-if "removing"
100    (putenv "FOO=bar")
101    (putenv "FOO")
102    (not (getenv "FOO")))
103
104  (pass-if "modifying string doesn't change env"
105    (let ((s (string-copy "FOO=bar")))
106      (putenv s)
107      (string-set! s 5 #\x)
108      (equal? "bar" (getenv "FOO")))))
109
110;;
111;; setenv
112;;
113
114(with-test-prefix "setenv"
115
116  (pass-if "something"
117    (setenv "FOO" "something")
118    (equal? "something" (getenv "FOO")))
119
120  (pass-if "replacing"
121    (setenv "FOO" "one")
122    (setenv "FOO" "two")
123    (equal? "two" (getenv "FOO")))
124
125  (pass-if "empty"
126    (setenv "FOO" "")
127    (equal? "" (getenv "FOO")))
128
129  (pass-if "removing"
130    (setenv "FOO" "something")
131    (setenv "FOO" #f)
132    (not (getenv "FOO"))))
133
134;;
135;; unsetenv
136;;
137
138(with-test-prefix "unsetenv"
139
140  (pass-if "something"
141    (putenv "FOO=something")
142    (unsetenv "FOO")
143    (not (getenv "FOO")))
144
145  (pass-if "empty"
146    (putenv "FOO=")
147    (unsetenv "FOO")
148    (not (getenv "FOO"))))
149
150;;
151;; ttyname
152;;
153
154(with-test-prefix "ttyname"
155
156  (pass-if-exception "non-tty argument" exception:system-error
157    ;; This used to crash in 1.8.1 and earlier.
158    (let ((file (false-if-exception
159                 (open-output-file "/dev/null"))))
160      (if (not file)
161          (throw 'unsupported)
162          (ttyname file)))))
163
164
165