Use an seqlite3 DB for metadata

R/db.R

@@ -0,0 +1,90 @@
+
+db_cols <- read.table(
+  header = TRUE,
+  stringsAsFactors = FALSE,
+  textConnection(
+    "column                type
+     package               TEXT
+     version               TEXT
+     depends               TEXT
+     imports               TEXT
+     suggests              TEXT
+     linkingto             TEXT
+     enhances              TEXT
+     license               TEXT
+     license_restricts_use BOOLEAN
+     license_is_foss       BOOLEAN
+     os_type               TEXT
+     priority              TEXT
+     repodir               TEXT
+     rversion              TEXT
+     platform              TEXT
+     needscompilation      BOOLEAN
+     ref                   TEXT
+     type                  TEXT
+     direct                BOOLEAN
+     status                TEXT
+     target                TEXT
+     mirror                TEXT
+     sources               TEXT
+     filesize              INTEGER
+     sha256                TEXT
+     sysreqs               TEXT
+     built                 TEXT
+     published             TEXT
+     md5sum                TEXT
+     path                  TEXT
+"))
+
+db_create <- function(path) {
+  path <- enc2utf8(path)
+  q <- paste0(
+    "CREATE TABLE package (",
+    paste(db_cols$column, db_cols$type, collapse = ", "),
+    ");"
+  )
+
+  .Call(c_sql3_create_db, path, q)
+}
+
+db_add_packages <- function(path, packages_path, meta_path, mirror,
+                            repodir, platform, type) {
+  path <- enc2utf8(path)
+  mirror <- enc2utf8(mirror)
+
+  packages <- parse_packages(packages_path)
+  names(packages) <- tolower(names(packages))
+  keep <- intersect(db_cols$column, names(packages))
+  packages2 <- packages[, keep]
+
+  packages2$repodir <- rep(repodir, nrow(packages2))
+  packages2$platform <- rep(platform, nrow(packages2))
+  packages2$ref <- packages2$package
+  packages2$direct <- rep(FALSE, nrow(packages2))
+  packages2$status <- rep("OK", nrow(packages2))
+  packages2$mirror <- rep(mirror, nrow(packages2))
+  packages2$type <- rep(type, nrow(packages2))
+  packages2$target <- packages_make_target(
+    platform, repodir, packages2$package, packages2$version,
+    packages2[["file"]], packages2[["path"]]
+  )
+
+  meta <- read_metadata_file(meta_path)
+  if (!is.null(meta)) {
+
+  }
+
+  # TODO: platform
+  # TODO: rversion
+
+  query <- paste0(
+    "INSERT INTO package (",
+    paste(names(packages2), collapse = ", "),
+    ") VALUES (",
+    paste(rep("?", ncol(packages2)), collapse = ", "),
+    ")"
+  )
+
+  print(setdiff(db_cols$column, names(packages2)))
+  .Call(c_sql3_add_packages, path, packages2, query)
+}

R/onload.R

@@ -615,6 +615,7 @@ onload_pkgcache <- function(libname, pkgname) {
   pkgenv$global_metadata_cache <- new.env(parent = emptyenv())
   pkgenv$archive_cache <- new.env(parent = emptyenv())
   err$onload_hook()
+  .Call(c_sql3_set_tempdir, enc2utf8(tempdir()))
 }
 
 if (exists(".onLoad", inherits = FALSE)) {

R/sqlite.R

@@ -0,0 +1 @@
+

src/cleancall.c

@@ -0,0 +1,166 @@
+#define R_NO_REMAP
+#include <Rinternals.h>
+
+#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() {
+  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);
+}

src/cleancall.h

@@ -0,0 +1,41 @@
+#ifndef CLEANCALL_H
+#define CLEANCALL_H
+
+#include <Rversion.h>
+#include <R_ext/Rdynload.h>
+
+// --------------------------------------------------------------------
+// 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();
+
+// --------------------------------------------------------------------
+// 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

src/init.c

@@ -1,5 +1,6 @@
 
 #include "pkgcache.h"
+#include "cleancall.h"
 
 #include <R_ext/Rdynload.h>
 
@@ -23,6 +24,12 @@ SEXP pkgcache__gcov_flush(void) {
 #define REG(name, args) { #name, (DL_FUNC) name, args }
 
 static const R_CallMethodDef callMethods[]  = {
+  CLEANCALL_METHOD_RECORD,
+
+  REG(c_sql3_set_tempdir,             1),
+  REG(c_sql3_create_db,               2),
+  REG(c_sql3_add_packages,            3),
+
   REG(pkgcache_read_raw,              1),
   REG(pkgcache_parse_description_raw, 1),
   REG(pkgcache_parse_description,     1),
@@ -38,4 +45,5 @@ void R_init_pkgcache(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);
 }

src/pkgcache.h

@@ -11,4 +11,8 @@ SEXP pkgcache_parse_descriptions(SEXP paths, SEXP lowercase);
 
 SEXP pkgcache_parse_packages_raw(SEXP raw);
 
+SEXP c_sql3_set_tempdir(SEXP path);
+SEXP c_sql3_create_db(SEXP path);
+SEXP c_sql3_add_packages(SEXP path, SEXP packages, SEXP query);
+
 SEXP pkgcache_graphics_api_version(void);