From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Maxime Devos Newsgroups: gmane.lisp.guile.devel Subject: [PATCH v2 12/14] =?UTF-8?q?Define=20a=20Scheme=20binding=20to=20?= =?UTF-8?q?=E2=80=98fstatat=E2=80=99=20when=20available.?= Date: Tue, 16 Nov 2021 11:06:35 +0000 Message-ID: <20211116110637.125579-13-maximedevos@telenet.be> References: <175c3a6572e832d84927937b309a3095cadf5702.camel@telenet.be> <20211116110637.125579-1-maximedevos@telenet.be> Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="34419"; mail-complaints-to="usenet@ciao.gmane.io" Cc: Maxime Devos To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Tue Nov 16 12:17:33 2021 Return-path: Envelope-to: guile-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1mmwSz-0008nF-Mq for guile-devel@m.gmane-mx.org; Tue, 16 Nov 2021 12:17:33 +0100 Original-Received: from localhost ([::1]:51196 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1mmwSy-00019Z-Em for guile-devel@m.gmane-mx.org; Tue, 16 Nov 2021 06:17:32 -0500 Original-Received: from eggs.gnu.org ([209.51.188.92]:34350) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mmwRM-00070w-N2 for guile-devel@gnu.org; Tue, 16 Nov 2021 06:15:52 -0500 Original-Received: from leibniz.telenet-ops.be ([195.130.137.77]:49196) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mmwRJ-0006Wf-RA for guile-devel@gnu.org; Tue, 16 Nov 2021 06:15:52 -0500 Original-Received: from baptiste.telenet-ops.be (baptiste.telenet-ops.be [IPv6:2a02:1800:120:4::f00:13]) by leibniz.telenet-ops.be (Postfix) with ESMTPS id 4Htjtg1G7HzMrHtL for ; Tue, 16 Nov 2021 12:06:51 +0100 (CET) Original-Received: from localhost.localdomain ([IPv6:2a02:1811:8c09:9d00:3c5f:2eff:feb0:ba5a]) by baptiste.telenet-ops.be with bizsmtp id Jz6j2600Q4UW6Th01z6rJK; Tue, 16 Nov 2021 12:06:51 +0100 X-Mailer: git-send-email 2.30.2 In-Reply-To: <20211116110637.125579-1-maximedevos@telenet.be> DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=telenet.be; s=r21; t=1637060811; bh=FBUV5UzoVFZBvcGvtPwrwbHh8tzDiTdfE5IzxbUSZgk=; h=From:To:Cc:Subject:Date:In-Reply-To:References; b=btC7ammGv8hUM6Ts9dSXMpI1LcDUTgOLHrtrPptMGGPNlqCNARuYVGjz/9xUe3b2N F5hMbZHM5Bac60MN+LdkbOlMVfLH/NXQrQH0yxNZm7tedr9a3LCKXWsoGjONdquGNY C4HLwwHzWOjTqpxopB6X62srxb6gf2PcEi2nIIsVw+ztH3B0S/4tkn8T3l4Nq9lhHl WMHDdoyRzwV2EpefyOxG6zmhcS3Xyki/5OqIS6/Qv+o2n0U2Pdq/LgAuyHPnWWKswP 7lWpltcbbh5H/THy+qTpW5xfAU9LvGp8+EjxtiIeJ894ws34HOIGixldNa2gtLtk04 i0Xe+LjH2napA== Received-SPF: pass client-ip=195.130.137.77; envelope-from=maximedevos@telenet.be; helo=leibniz.telenet-ops.be X-Spam_score_int: -27 X-Spam_score: -2.8 X-Spam_bar: -- X-Spam_report: (-2.8 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001, RCVD_IN_DNSWL_LOW=-0.7, RCVD_IN_MSPIKE_H2=-0.001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Original-Sender: "guile-devel" Xref: news.gmane.io gmane.lisp.guile.devel:20947 Archived-At: * configure.ac: Detect if ‘fstatat’ is defined. * libguile/filesys.c (scm_statat): Define a Scheme binding to ‘fstatat’. * libguile/filesys.h (scm_statat): Make it part of the C API. * doc/ref/posix.texi (File System): Document it. * libguile/syscalls.h (fstatat_or_fstatat64): Choose between ‘fstatat’ and ‘fstatat64’. --- configure.ac | 4 +- doc/ref/posix.texi | 8 ++++ libguile/filesys.c | 39 +++++++++++++++++ libguile/filesys.h | 1 + libguile/syscalls.h | 1 + test-suite/tests/filesys.test | 80 +++++++++++++++++++++++++++++++++++ 6 files changed, 131 insertions(+), 2 deletions(-) diff --git a/configure.ac b/configure.ac index dcb6bceb5..e073e04f4 100644 --- a/configure.ac +++ b/configure.ac @@ -478,7 +478,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # isblank - available as a GNU extension or in C99 # _NSGetEnviron - Darwin specific # strcoll_l, newlocale, uselocale, utimensat, futimens, fchmodat, -# unlinkat, fchownat - POSIX.1-2008 +# unlinkat, fchownat, fstatat - POSIX.1-2008 # strtol_l - non-POSIX, found in glibc # fork - unavailable on Windows # sched_getaffinity, sched_setaffinity - GNU extensions (glibc) @@ -495,7 +495,7 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \ getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp \ index bcopy memcpy rindex truncate isblank _NSGetEnviron \ strcoll strcoll_l strtod_l strtol_l newlocale uselocale utimensat \ - futimens sched_getaffinity sched_setaffinity sendfile]) + fstatat futimens sched_getaffinity sched_setaffinity sendfile]) # The newlib C library uses _NL_ prefixed locale langinfo constants. AC_CHECK_DECLS([_NL_NUMERIC_GROUPING], [], [], [[#include ]]) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 3d06f1c73..cdd03f141 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -755,6 +755,14 @@ it will return information about a symbolic link itself, not the file it points to. @var{path} must be a string. @end deffn +@deffn {Scheme Procedure} statat dir filename [flags] +@deffnx {C Function} scm_statat dir filename flags +Like @code{stat}, but resolve @var{filename} relative to the directory +referred to by the file port @var{dir} instead. The optional argument +@var{flags} argument can be @code{AT_SYMLINK_NOFOLLOW}, in which case +@var{filename} will not be dereferenced even if it is a symbolic link. +@end deffn + @deffn {Scheme Procedure} readlink path @deffnx {C Function} scm_readlink (path) Return the value of the symbolic link named by @var{path} (a string, or diff --git a/libguile/filesys.c b/libguile/filesys.c index c257bb59c..d045a672f 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -601,6 +601,45 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0, } #undef FUNC_NAME +#ifdef HAVE_FSTATAT +SCM_DEFINE (scm_statat, "statat", 2, 1, 0, + (SCM dir, SCM filename, SCM flags), + "Like @code{stat}, but resolve @var{filename} relative to the\n" + "directory referred to by the file port @var{dir} instead.\n\n" + "The optional argument @var{flags} argument can be\n" + "@code{AT_SYMLINK_NOFOLLOW}, in which case @var{filename} will\n" + "not be dereferenced even if it is a symbolic link.") +#define FUNC_NAME s_scm_statat +{ + int rv; + int dir_fdes; + int c_flags; + struct stat_or_stat64 stat_temp; + + if (SCM_UNBNDP (flags)) + c_flags = 0; + else + c_flags = scm_to_int (flags); + + SCM_VALIDATE_OPFPORT (SCM_ARG1, dir); + dir_fdes = SCM_FPORT_FDES (dir); + + STRING_SYSCALL (filename, c_filename, + rv = fstatat_or_fstatat64 (dir_fdes, c_filename, + &stat_temp, c_flags)); + scm_remember_upto_here_1 (dir); + if (rv != 0) + { + int en = errno; + SCM_SYSERROR_MSG ("~A: ~S", + scm_list_2 (scm_strerror (scm_from_int (en)), filename), + en); + } + return scm_stat2scm (&stat_temp); +} +#undef FUNC_NAME +#endif /* HAVE_FSTATAT */ + SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, (SCM str), "Similar to @code{stat}, but does not follow symbolic links, i.e.,\n" diff --git a/libguile/filesys.h b/libguile/filesys.h index 7673c8051..8af0f989a 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -48,6 +48,7 @@ SCM_API SCM scm_open (SCM path, SCM flags, SCM mode); SCM_API SCM scm_close (SCM fd_or_port); SCM_API SCM scm_close_fdes (SCM fd); SCM_API SCM scm_stat (SCM object, SCM exception_on_error); +SCM_API SCM scm_statat (SCM dir, SCM filename, SCM flags); SCM_API SCM scm_link (SCM oldpath, SCM newpath); SCM_API SCM scm_rename (SCM oldname, SCM newname); SCM_API SCM scm_renameat (SCM olddir, SCM oldname, SCM newdir, SCM newname); diff --git a/libguile/syscalls.h b/libguile/syscalls.h index 30b99c193..37d532e60 100644 --- a/libguile/syscalls.h +++ b/libguile/syscalls.h @@ -65,6 +65,7 @@ # define readdir_r_or_readdir64_r readdir_r #endif #define stat_or_stat64 CHOOSE_LARGEFILE(stat,stat64) +#define fstatat_or_fstatat64 CHOOSE_LARGEFILE(fstatat,fstatat64) #define truncate_or_truncate64 CHOOSE_LARGEFILE(truncate,truncate64) #define scm_from_off_t_or_off64_t CHOOSE_LARGEFILE(scm_from_off_t,scm_from_int64) #define scm_from_ino_t_or_ino64_t CHOOSE_LARGEFILE(scm_from_ulong,scm_from_uint64) diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test index 33b68e16d..b794b07b3 100644 --- a/test-suite/tests/filesys.test +++ b/test-suite/tests/filesys.test @@ -134,6 +134,86 @@ (close-port port) (eqv? 5 (stat:size st)))))) +(with-test-prefix "statat" + ;; file-exists? from (ice-9 boot) dereferences symbolic links + ;; (a bug?). + (define (file-exists? filename) + (catch 'system-error + (lambda () (lstat filename) #t) + (lambda args + (if (= (system-error-errno args) ENOENT) + ;; For the purposes of the following tests, + ;; it is safe to ignore errors like EPERM, but a correct + ;; implementation would return #t for that error. + #f + (apply throw args))))) + (define (maybe-delete-directory) + (when (file-exists? (test-directory)) + (for-each + (lambda (filename) + (define full-name (in-vicinity (test-directory) filename)) + (when (file-exists? full-name) + (delete-file full-name))) + '("test-file" "test-symlink")) + (rmdir (test-directory)))) + (define (skip-unless-defined . things) + (for-each (lambda (thing) + (unless (defined? thing) + (throw 'unsupported))) + things)) + (maybe-delete-directory) + (mkdir (test-directory)) + (call-with-output-file (in-vicinity (test-directory) "test-file") + (lambda (port) + (display "hello" port))) + + ;; Return #true if the symlink was created, #false otherwise. + (define (maybe-create-symlink) + (if (file-exists? (in-vicinity (test-directory) "test-symlink")) + #t + (false-if-exception + (symlink "test-file" + (in-vicinity (test-directory) "test-symlink"))))) + + (pass-if-equal "regular file" 5 + (skip-unless-defined 'statat) + (call-with-port + (open (test-directory) O_RDONLY) + (lambda (port) + (stat:size (statat port "test-file"))))) + + (pass-if-equal "regular file, AT_SYMLINK_NOFOLLOW" 5 + (skip-unless-defined 'statat 'AT_SYMLINK_NOFOLLOW) + (call-with-port + (open (test-directory) O_RDONLY) + (lambda (port) + (stat:size (statat port "test-file" AT_SYMLINK_NOFOLLOW))))) + + (pass-if-equal "symbolic links are dereferenced" '(regular 5) + ;; Not all systems support symlinks. + (skip-unless-defined 'statat 'symlink) + (unless (maybe-create-symlink) + (throw 'unresolved)) + (call-with-port + (open (test-directory) O_RDONLY) + (lambda (port) + (define result (statat port "test-symlink")) + (list (stat:type result) (stat:size result))))) + + (pass-if-equal "symbolic links are not dereferenced" + `(symlink ,(string-length "test-file")) + ;; Not all systems support symlinks. + (skip-unless-defined 'statat 'symlink) + (unless (maybe-create-symlink) + (throw 'unresolved)) + (call-with-port + (open (test-directory) O_RDONLY) + (lambda (port) + (define result (statat port "test-symlink" AT_SYMLINK_NOFOLLOW)) + (list (stat:type result) (stat:size result))))) + + (maybe-delete-directory)) + (with-test-prefix "sendfile" (let* ((file (search-path %load-path "ice-9/boot-9.scm")) -- 2.30.2