mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

in filesys test, add helper function for deleting files and symlinks

Browse source 
On Windows, a file needs to have write permission to be deleted.
This adds a helper to handle that case, but, is used generally.

* test-suite/tests/filesys.test (%delete-file): new helper function
  Replace every delete-file call with %delete-file.
This commit is contained in:
Michael Gran 2023-06-20 13:47:04 -07:00
parent cc1c79ae34
commit 6b4d829d40
1 changed files with 29 additions and 27 deletions
Download patch file Download diff file Expand all files Collapse all files

56
test-suite/tests/filesys.test
View file

@ -38,6 +38,14 @@
(when (string-ci=? "darwin" (utsname:sysname (uname)))
(throw 'untested)))
(define (%delete-file file)
;; lstat finds files and links. stat finds just files.
(when (false-if-exception (lstat file))
;; MinGW requires write permission to delete a file.
(when (and (stat file #f) (not (access? file W_OK)))
(chmod file (logior (stat:mode (stat file)) #o200)))
(delete-file file)))
;;;
;;; copy-file
;;;
@ -99,7 +107,7 @@
(call-with-output-file (test-file)
(lambda (port)
(display "hello" port)))
(false-if-exception (delete-file (test-symlink)))
(%delete-file (test-symlink))
(if (not (false-if-exception
(begin (symlink (test-file) (test-symlink)) #t)))
(display "cannot create symlink, lstat test skipped\n")
@ -182,8 +190,7 @@
(for-each
(lambda (filename)
(define full-name (in-vicinity (test-directory) filename))
(when (file-exists? full-name)
(delete-file full-name)))
(%delete-file full-name))
'("test-file" "test-symlink"))
(rmdir (test-directory))))
(define (skip-unless-defined . things)
@ -351,9 +358,8 @@
;; https://debbugs.gnu.org/69437
(pass-if-equal "bar" (basename "foo/bar" "o/bar")))
(delete-file (test-file))
(when (file-exists? (test-symlink))
(delete-file (test-symlink)))
(%delete-file (test-file))
(%delete-file (test-symlink))
(with-test-prefix "mkdtemp"
@ -493,8 +499,8 @@
(chdir (open-input-string ""))))
(with-test-prefix "readlink"
(false-if-exception (delete-file (test-symlink)))
(false-if-exception (delete-file (test-file)))
(%delete-file (test-symlink))
(%delete-file (test-file))
(call-with-output-file (test-file)
(lambda (port)
(display "hello" port)))
@ -550,8 +556,8 @@
(close-port port)
(readlink port)))
(false-if-exception (delete-file (test-symlink)))
(false-if-exception (delete-file (test-file))))
(%delete-file (test-symlink))
(%delete-file (test-file)))
(with-test-prefix "symlinkat"
(pass-if-equal "create" (test-file)
@ -562,7 +568,7 @@
(lambda (port)
(symlinkat port (test-file) (test-symlink))
(readlink (test-symlink)))))
(false-if-exception (delete-file (test-symlink)))
(%delete-file (test-symlink))
(pass-if-exception "not a port" exception:wrong-type-arg
(unless (defined? 'symlinkat)
@ -631,8 +637,8 @@
(list (file-exists? "filesys-test-a.tmp")
(call-with-input-file "filesys-test-b.tmp" get-string-all)))
(false-if-exception (delete-file "filesys-test-a.tmp"))
(false-if-exception (delete-file "filesys-test-b.tmp"))
(%delete-file "filesys-test-a.tmp")
(%delete-file "filesys-test-b.tmp")
(pass-if-equal "two ports" '(#f "hello")
(skip-if-unsupported)
@ -651,8 +657,8 @@
(list (file-exists? (in-vicinity (test-directory) "a"))
(call-with-input-file (in-vicinity (test-directory2) "b")
get-string-all))))
(false-if-exception (delete-file (in-vicinity (test-directory) "a")))
(false-if-exception (delete-file (in-vicinity (test-directory2) "b")))
(%delete-file (in-vicinity (test-directory) "a"))
(%delete-file (in-vicinity (test-directory2) "b"))
(false-if-exception (rmdir (test-directory)))
(false-if-exception (rmdir (test-directory2)))
@ -669,9 +675,9 @@
;; Verify it exists under the new name, and not under the old name.
(list (file-exists? (in-vicinity (test-directory) "a"))
(call-with-input-file (test-file) get-string-all))))
(false-if-exception (delete-file (in-vicinity (test-directory) "a")))
(%delete-file (in-vicinity (test-directory) "a"))
(false-if-exception (rmdir (test-directory)))
(false-if-exception (delete-file (test-file)))
(%delete-file (test-file))
(pass-if-equal "current working directory and port" '(#f "hello")
(skip-if-unsupported)
@ -688,8 +694,8 @@
(call-with-input-file (in-vicinity (test-directory) "b")
get-string-all))))
(false-if-exception (delete-file (in-vicinity (test-directory) "b")))
(false-if-exception (delete-file (test-file)))
(%delete-file (in-vicinity (test-directory) "b"))
(%delete-file (test-file))
(false-if-exception (rmdir (test-directory)))
(pass-if-exception "not a file port (1)" exception:wrong-type-arg
@ -728,8 +734,7 @@
(define (create-test-directory)
(mkdir (test-directory)))
(define (delete-test-file)
(when (file-exists? (test-file))
(delete-file (test-file))))
(%delete-file (test-file)))
(define (delete-test-directory)
(when (file-exists? (test-directory))
(rmdir (test-directory))))
@ -808,8 +813,7 @@
(list (basename file) O_RDONLY)
(lambda (port) (port-revealed port))))
(when (file-exists? (test-file))
(delete-file (test-file)))
(%delete-file (test-file))
(pass-if-equal "O_CREAT/O_WRONLY" (list #t (logand (lognot (umask)) #o666) "w")
(skip-if-unsupported)
@ -821,8 +825,7 @@
(stat:perms (stat (test-file)))
(port-mode port)))))
(when (file-exists? (test-file))
(delete-file (test-file)))
(%delete-file (test-file))
(pass-if-equal "O_CREAT/O_WRONLY, non-default mode"
(list #t (logand (lognot (umask)) #o700) "w")
@ -847,5 +850,4 @@
(skip-if-unsupported)
(openat "not a port" "." O_RDONLY))
(when (file-exists? (test-file))
(delete-file (test-file))))
(%delete-file (test-file)))