mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-30 00:40:20 +02:00
7f3be1db99
* libguile/filesys.c (scm_sendfile): In Linux-style sendfile(2) code, if
EINTR or EAGAIN occurs, set result to 1 (not 0) so that we actually
keep going. In non-sendfile(2) code, deal gracefully with short reads
due to EOF.
* test-suite/tests/filesys.test ("sendfile"): Use 'let*' to guarantee
the needed order of operations: write (test-file) and then read it.
Add code to check the written data (not just the returned length) in
all tests, including the cases that hit EOF prematurely.
225 lines
7.6 KiB
Scheme
225 lines
7.6 KiB
Scheme
;;;; filesys.test --- test file system functions -*- scheme -*-
|
|
;;;;
|
|
;;;; Copyright (C) 2004, 2006, 2013 Free Software Foundation, Inc.
|
|
;;;;
|
|
;;;; 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-filesys)
|
|
#:use-module (test-suite lib)
|
|
#:use-module (test-suite guile-test)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (rnrs io ports)
|
|
#:use-module (rnrs bytevectors))
|
|
|
|
(define (test-file)
|
|
(data-file-name "filesys-test.tmp"))
|
|
(define (test-symlink)
|
|
(data-file-name "filesys-test-link.tmp"))
|
|
|
|
|
|
;;;
|
|
;;; copy-file
|
|
;;;
|
|
|
|
(with-test-prefix "copy-file"
|
|
|
|
;; return next prospective file descriptor number
|
|
(define (next-fd)
|
|
(let ((fd (dup 0)))
|
|
(close fd)
|
|
fd))
|
|
|
|
;; in guile 1.6.4 and earlier, copy-file didn't close the input fd when
|
|
;; the output could not be opened
|
|
(pass-if "fd leak when dest unwritable"
|
|
(let ((old-next (next-fd)))
|
|
(false-if-exception (copy-file "/dev/null" "no/such/dir/foo"))
|
|
(= old-next (next-fd)))))
|
|
|
|
;;;
|
|
;;; lstat
|
|
;;;
|
|
|
|
(with-test-prefix "lstat"
|
|
|
|
(pass-if "normal file"
|
|
(call-with-output-file (test-file)
|
|
(lambda (port)
|
|
(display "hello" port)))
|
|
(eqv? 5 (stat:size (lstat (test-file)))))
|
|
|
|
(call-with-output-file (test-file)
|
|
(lambda (port)
|
|
(display "hello" port)))
|
|
(false-if-exception (delete-file (test-symlink)))
|
|
(if (not (false-if-exception
|
|
(begin (symlink (test-file) (test-symlink)) #t)))
|
|
(display "cannot create symlink, lstat test skipped\n")
|
|
(pass-if "symlink"
|
|
;; not much to test, except that it works
|
|
(->bool (lstat (test-symlink))))))
|
|
|
|
;;;
|
|
;;; opendir and friends
|
|
;;;
|
|
|
|
(with-test-prefix "opendir"
|
|
|
|
(with-test-prefix "root directory"
|
|
(let ((d (opendir "/")))
|
|
(pass-if "not empty"
|
|
(string? (readdir d)))
|
|
(pass-if "all entries are strings"
|
|
(let more ()
|
|
(let ((f (readdir d)))
|
|
(cond ((string? f)
|
|
(more))
|
|
((eof-object? f)
|
|
#t)
|
|
(else
|
|
#f)))))
|
|
(closedir d))))
|
|
|
|
;;;
|
|
;;; stat
|
|
;;;
|
|
|
|
(with-test-prefix "stat"
|
|
|
|
(with-test-prefix "filename"
|
|
|
|
(pass-if "size"
|
|
(call-with-output-file (test-file)
|
|
(lambda (port)
|
|
(display "hello" port)))
|
|
(eqv? 5 (stat:size (stat (test-file))))))
|
|
|
|
(with-test-prefix "file descriptor"
|
|
|
|
(pass-if "size"
|
|
(call-with-output-file (test-file)
|
|
(lambda (port)
|
|
(display "hello" port)))
|
|
(let* ((fd (open-fdes (test-file) O_RDONLY))
|
|
(st (stat fd)))
|
|
(close-fdes fd)
|
|
(eqv? 5 (stat:size st)))))
|
|
|
|
(with-test-prefix "port"
|
|
|
|
(pass-if "size"
|
|
(call-with-output-file (test-file)
|
|
(lambda (port)
|
|
(display "hello" port)))
|
|
(let* ((port (open-file (test-file) "r+"))
|
|
(st (stat port)))
|
|
(close-port port)
|
|
(eqv? 5 (stat:size st))))))
|
|
|
|
(with-test-prefix "sendfile"
|
|
|
|
(let* ((file (search-path %load-path "ice-9/boot-9.scm"))
|
|
(len (stat:size (stat file)))
|
|
(ref (call-with-input-file file get-bytevector-all)))
|
|
|
|
(pass-if-equal "file" (cons len ref)
|
|
(let* ((result (call-with-input-file file
|
|
(lambda (input)
|
|
(call-with-output-file (test-file)
|
|
(lambda (output)
|
|
(sendfile output input len 0))))))
|
|
(out (call-with-input-file (test-file) get-bytevector-all)))
|
|
(cons result out)))
|
|
|
|
(pass-if-equal "file with offset"
|
|
(cons (- len 777) (call-with-input-file file
|
|
(lambda (input)
|
|
(seek input 777 SEEK_SET)
|
|
(get-bytevector-all input))))
|
|
(let* ((result (call-with-input-file file
|
|
(lambda (input)
|
|
(call-with-output-file (test-file)
|
|
(lambda (output)
|
|
(sendfile output input (- len 777) 777))))))
|
|
(out (call-with-input-file (test-file) get-bytevector-all)))
|
|
(cons result out)))
|
|
|
|
(pass-if-equal "file with offset past the end"
|
|
(cons (- len 777) (call-with-input-file file
|
|
(lambda (input)
|
|
(seek input 777 SEEK_SET)
|
|
(get-bytevector-all input))))
|
|
(let* ((result (call-with-input-file file
|
|
(lambda (input)
|
|
(call-with-output-file (test-file)
|
|
(lambda (output)
|
|
(sendfile output input len 777))))))
|
|
(out (call-with-input-file (test-file) get-bytevector-all)))
|
|
(cons result out)))
|
|
|
|
(pass-if-equal "file with offset near the end"
|
|
(cons 77 (call-with-input-file file
|
|
(lambda (input)
|
|
(seek input (- len 77) SEEK_SET)
|
|
(get-bytevector-all input))))
|
|
(let* ((result (call-with-input-file file
|
|
(lambda (input)
|
|
(call-with-output-file (test-file)
|
|
(lambda (output)
|
|
(sendfile output input len (- len 77)))))))
|
|
(out (call-with-input-file (test-file) get-bytevector-all)))
|
|
(cons result out)))
|
|
|
|
(pass-if-equal "pipe" (cons len ref)
|
|
(if (provided? 'threads)
|
|
(let* ((in+out (pipe))
|
|
(child (call-with-new-thread
|
|
(lambda ()
|
|
(call-with-input-file file
|
|
(lambda (input)
|
|
(let ((result (sendfile (cdr in+out)
|
|
(fileno input)
|
|
len 0)))
|
|
(close-port (cdr in+out))
|
|
result)))))))
|
|
(let ((out (get-bytevector-all (car in+out))))
|
|
(close-port (car in+out))
|
|
(cons (join-thread child) out)))
|
|
(throw 'unresolved)))
|
|
|
|
(pass-if-equal "pipe with offset"
|
|
(cons (- len 777) (call-with-input-file file
|
|
(lambda (input)
|
|
(seek input 777 SEEK_SET)
|
|
(get-bytevector-all input))))
|
|
(if (provided? 'threads)
|
|
(let* ((in+out (pipe))
|
|
(child (call-with-new-thread
|
|
(lambda ()
|
|
(call-with-input-file file
|
|
(lambda (input)
|
|
(let ((result (sendfile (cdr in+out)
|
|
(fileno input)
|
|
(- len 777)
|
|
777)))
|
|
(close-port (cdr in+out))
|
|
result)))))))
|
|
(let ((out (get-bytevector-all (car in+out))))
|
|
(close-port (car in+out))
|
|
(cons (join-thread child) out)))
|
|
(throw 'unresolved)))))
|
|
|
|
(delete-file (test-file))
|
|
(delete-file (test-symlink))
|