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