diff --git a/.Rbuildignore b/.Rbuildignore index d6ca6eb..6e53454 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -17,3 +17,5 @@ ^CRAN-SUBMISSION$ ^[\.]?air\.toml$ ^\.vscode$ +^[.]dev$ +^[.]covrignore$ diff --git a/.covrignore b/.covrignore new file mode 100644 index 0000000..e4c5ee1 --- /dev/null +++ b/.covrignore @@ -0,0 +1 @@ +src/cleancall.c diff --git a/.gitignore b/.gitignore index 1330c44..54b49f3 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,4 @@ /src/*.o /revdep docs +/.dev diff --git a/DESCRIPTION b/DESCRIPTION index d4e9ca8..46cc981 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -11,11 +11,12 @@ Description: Place an exclusive or shared lock on a file. It uses License: MIT + file LICENSE URL: https://r-lib.github.io/filelock/, https://github.com/r-lib/filelock BugReports: https://github.com/r-lib/filelock/issues -Depends: +Depends: R (>= 3.4) Suggests: callr (>= 2.0.0), covr, + ps, testthat (>= 3.0.0) Config/Needs/website: tidyverse/tidytemplate Config/testthat/edition: 3 diff --git a/src/Makevars b/src/Makevars index 945ce82..8d04f58 100644 --- a/src/Makevars +++ b/src/Makevars @@ -1,5 +1,5 @@ -OBJECTS = init.o filelock-unix.o locklist.o +OBJECTS = init.o filelock-unix.o locklist.o cleancall.o all: clean diff --git a/src/Makevars.win b/src/Makevars.win index 1f37ea5..eea3c58 100644 --- a/src/Makevars.win +++ b/src/Makevars.win @@ -1,5 +1,5 @@ -OBJECTS = init.o filelock-windows.o locklist.o utf8.o +OBJECTS = init.o filelock-windows.o locklist.o utf8.o cleancall.o all: clean diff --git a/src/cleancall.c b/src/cleancall.c new file mode 100644 index 0000000..acde7de --- /dev/null +++ b/src/cleancall.c @@ -0,0 +1,166 @@ +#define R_NO_REMAP +#include + +#include "cleancall.h" + + +#if (defined(R_VERSION) && R_VERSION < R_Version(3, 4, 0)) + SEXP R_MakeExternalPtrFn(DL_FUNC p, SEXP tag, SEXP prot) { + fn_ptr ptr; + ptr.fn = p; + return R_MakeExternalPtr(ptr.p, tag, prot); + } + DL_FUNC R_ExternalPtrAddrFn(SEXP s) { + fn_ptr ptr; + ptr.p = R_ExternalPtrAddr(s); + return ptr.fn; + } +#endif + +// The R API does not have a setter for function pointers + +SEXP cleancall_MakeExternalPtrFn(DL_FUNC p, SEXP tag, SEXP prot) { + fn_ptr tmp; + tmp.fn = p; + return R_MakeExternalPtr(tmp.p, tag, prot); +} + +void cleancall_SetExternalPtrAddrFn(SEXP s, DL_FUNC p) { + fn_ptr ptr; + ptr.fn = p; + R_SetExternalPtrAddr(s, ptr.p); +} + + +// Initialised at load time with the `.Call` primitive +SEXP cleancall_fns_dot_call = NULL; + +void cleancall_init(void) { + cleancall_fns_dot_call = Rf_findVar(Rf_install(".Call"), R_BaseEnv); +} + +struct eval_args { + SEXP call; + SEXP env; +}; + +static SEXP eval_wrap(void* data) { + struct eval_args* args = (struct eval_args*) data; + return Rf_eval(args->call, args->env); +} + + +SEXP cleancall_call(SEXP args, SEXP env) { + SEXP call = PROTECT(Rf_lcons(cleancall_fns_dot_call, args)); + struct eval_args data = { call, env }; + + SEXP out = r_with_cleanup_context(&eval_wrap, &data); + + UNPROTECT(1); + return out; +} + + +static SEXP callbacks = NULL; + +// Preallocate a callback +static void push_callback(SEXP stack) { + SEXP top = CDR(stack); + + SEXP early_handler = PROTECT(Rf_allocVector(LGLSXP, 1)); + SEXP fn_extptr = PROTECT(cleancall_MakeExternalPtrFn(NULL, R_NilValue, + R_NilValue)); + SEXP data_extptr = PROTECT(R_MakeExternalPtr(NULL, early_handler, + R_NilValue)); + SEXP cb = Rf_cons(Rf_cons(fn_extptr, data_extptr), top); + + SETCDR(stack, cb); + + UNPROTECT(3); +} + +struct data_wrapper { + SEXP (*fn)(void* data); + void *data; + SEXP callbacks; + int success; +}; + +static void call_exits(void* data) { + // Remove protecting node. Don't remove the preallocated callback on + // the top as it might contain a handler when something went wrong. + SEXP top = CDR(callbacks); + + // Restore old stack + struct data_wrapper* state = data; + callbacks = (SEXP) state->callbacks; + + // Handlers should not jump + while (top != R_NilValue) { + SEXP cb = CAR(top); + top = CDR(top); + + void (*fn)(void*) = (void (*)(void*)) R_ExternalPtrAddrFn(CAR(cb)); + void *data = (void*) R_ExternalPtrAddr(CDR(cb)); + int early_handler = LOGICAL(R_ExternalPtrTag(CDR(cb)))[0]; + + // Check for empty pointer in preallocated callbacks + if (fn) { + if (!early_handler || !state->success) fn(data); + } + } +} + +static SEXP with_cleanup_context_wrap(void *data) { + struct data_wrapper* cdata = data; + SEXP ret = cdata->fn(cdata->data); + cdata->success = 1; + return ret; +} + +SEXP r_with_cleanup_context(SEXP (*fn)(void* data), void* data) { + // Preallocate new stack before changing `callbacks` to avoid + // leaving the global variable in a bad state if alloc fails + SEXP new = PROTECT(Rf_cons(R_NilValue, R_NilValue)); + push_callback(new); + + if (!callbacks) callbacks = R_NilValue; + + SEXP old = callbacks; + callbacks = new; + + struct data_wrapper state = { fn, data, old, 0 }; + + SEXP out = R_ExecWithCleanup(with_cleanup_context_wrap, &state, + &call_exits, &state); + + UNPROTECT(1); + return out; +} + +static void call_save_handler(void (*fn)(void *data), void* data, + int early) { + if (!callbacks) { + fn(data); + Rf_error("Internal error: Exit handler pushed outside " + "of an exit context"); + } + + SEXP cb = CADR(callbacks); + + // Update pointers + cleancall_SetExternalPtrAddrFn(CAR(cb), (DL_FUNC) fn); + R_SetExternalPtrAddr(CDR(cb), data); + LOGICAL(R_ExternalPtrTag(CDR(cb)))[0] = early; + + // Preallocate the next callback in case the allocator jumps + push_callback(callbacks); +} + +void r_call_on_exit(void (*fn)(void* data), void* data) { + call_save_handler(fn, data, /* early = */ 0); +} + +void r_call_on_early_exit(void (*fn)(void* data), void* data) { + call_save_handler(fn, data, /* early = */ 1); +} diff --git a/src/cleancall.h b/src/cleancall.h new file mode 100644 index 0000000..849107c --- /dev/null +++ b/src/cleancall.h @@ -0,0 +1,41 @@ +#ifndef CLEANCALL_H +#define CLEANCALL_H + +#include +#include + +// -------------------------------------------------------------------- +// Internals +// -------------------------------------------------------------------- + +typedef union {void* p; DL_FUNC fn;} fn_ptr; + +#if (defined(R_VERSION) && R_VERSION < R_Version(3, 4, 0)) + SEXP R_MakeExternalPtrFn(DL_FUNC p, SEXP tag, SEXP prot); + DL_FUNC R_ExternalPtrAddrFn(SEXP s); +#endif + +// -------------------------------------------------------------------- +// API for packages that embed cleancall +// -------------------------------------------------------------------- + +// The R API does not have a setter for external function pointers +SEXP cleancall_MakeExternalPtrFn(DL_FUNC p, SEXP tag, SEXP prot); +void cleancall_SetExternalPtrAddrFn(SEXP s, DL_FUNC p); + +#define CLEANCALL_METHOD_RECORD \ + {"cleancall_call", (DL_FUNC) &cleancall_call, 2} + +SEXP cleancall_call(SEXP args, SEXP env); +extern SEXP cleancall_fns_dot_call; +void cleancall_init(void); + +// -------------------------------------------------------------------- +// Public API +// -------------------------------------------------------------------- + +SEXP r_with_cleanup_context(SEXP (*fn)(void* data), void* data); +void r_call_on_exit(void (*fn)(void* data), void* data); +void r_call_on_early_exit(void (*fn)(void* data), void* data); + +#endif diff --git a/src/filelock-unix.c b/src/filelock-unix.c index 0ecfc66..3903617 100644 --- a/src/filelock-unix.c +++ b/src/filelock-unix.c @@ -11,18 +11,22 @@ #include #include "filelock.h" +#include "cleancall.h" #define FILELOCK_INTERRUPT_INTERVAL 200 struct sigaction filelock_old_sa; -void filelock__finalizer(SEXP x) { - filelock__list_t *ptr = (filelock__list_t*) R_ExternalPtrAddr(x); +void filelock__finalizer(SEXP x) +{ + filelock__list_t *ptr = (filelock__list_t *)R_ExternalPtrAddr(x); - if (!ptr) return; + if (!ptr) + return; ptr->refcount -= 1; - if (!ptr->refcount) { + if (!ptr->refcount) + { close(ptr->file); filelock__list_remove(ptr->path); } @@ -30,27 +34,31 @@ void filelock__finalizer(SEXP x) { R_ClearExternalPtr(x); } -void filelock__alarm_callback (int signum) { +void filelock__alarm_callback(int signum) +{ /* Restore signal handler */ sigaction(SIGALRM, &filelock_old_sa, 0); } int filelock__interruptible(int filedes, struct flock *lck, - const char *c_path, - int c_exclusive, int c_timeout) { + const char *c_path, + int c_exclusive, int c_timeout) +{ struct itimerval timer; struct sigaction sa; int timeleft = c_timeout; int ret = 1; - while (c_timeout < 0 || timeleft > 0) { + while (c_timeout < 0 || timeleft > 0) + { /* If block forever, then always use the interrupt interval, If timeout and just a little time left, use that. */ int waitnow = FILELOCK_INTERRUPT_INTERVAL; - if (c_timeout >= 0 && timeleft < FILELOCK_INTERRUPT_INTERVAL) { + if (c_timeout >= 0 && timeleft < FILELOCK_INTERRUPT_INTERVAL) + { waitnow = timeleft; } @@ -59,7 +67,7 @@ int filelock__interruptible(int filedes, struct flock *lck, timer.it_interval.tv_sec = 0; timer.it_interval.tv_usec = 0; - memset(&sa, 0, sizeof (sa)); + memset(&sa, 0, sizeof(sa)); sa.sa_handler = &filelock__alarm_callback; sigaction(SIGALRM, &sa, &filelock_old_sa); @@ -76,8 +84,13 @@ int filelock__interruptible(int filedes, struct flock *lck, /* If ret != -1, then we have the lock, return. If -1, but not EINTR, then a real error happened. */ - if (ret != -1) { ret = 0; break; } - if (ret == -1 && errno != EINTR) { + if (ret != -1) + { + ret = 0; + break; + } + if (ret == -1 && errno != EINTR) + { error("Cannot lock file: '%s': %s", c_path, strerror(errno)); } @@ -89,71 +102,132 @@ int filelock__interruptible(int filedes, struct flock *lck, return ret; } -SEXP filelock_lock(SEXP path, SEXP exclusive, SEXP timeout) { - struct flock lck; - const char *c_path = CHAR(STRING_ELT(path, 0)); - int c_exclusive = LOGICAL(exclusive)[0]; - int c_timeout = INTEGER(timeout)[0]; - int filedes, ret; - - /* Check if this file was already locked. */ - filelock__list_t *node = filelock__list_find(c_path); - if (node) { - if ((c_exclusive && node->exclusive) || - (!c_exclusive && !node->exclusive)) { - return filelock__make_lock_handle(node); - } else if (c_exclusive) { - error("File already has a shared lock"); - } else { - error("File already has an exclusive lock"); - } +/* Cleanup handler to close file descriptor on early exit (interrupt/error) */ +static void filelock__close_fd_cleanup(void *ptr) +{ + int *filedes = (int *)ptr; + if (filedes && *filedes >= 0) + { + REprintf("Cleaning up: closing file descriptor %d\n", *filedes); + close(*filedes); + *filedes = -1; } +} + +/* Structure to hold filelock_lock arguments and state */ +struct filelock_lock_data +{ + const char *c_path; + int c_exclusive; + int c_timeout; + int filedes; +}; + +/* Worker function that will be called within cleanup context */ +static SEXP filelock_lock_worker(void *data) +{ + struct filelock_lock_data *args = (struct filelock_lock_data *)data; + struct flock lck; + int ret; - lck.l_type = c_exclusive ? F_WRLCK : F_RDLCK; + lck.l_type = args->c_exclusive ? F_WRLCK : F_RDLCK; lck.l_whence = SEEK_SET; lck.l_start = 0; lck.l_len = 0; - filedes = open(c_path, O_RDWR | O_CREAT, S_IRUSR | S_IWUSR); - if (filedes == -1) error("Cannot open lock file: %s", strerror(errno)); + args->filedes = open(args->c_path, O_RDWR | O_CREAT, S_IRUSR | S_IWUSR); + if (args->filedes == -1) + { + error("Cannot open lock file: %s", strerror(errno)); + } + + /* Register cleanup handler - will close filedes on interrupt/error */ + r_call_on_early_exit(filelock__close_fd_cleanup, &args->filedes); /* One shot only? Do not block if cannot lock */ - if (c_timeout == 0) { - ret = fcntl(filedes, F_SETLK, &lck); - if (ret == -1) { - if (errno == EAGAIN || errno == EACCES) { - return R_NilValue; + if (args->c_timeout == 0) + { + ret = fcntl(args->filedes, F_SETLK, &lck); + if (ret == -1) + { + if (errno == EAGAIN || errno == EACCES) + { + return R_NilValue; } - error("Cannot lock file: '%s': %s", c_path, strerror(errno)); + error("Cannot lock file: '%s': %s", args->c_path, strerror(errno)); } - - } else { - ret = filelock__interruptible(filedes, &lck, c_path, c_exclusive, - c_timeout); + } + else + { + ret = filelock__interruptible(args->filedes, &lck, args->c_path, + args->c_exclusive, args->c_timeout); } /* Failed to acquire the lock? */ - if (ret) { + if (ret) + { + close(args->filedes); return R_NilValue; - } else { - return filelock__list_add(c_path, filedes, c_exclusive); + } + else + { + return filelock__list_add(args->c_path, args->filedes, args->c_exclusive); } } -SEXP filelock_unlock(SEXP lock) { +SEXP filelock_lock(SEXP path, SEXP exclusive, SEXP timeout) +{ + const char *c_path = CHAR(STRING_ELT(path, 0)); + int c_exclusive = LOGICAL(exclusive)[0]; + int c_timeout = INTEGER(timeout)[0]; + + /* Check if this file was already locked. */ + filelock__list_t *node = filelock__list_find(c_path); + if (node) + { + if ((c_exclusive && node->exclusive) || + (!c_exclusive && !node->exclusive)) + { + return filelock__make_lock_handle(node); + } + else if (c_exclusive) + { + error("File already has a shared lock"); + } + else + { + error("File already has an exclusive lock"); + } + } + + /* Set up worker arguments and call with cleanup context */ + struct filelock_lock_data args = { + .c_path = c_path, + .c_exclusive = c_exclusive, + .c_timeout = c_timeout, + .filedes = -1}; + + return r_with_cleanup_context(filelock_lock_worker, &args); +} + +SEXP filelock_unlock(SEXP lock) +{ void *ptr = R_ExternalPtrAddr(VECTOR_ELT(lock, 0)); const char *c_path; filelock__list_t *node; - if (!ptr) return ScalarLogical(1); + if (!ptr) + return ScalarLogical(1); c_path = CHAR(STRING_ELT(VECTOR_ELT(lock, 1), 0)); node = filelock__list_find(c_path); /* It has to be there.... */ - if (node) { + if (node) + { node->refcount -= 1; - if (!node->refcount) { + if (!node->refcount) + { close(node->file); filelock__list_remove(c_path); } @@ -164,13 +238,17 @@ SEXP filelock_unlock(SEXP lock) { return ScalarLogical(1); } -SEXP filelock_is_unlocked(SEXP lock) { +SEXP filelock_is_unlocked(SEXP lock) +{ void *ptr = R_ExternalPtrAddr(VECTOR_ELT(lock, 0)); - if (ptr) { + if (ptr) + { const char *c_path = CHAR(STRING_ELT(VECTOR_ELT(lock, 1), 0)); int inlist = filelock__list_find(c_path) != 0; - return ScalarLogical(! inlist); - } else { + return ScalarLogical(!inlist); + } + else + { return ScalarLogical(1); } } diff --git a/src/filelock.h b/src/filelock.h index 4aec0dd..76725cc 100644 --- a/src/filelock.h +++ b/src/filelock.h @@ -3,6 +3,8 @@ #include #include +#include "cleancall.h" + #ifdef _WIN32 #include #endif diff --git a/src/init.c b/src/init.c index 2fd89e4..b955943 100644 --- a/src/init.c +++ b/src/init.c @@ -1,7 +1,9 @@ #include "filelock.h" +#include "cleancall.h" static const R_CallMethodDef callMethods[] = { + CLEANCALL_METHOD_RECORD, { "filelock_lock", (DL_FUNC) &filelock_lock, 3 }, { "filelock_unlock", (DL_FUNC) &filelock_unlock, 1 }, { "filelock_is_unlocked", (DL_FUNC) &filelock_is_unlocked, 1 }, @@ -12,4 +14,5 @@ void R_init_filelock(DllInfo *dll) { R_registerRoutines(dll, NULL, callMethods, NULL, NULL); R_useDynamicSymbols(dll, FALSE); R_forceSymbols(dll, TRUE); + cleancall_fns_dot_call = Rf_findVar(Rf_install(".Call"), R_BaseEnv); } diff --git a/tests/testthat/test.R b/tests/testthat/test.R index 31d434f..df9463b 100644 --- a/tests/testthat/test.R +++ b/tests/testthat/test.R @@ -308,13 +308,17 @@ test_that("UTF-8 filenames", { good <- tryCatch( { cat("hello\n", file = tmp) - if (readLines(tmp) != "hello") stop("Not good") + if (readLines(tmp) != "hello") { + stop("Not good") + } unlink(tmp) TRUE }, error = function(e) FALSE ) - if (identical(good, FALSE)) skip("FS does not support Unicode file names") + if (identical(good, FALSE)) { + skip("FS does not support Unicode file names") + } expect_silent(l <- lock(tmp)) expect_equal(Encoding(l[[2]]), "UTF-8") @@ -332,3 +336,55 @@ test_that("non-exclusive lock with timeout", { test_that("unlock() needs lock object", { expect_snapshot(error = TRUE, unlock(1)) }) + +test_that("clean up file descriptor on interrupt", { + skip_on_cran() + tmp <- tempfile() + l <- filelock::lock(tmp) + rs <- callr::r_session$new() + on.exit(rs$close(), add = TRUE) + rs$call( + function(path) .GlobalEnv$lock <- filelock::lock(path), + list(tmp) + ) + deadline <- Sys.time() + as.difftime(2, units = "secs") + while (Sys.time() < deadline) { + of <- ps::ps_open_files(ps::ps_handle(rs$get_pid())) + if (normalizePath(tmp) %in% normalizePath(of$path)) { + break + } + } + expect_true(normalizePath(tmp) %in% normalizePath(of$path)) + + rs$interrupt() + + deadline <- Sys.time() + as.difftime(2, units = "secs") + while (Sys.time() < deadline) { + of2 <- ps::ps_open_files(ps::ps_handle(rs$get_pid())) + if (!normalizePath(tmp) %in% normalizePath(of2$path)) { + break + } + } + expect_false(normalizePath(tmp) %in% normalizePath(of2$path)) +}) + +test_that("clean up file descriptor on timeout", { + skip_on_cran() + tmp <- tempfile() + l <- filelock::lock(tmp) + rs <- callr::r_session$new() + on.exit(rs$close(), add = TRUE) + rs$call( + function(path) .GlobalEnv$lock <- filelock::lock(path, timeout = 10), + list(tmp) + ) + rs$poll_io(1000) + deadline <- Sys.time() + as.difftime(2, units = "secs") + while (Sys.time() < deadline) { + of <- ps::ps_open_files(ps::ps_handle(rs$get_pid())) + if (!normalizePath(tmp) %in% normalizePath(of$path)) { + break + } + } + expect_true(!normalizePath(tmp) %in% normalizePath(of$path)) +})