test-suite/tests/posix.test

   1 ;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright 2003, 2004, 2006, 2007, 2010, 2012 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library 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 GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-suite test-posix)
  20   :use-module (test-suite lib))
  21
  22
  23 ;; FIXME: The following exec tests are disabled since on an i386 debian with
  24 ;; glibc 2.3.2 they seem to interact badly with threads.test, the latter
  25 ;; dies with signal 32 (one of the SIGRTs).  Don't know how or why, or who's
  26 ;; at fault (though it seems to happen with or without the recent memory
  27 ;; leak fix in these error cases).
  28
  29 ;;
  30 ;; execl
  31 ;;
  32
  33 ;; (with-test-prefix "execl"
  34 ;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
  35 ;;     (execl "./nosuchprog" "./nosuchprog" "some arg")))
  36
  37 ;;
  38 ;; execlp
  39 ;;
  40
  41 ;; (with-test-prefix "execlp"
  42 ;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
  43 ;;     (execlp "./nosuchprog" "./nosuchprog" "some arg")))
  44
  45 ;;
  46 ;; execle
  47 ;;
  48
  49 ;; (with-test-prefix "execle"
  50 ;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
  51 ;;     (execle "./nosuchprog" '() "./nosuchprog" "some arg"))
  52 ;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
  53 ;;     (execle "./nosuchprog" '("FOO=1" "BAR=2") "./nosuchprog" "some arg")))
  54
  55
  56 ;;
  57 ;; mkstemp!
  58 ;;
  59
  60 (with-test-prefix "mkstemp!"
  61
  62   ;; the temporary names used in the tests here are kept to 8 characters so
  63   ;; they'll work on a DOS 8.3 file system
  64
  65   (define (string-copy str)
  66     (list->string (string->list str)))
  67
  68   (pass-if-exception "number arg" exception:wrong-type-arg
  69     (mkstemp! 123))
  70
  71   (pass-if "filename string modified"
  72     (let* ((template "T-XXXXXX")
  73            (str      (string-copy template))
  74            (port     (mkstemp! str))
  75            (result   (not (string=? str template))))
  76       (close-port port)
  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 ;; utimes
 166 ;;
 167
 168 (with-test-prefix "utime"
 169
 170   (pass-if "valid argument (second resolution)"
 171     (let ((file "posix.test-utime"))
 172       (dynamic-wind
 173         (lambda ()
 174           (close-port (open-output-file file)))
 175         (lambda ()
 176           (let* ((accessed (+ (current-time) 3600))
 177                  (modified (- accessed 1000)))
 178             (utime file accessed modified)
 179             (let ((info (stat file)))
 180               (and (= (stat:atime info) accessed)
 181                    (= (stat:mtime info) modified)))))
 182         (lambda ()
 183           (delete-file file))))))
 184
 185 ;;
 186 ;; affinity
 187 ;;
 188
 189 (with-test-prefix "affinity"
 190
 191   (pass-if "getaffinity"
 192     (if (defined? 'getaffinity)
 193         (> (bitvector-length (getaffinity (getpid))) 0)
 194         (throw 'unresolved)))
 195
 196   (pass-if "setaffinity"
 197     (if (and (defined? 'setaffinity) (defined? 'getaffinity))
 198         (let ((mask (getaffinity (getpid))))
 199           (setaffinity (getpid) mask)
 200           (equal? mask (getaffinity (getpid))))
 201         (throw 'unresolved))))
 202
 203 ;;
 204 ;; system*
 205 ;;
 206
 207 (with-test-prefix "system*"
 208
 209   (pass-if "http://bugs.gnu.org/13166"
 210     ;; With Guile up to 2.0.7 included, the child process launched by
 211     ;; `system*' would remain alive after an `execvp' failure.
 212     (let ((me (getpid)))
 213       (and (not (zero? (system* "something-that-does-not-exist")))
 214            (= me (getpid))))))