guile/test-suite/tests/posix.test

;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*-
;;;;
;;;; Copyright 2003-2004, 2006-2007, 2010, 2012, 2015, 2017-2019, 2021-2023
;;;;   Free Software Foundation, Inc.
;;;; Copyright 2021 Maxime Devos <maximedevos@telenet.be>
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-posix)
  #:use-module (test-suite lib)
  #:use-module ((rnrs io ports) #:select (get-string-all)))

(define (skip-on-darwin)
  (when (string-ci=? "darwin" (utsname:sysname (uname)))
    (throw 'untested)))

;; FIXME: The following exec tests are disabled since on an i386 debian with
;; glibc 2.3.2 they seem to interact badly with threads.test, the latter
;; dies with signal 32 (one of the SIGRTs).  Don't know how or why, or who's
;; at fault (though it seems to happen with or without the recent memory
;; leak fix in these error cases).

;;
;; execl
;;

;; (with-test-prefix "execl"
;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
;;     (execl "./nosuchprog" "./nosuchprog" "some arg")))
  
;;
;; execlp
;;

;; (with-test-prefix "execlp"
;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
;;     (execlp "./nosuchprog" "./nosuchprog" "some arg")))
  
;;
;; execle
;;

;; (with-test-prefix "execle"
;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
;;     (execle "./nosuchprog" '() "./nosuchprog" "some arg"))
;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
;;     (execle "./nosuchprog" '("FOO=1" "BAR=2") "./nosuchprog" "some arg")))

  
;;
;; mkstemp
;;

(with-test-prefix "mkstemp"

  ;; the temporary names used in the tests here are kept to 8 characters so
  ;; they'll work on a DOS 8.3 file system

  (define (string-copy str)
    (list->string (string->list str)))

  (pass-if-exception "number arg" exception:wrong-type-arg
    (mkstemp! 123))

  (pass-if "binary mode honored"
    (let* ((outport  (mkstemp "T-XXXXXX" "wb"))
           (filename (port-filename outport)))
      (display "\n" outport)
      (close-port outport)
      (let* ((inport (open-input-file filename #:binary #t))
             (char1  (read-char inport))
             (char2  (read-char inport))
             (result (and (char=? char1 #\newline)
                          (eof-object? char2))))
        (close-port inport)
        (delete-file filename)
        result))))

;;
;; putenv
;;

(with-test-prefix "putenv"
  
  (pass-if "something"
    (putenv "FOO=something")
    (equal? "something" (getenv "FOO")))
  
  (pass-if "replacing"
    (putenv "FOO=one")
    (putenv "FOO=two")
    (equal? "two" (getenv "FOO")))
  
  (pass-if "empty"
    (putenv "FOO=")
    (equal? "" (getenv "FOO")))
  
  (pass-if "removing"
    (putenv "FOO=bar")
    (putenv "FOO")
    (not (getenv "FOO")))
  
  (pass-if "modifying string doesn't change env"
    (let ((s (string-copy "FOO=bar")))
      (putenv s)
      (string-set! s 5 #\x)
      (equal? "bar" (getenv "FOO")))))

;;
;; setenv
;;

(with-test-prefix "setenv"
  
  (pass-if "something"
    (setenv "FOO" "something")
    (equal? "something" (getenv "FOO")))
  
  (pass-if "replacing"
    (setenv "FOO" "one")
    (setenv "FOO" "two")
    (equal? "two" (getenv "FOO")))

  (pass-if "empty"
    (setenv "FOO" "")
    (equal? "" (getenv "FOO")))
  
  (pass-if "removing"
    (setenv "FOO" "something")
    (setenv "FOO" #f)
    (not (getenv "FOO"))))
  
;;
;; unsetenv
;;

(with-test-prefix "unsetenv"
  
  (pass-if "something"
    (putenv "FOO=something")
    (unsetenv "FOO")
    (not (getenv "FOO")))
  
  (pass-if "empty"
    (putenv "FOO=")
    (unsetenv "FOO")
    (not (getenv "FOO"))))

;;
;; ttyname
;;

(with-test-prefix "ttyname"

  (pass-if-exception "non-tty argument" exception:system-error
    ;; This used to crash in 1.8.1 and earlier.
    (let ((file (false-if-exception
                 (open-output-file "/dev/null"))))
      (if (not file)
          (throw 'unsupported)
          (ttyname file)))))

;;
;; utimes
;;

(with-test-prefix "utime"

  (pass-if "valid argument (second resolution)"
    (let ((file "posix.test-utime"))
      (dynamic-wind
        (lambda ()
          (close-port (open-output-file file)))
        (lambda ()
          (let* ((accessed (+ (current-time) 3600))
                 (modified (- accessed 1000)))
            (utime file accessed modified)
            (let ((info (stat file)))
              (and (= (stat:atime info) accessed)
                   (= (stat:mtime info) modified)))))
        (lambda ()
          (delete-file file)))))

  (pass-if-equal "AT_SYMLINK_NOFOLLOW"
      '(1 1)
    (if (defined? 'AT_SYMLINK_NOFOLLOW)
        (let ((file "posix.test-utime"))
          (dynamic-wind
            (lambda ()
              (symlink "/dev/null" file))
            (lambda ()
              (utime file 1 1 0 0 AT_SYMLINK_NOFOLLOW)
              (let ((info (lstat file)))
                (list (stat:atime info) (stat:mtime info))))
            (lambda ()
              (delete-file file))))
        (throw 'unsupported)))

  (define (utime-unless-unsupported oops . arguments)
    (catch 'system-error
      (lambda ()
        (catch 'wrong-type-arg
          (lambda ()
            (apply utime arguments))
          (lambda _
            ;; 'futimens' is not supported on all platforms.
            (oops))))
      (lambda args
        ;; On some platforms, 'futimens' returns ENOSYS according to Gnulib.
        (if (= (system-error-errno args) ENOSYS)
            (oops)
            (apply throw args)))))

  (pass-if-equal "file port"
      '(1 1)
    (let ((file "posix.test-utime"))
      (false-if-exception (delete-file file))
      (close-port (open-output-file file))
      (define (delete)
        (delete-file file))
      (define (oops)
        (delete)
        (throw 'unsupported))
      (call-with-input-file file
        (lambda (port)
          (utime-unless-unsupported oops port 1 1 0 0)
          (define info (stat file))
          (delete)
          (list (stat:atime info) (stat:mtime info))))))

  ;; This causes an EBADF system error on GNU/Linux with the 5.10.46 kernel.
  #;
  (pass-if-equal "file port (port representing symbolic link)"
      '(1 1)
    (let ((file "posix.test-utime"))
      (unless (false-if-exception
               (begin (symlink "/should-be-irrelevant" file)
                      #t))
        (display "cannot create symlink, a utime test skipped\n")
        (throw 'unresolved))
      (unless (and (defined? 'O_NOFOLLOW)
                   (defined? 'O_PATH)
                   (not (= 0 O_NOFOLLOW))
                   (not (= 0 O_PATH)))
        (display "cannot open symlinks, a utime test skipped\n")
        (throw 'unresolved))
      (define (delete)
        (when port (close-port port))
        (false-if-exception (delete-file file)))
      (define (oops)
        (delete)
        (throw 'unsupported))
      (define port #f)
      (catch #t
        (lambda ()
          (set! port
            (open file (logior O_NOFOLLOW O_PATH)))
          (utime-unless-unsupported oops port 1 1 0 0))
        (lambda args
          (pk 'deleting file)
          (delete)
          (apply throw args)))
      (define info (lstat file))
      (delete)
      (list (stat:mtime info) (stat:atime info)))))

;;
;; affinity
;;

(with-test-prefix "affinity"

  (pass-if "getaffinity"
    (if (defined? 'getaffinity)
        (> (bitvector-length (getaffinity (getpid))) 0)
        (throw 'unresolved)))

  (pass-if "setaffinity"
    (if (and (defined? 'setaffinity) (defined? 'getaffinity))
        (catch 'system-error
          (lambda ()
            (let ((mask (getaffinity (getpid))))
              (setaffinity (getpid) mask)
              (equal? mask (getaffinity (getpid)))))
          (lambda args
            ;; On some platforms such as sh4-linux-gnu, 'setaffinity'
            ;; returns ENOSYS.
            (let ((errno (system-error-errno args)))
              (if (= errno ENOSYS)
                  (throw 'unresolved)
                  (apply throw args)))))
        (throw 'unresolved))))

;;
;; pipe
;;

(with-test-prefix "pipe"

  (pass-if-equal "in and out"
      "hi!\n"
    (let ((in+out (pipe)))
      (display "hi!\n" (cdr in+out))
      (close-port (cdr in+out))
      (let ((str (list->string (list (read-char (car in+out))
                                     (read-char (car in+out))
                                     (read-char (car in+out))
                                     (read-char (car in+out))))))
        (and (eof-object? (read-char (car in+out)))
             (begin
               (close-port (car in+out))
               str)))))

  (pass-if-equal "O_CLOEXEC"
      (list FD_CLOEXEC FD_CLOEXEC)
    (let* ((in+out (catch 'system-error
                     (lambda ()
                       (pipe O_CLOEXEC))
                     (lambda args
                       (if (= (system-error-errno args) ENOSYS)
                           (throw 'unresolved)
                           (apply throw args)))))
           (flags (list (fcntl (car in+out) F_GETFD)
                        (fcntl (cdr in+out) F_GETFD))))
      (close-port (car in+out))
      (close-port (cdr in+out))
      flags)))

;;
;; system*
;;

(with-test-prefix "system*"

  (pass-if "http://bugs.gnu.org/13166"
    ;; With Guile up to 2.0.7 included, the child process launched by
    ;; `system*' would remain alive after an `execvp' failure.
    (let ((me (getpid)))
      (and (not (zero? (system* "something-that-does-not-exist")))
           (= me (getpid)))))

  (pass-if-equal "exit code for nonexistent file"
      127                                         ;aka. EX_NOTFOUND
    (status:exit-val (system* "something-that-does-not-exist")))

  (pass-if-equal "https://bugs.gnu.org/55596"
      127
    ;; The parameterization below used to cause 'start_child' to close
    ;; fd 2 in the child process, which in turn would cause it to
    ;; segfault, leading to a wrong exit code.
    (parameterize ((current-output-port (current-error-port)))
      (status:exit-val (system* "something-that-does-not-exist"))))

  (pass-if-equal "https://bugs.gnu.org/52835"
      "bong\n"
    (let* ((port (mkstemp "T-XXXXXX"))
           (file (port-filename port)))
      ;; Redirect stdout and stderr to FILE.
      (define status
        (call-with-output-file file
          (lambda (port)
            (with-output-to-port port
              (lambda ()
                (with-error-to-port port
                  (lambda ()
                    (system* "sh" "-c" "echo bong >&2"))))))))

      (delete-file file)
      (and (zero? (status:exit-val status))
           (get-string-all port))))

  (pass-if-equal "https://bugs.gnu.org/63024"
      0
    (if (file-exists? "/proc/self/fd/0")          ;on GNU/Linux?
        (parameterize ((current-output-port (%make-void-port "w0")))
          (system* "guile" "-c"
                   (object->string
                    '(exit (string=? "/dev/null"
                                     (readlink "/proc/self/fd/1"))))))
        (throw 'unresolved))))

;;
;; spawn
;;

(with-test-prefix "spawn"

  (pass-if-equal "basic"
      0
    (cdr (waitpid (spawn "true" '("true")))))

  (pass-if-exception "non-file port argument" ;<https://bugs.gnu.org/61073>
      exception:wrong-type-arg
    (spawn "true" '("true")
           #:error (%make-void-port "w")))

  (pass-if-equal "uname with stdout redirect"
      (list 0                                     ;exit value
            (string-append (utsname:sysname (uname)) " "
                           (utsname:machine (uname)) "\n"))
    (let* ((input+output (pipe))
           (pid (spawn "uname" '("uname" "-s" "-m")
                       #:output (cdr input+output))))
      (close-port (cdr input+output))
      (let ((str (get-string-all (car input+output))))
        (close-port (car input+output))
        (list (cdr (waitpid pid)) str))))

  (pass-if-equal "wc with stdin and stdout redirects"
      "2\n"
    (let* ((a+b (pipe))
           (c+d (pipe))
           (pid (spawn "wc" '("wc" "-w")
                       #:input (car a+b)
                       #:output (cdr c+d))))
      (close-port (car a+b))
      (close-port (cdr c+d))

      (display "Hello world.\n" (cdr a+b))
      (close-port (cdr a+b))

      (let ((str (get-string-all (car c+d))))
        (close-port (car c+d))
        (waitpid pid)
        str)))

  (pass-if-equal "env with #:environment and #:output"
      "GNU=guile\n"
    (let* ((input+output (pipe))
           (pid (spawn "env" '("env")
                       #:environment '("GNU=guile")
                       #:output (cdr input+output))))
      (close-port (cdr input+output))
      (let ((str (get-string-all (car input+output))))
        (close-port (car input+output))
        (waitpid pid)

        (let ((sysname (utsname:sysname (uname))))
          (cond
           ((string=? "GNU" sysname)
            ;; On GNU/Hurd, the exec server prepends 'LD_ORIGIN_PATH' for
            ;; every program: <https://bugs.gnu.org/62501>.  Strip it.
            (if (string-prefix? "LD_ORIGIN_PATH=" str)
                (string-drop str (+ 1 (string-index str #\newline)))
                str))
           ((string-ci=? "darwin" sysname)
            ;; MacOS appends '__CF_USER_TEXT_ENCODING' for every program.  Strip
            ;; it.
            (let ((pos (string-contains str "__CF_USER_TEXT_ENCODING=")))
              (if pos
                  (string-drop-right str (- (string-length str) pos))
                  str)))
           (else
            str))))))

  (pass-if-equal "ls /proc/self/fd"
      "0\n1\n2\n3\n"                     ;fourth FD is for /proc/self/fd
    (if (file-exists? "/proc/self/fd")   ;Linux
        (let* ((input+output (pipe))
               (pid (spawn "ls" '("ls" "/proc/self/fd")
                           #:output (cdr input+output))))
          (close-port (cdr input+output))
          (let ((str (get-string-all (car input+output))))
            (close-port (car input+output))
            (waitpid pid)
            str))
        (throw 'unresolved)))

  (pass-if-equal "file not found"
      ENOENT
    ;; Actually "skip-if-posix_spawn-replaced" would be preferred, since the
    ;; behavior below is not implemented in gnulib, but I do not know how to
    ;; write such test.  However due to posix_spawnp being buggy on macOS it is
    ;; always replaced, so whatever.
    (skip-on-darwin)
    (catch 'system-error
      (lambda ()
        (spawn "this-does-not-exist" '("nope")
               #:search-path? #f))
      (lambda args
        (system-error-errno args)))))

;;
;; crypt
;;

(with-test-prefix "crypt"

  (pass-if "basic usage"
    (if (not (defined? 'crypt))
        (throw 'unsupported)
        (string? (crypt "pass" "abcdefg"))))

  (pass-if "crypt invalid salt on glibc"
    (begin
      (unless (defined? 'crypt)
        (throw 'unsupported))
      (unless (string-contains %host-type "-gnu")
        (throw 'unresolved))
      (catch 'system-error
             (lambda ()
               ;; This used to deadlock on glibc while trying to throw to
               ;; 'system-error'.  This test uses the special
               ;; interpretation of the salt that glibc does;
               ;; specifically, we pass a salt that's probably
               ;; syntactically invalid here.  Note, whether it's invalid
               ;; or not is system-defined, so it's possible it just works.
               (string? (crypt "pass" "$X$abc")))
             (lambda _ #t)))))