RJDBC: Provides access to databases through the JDBC interface

Documented in JDBC

##=== JDBCDriver

setClass("JDBCDriver", representation("DBIDriver", identifier.quote="character", jdrv="jobjRef"))

JDBC <- function(driverClass='', classPath='', identifier.quote=NA) {
  ## expand all paths in the classPath
  classPath <- path.expand(unlist(strsplit(classPath, .Platform$path.sep)))
  .jinit(classPath) ## this is benign in that it's equivalent to .jaddClassPath if a JVM is running
  .jaddClassPath(system.file("java", "RJDBC.jar", package="RJDBC"))
  if (nchar(driverClass) && is.jnull(.jfindClass(as.character(driverClass)[1])))
    stop("Cannot find JDBC driver class ",driverClass)
  jdrv <- .jnew(driverClass, check=FALSE)
  .jcheck(TRUE)
  if (is.jnull(jdrv)) jdrv <- .jnull()
  new("JDBCDriver", identifier.quote=as.character(identifier.quote), jdrv=jdrv)
}

.verify.JDBC.result <- function (result, ...) {
  if (is.jnull(result)) {
    x <- .jgetEx(TRUE)
    if (is.jnull(x))
      stop(...)
    else
      stop(...," (",.jcall(x, "S", "getMessage"),")")
  }
}

setMethod("dbListConnections", "JDBCDriver", def=function(drv, ...) { warning("JDBC driver maintains no list of active connections."); list() })

setMethod("dbGetInfo", "JDBCDriver", def=function(dbObj, ...)
  list(name="JDBC", driver.version="0.1-1",
       DBI.version="0.1-1",
       client.version=NA,
       max.connections=NA)
          )

setMethod("dbUnloadDriver", "JDBCDriver", def=function(drv, ...) FALSE)

setMethod("dbConnect", "JDBCDriver", def=function(drv, url, user='', password='', ...) {
  jc <- .jcall("java/sql/DriverManager","Ljava/sql/Connection;","getConnection", as.character(url)[1], as.character(user)[1], as.character(password)[1], check=FALSE)
  if (is.jnull(jc) && !is.jnull(drv@jdrv)) {
    # ok one reason for this to fail is its interaction with rJava's
    # class loader. In that case we try to load the driver directly.
    oex <- .jgetEx(TRUE)
    p <- .jnew("java/util/Properties")
    if (length(user)==1 && nchar(user)) .jcall(p,"Ljava/lang/Object;","setProperty","user",user)
    if (length(password)==1 && nchar(password)) .jcall(p,"Ljava/lang/Object;","setProperty","password",password)
    l <- list(...)
    if (length(names(l))) for (n in names(l)) .jcall(p, "Ljava/lang/Object;", "setProperty", n, as.character(l[[n]]))
    jc <- .jcall(drv@jdrv, "Ljava/sql/Connection;", "connect", as.character(url)[1], p)
  }
  .verify.JDBC.result(jc, "Unable to connect JDBC to ",url)
  new("JDBCConnection", jc=jc, identifier.quote=drv@identifier.quote)},
          valueClass="JDBCConnection")

### JDBCConnection

setClass("JDBCConnection", representation("DBIConnection", jc="jobjRef", identifier.quote="character"))

setMethod("dbDisconnect", "JDBCConnection", def=function(conn, ...)
          {.jcall(conn@jc, "V", "close"); TRUE})

.fillStatementParameters <- function(s, l) {
  for (i in 1:length(l)) {
    v <- l[[i]]
    if (is.na(v)) { # map NAs to NULLs (courtesy of Axel Klenk)
      sqlType <- if (is.integer(v)) 4 else if (is.numeric(v)) 8 else 12
      .jcall(s, "V", "setNull", i, as.integer(sqlType))
    } else if (is.integer(v))
      .jcall(s, "V", "setInt", i, v[1])
    else if (is.numeric(v))
      .jcall(s, "V", "setDouble", i, as.double(v)[1])
    else
      .jcall(s, "V", "setString", i, as.character(v)[1])
  }
}

setMethod("dbSendQuery", signature(conn="JDBCConnection", statement="character"),  def=function(conn, statement, ..., list=NULL) {
  statement <- as.character(statement)[1L]
  ## if the statement starts with {call or {?= call then we use CallableStatement
  if (isTRUE(as.logical(grepl("^\\{(call|\\?= *call)", statement)))) {
    s <- .jcall(conn@jc, "Ljava/sql/CallableStatement;", "prepareCall", statement, check=FALSE)
    .verify.JDBC.result(s, "Unable to execute JDBC callable statement ",statement)
    if (length(list(...))) .fillStatementParameters(s, list(...))
    if (!is.null(list)) .fillStatementParameters(s, list)
    r <- .jcall(s, "Ljava/sql/ResultSet;", "executeQuery", check=FALSE)
    .verify.JDBC.result(r, "Unable to retrieve JDBC result set for ",statement)
  } else if (length(list(...)) || length(list)) { ## use prepared statements if there are additional arguments
    s <- .jcall(conn@jc, "Ljava/sql/PreparedStatement;", "prepareStatement", statement, check=FALSE)
    .verify.JDBC.result(s, "Unable to execute JDBC prepared statement ", statement)
    if (length(list(...))) .fillStatementParameters(s, list(...))
    if (!is.null(list)) .fillStatementParameters(s, list)
    r <- .jcall(s, "Ljava/sql/ResultSet;", "executeQuery", check=FALSE)
    .verify.JDBC.result(r, "Unable to retrieve JDBC result set for ",statement)
  } else { ## otherwise use a simple statement some DBs fail with the above)
    s <- .jcall(conn@jc, "Ljava/sql/Statement;", "createStatement")
    .verify.JDBC.result(s, "Unable to create simple JDBC statement ",statement)
    r <- .jcall(s, "Ljava/sql/ResultSet;", "executeQuery", as.character(statement)[1], check=FALSE)
    .verify.JDBC.result(r, "Unable to retrieve JDBC result set for ",statement)
  }
  md <- .jcall(r, "Ljava/sql/ResultSetMetaData;", "getMetaData", check=FALSE)
  .verify.JDBC.result(md, "Unable to retrieve JDBC result set meta data for ",statement, " in dbSendQuery")
  new("JDBCResult", jr=r, md=md, stat=s, pull=.jnull())
})

if (is.null(getGeneric("dbSendUpdate"))) setGeneric("dbSendUpdate", function(conn, statement, ...) standardGeneric("dbSendUpdate"))

setMethod("dbSendUpdate",  signature(conn="JDBCConnection", statement="character"),  def=function(conn, statement, ..., list=NULL) {
  statement <- as.character(statement)[1L]
  ## if the statement starts with {call or {?= call then we use CallableStatement
  if (isTRUE(as.logical(grepl("^\\{(call|\\?= *call)", statement)))) {
    s <- .jcall(conn@jc, "Ljava/sql/CallableStatement;", "prepareCall", statement, check=FALSE)
    .verify.JDBC.result(s, "Unable to execute JDBC callable statement ",statement)
    on.exit(.jcall(s, "V", "close")) # same as ORA issue below and #4
    if (length(list(...))) .fillStatementParameters(s, list(...))
    if (!is.null(list)) .fillStatementParameters(s, list)
    r <- .jcall(s, "Ljava/sql/ResultSet;", "executeQuery", check=FALSE)
    .verify.JDBC.result(r, "Unable to retrieve JDBC result set for ",statement)
  } else if (length(list(...)) || length(list)) { ## use prepared statements if there are additional arguments
    s <- .jcall(conn@jc, "Ljava/sql/PreparedStatement;", "prepareStatement", statement, check=FALSE)
    .verify.JDBC.result(s, "Unable to execute JDBC prepared statement ", statement)
    on.exit(.jcall(s, "V", "close")) # this will fix issue #4 and http://stackoverflow.com/q/21603660/2161065
    if (length(list(...))) .fillStatementParameters(s, list(...))
    if (!is.null(list)) .fillStatementParameters(s, list)
    .jcall(s, "I", "executeUpdate", check=FALSE)
  } else {
    s <- .jcall(conn@jc, "Ljava/sql/Statement;", "createStatement")
    .verify.JDBC.result(s, "Unable to create JDBC statement ",statement)
    on.exit(.jcall(s, "V", "close")) # in theory this is not necesary since 's' will go away and be collected, but appearently it may be too late for Oracle (ORA-01000)
    .jcall(s, "I", "executeUpdate", as.character(statement)[1], check=FALSE)
  }
  x <- .jgetEx(TRUE)
  if (!is.jnull(x)) stop("execute JDBC update query failed in dbSendUpdate (", .jcall(x, "S", "getMessage"),")")
})

setMethod("dbGetQuery", signature(conn="JDBCConnection", statement="character"),  def=function(conn, statement, ...) {
  r <- dbSendQuery(conn, statement, ...)
  ## Teradata needs this - closing the statement also closes the result set according to Java docs
  on.exit(.jcall(r@stat, "V", "close"))
  fetch(r, -1)
})

setMethod("dbGetException", "JDBCConnection",
          def = function(conn, ...) list()
          , valueClass = "list")

setMethod("dbGetInfo", "JDBCConnection",
          def = function(dbObj, ...) list() )

setMethod("dbListResults", "JDBCConnection",
          def = function(conn, ...) { warning("JDBC maintains no list of active results"); NULL }
          )

.fetch.result <- function(r) {
  md <- .jcall(r, "Ljava/sql/ResultSetMetaData;", "getMetaData", check=FALSE)
  .verify.JDBC.result(md, "Unable to retrieve JDBC result set meta data")
  res <- new("JDBCResult", jr=r, md=md, stat=.jnull(), pull=.jnull())
  fetch(res, -1)
}

setMethod("dbListTables", "JDBCConnection", def=function(conn, pattern="%", ...) {
  md <- .jcall(conn@jc, "Ljava/sql/DatabaseMetaData;", "getMetaData", check=FALSE)
  .verify.JDBC.result(md, "Unable to retrieve JDBC database metadata")
  r <- .jcall(md, "Ljava/sql/ResultSet;", "getTables", .jnull("java/lang/String"),
              .jnull("java/lang/String"), pattern, .jnull("[Ljava/lang/String;"), check=FALSE)
  .verify.JDBC.result(r, "Unable to retrieve JDBC tables list")
  on.exit(.jcall(r, "V", "close"))
  ts <- character()
  while (.jcall(r, "Z", "next"))
    ts <- c(ts, .jcall(r, "S", "getString", "TABLE_NAME"))
  ts
})

if (is.null(getGeneric("dbGetTables"))) setGeneric("dbGetTables", function(conn, ...) standardGeneric("dbGetTables"))

setMethod("dbGetTables", "JDBCConnection", def=function(conn, pattern="%", ...) {
  md <- .jcall(conn@jc, "Ljava/sql/DatabaseMetaData;", "getMetaData", check=FALSE)
  .verify.JDBC.result(md, "Unable to retrieve JDBC database metadata")
  r <- .jcall(md, "Ljava/sql/ResultSet;", "getTables", .jnull("java/lang/String"),
              .jnull("java/lang/String"), pattern, .jnull("[Ljava/lang/String;"), check=FALSE)
  .verify.JDBC.result(r, "Unable to retrieve JDBC tables list")
  on.exit(.jcall(r, "V", "close"))
  .fetch.result(r)
})

setMethod("dbExistsTable", "JDBCConnection", def=function(conn, name, ...) (length(dbListTables(conn, name))>0))

setMethod("dbRemoveTable", "JDBCConnection", def=function(conn, name, ...) dbSendUpdate(conn, paste("DROP TABLE", name))==0)

setMethod("dbListFields", "JDBCConnection", def=function(conn, name, pattern="%", full=FALSE, ...) {
  md <- .jcall(conn@jc, "Ljava/sql/DatabaseMetaData;", "getMetaData", check=FALSE)
  .verify.JDBC.result(md, "Unable to retrieve JDBC database metadata")
  r <- .jcall(md, "Ljava/sql/ResultSet;", "getColumns", .jnull("java/lang/String"),
              .jnull("java/lang/String"), name, pattern, check=FALSE)
  .verify.JDBC.result(r, "Unable to retrieve JDBC columns list for ",name)
  on.exit(.jcall(r, "V", "close"))
  ts <- character()
  while (.jcall(r, "Z", "next"))
    ts <- c(ts, .jcall(r, "S", "getString", "COLUMN_NAME"))
  .jcall(r, "V", "close")
  ts
})

if (is.null(getGeneric("dbGetFields"))) setGeneric("dbGetFields", function(conn, ...) standardGeneric("dbGetFields"))

setMethod("dbGetFields", "JDBCConnection", def=function(conn, name, pattern="%", ...) {
  md <- .jcall(conn@jc, "Ljava/sql/DatabaseMetaData;", "getMetaData", check=FALSE)
  .verify.JDBC.result(md, "Unable to retrieve JDBC database metadata")
  r <- .jcall(md, "Ljava/sql/ResultSet;", "getColumns", .jnull("java/lang/String"),
              .jnull("java/lang/String"), name, pattern, check=FALSE)
  .verify.JDBC.result(r, "Unable to retrieve JDBC columns list for ",name)
  on.exit(.jcall(r, "V", "close"))
  .fetch.result(r)
})

setMethod("dbReadTable", "JDBCConnection", def=function(conn, name, ...)
          dbGetQuery(conn, paste("SELECT * FROM",.sql.qescape(name,TRUE,conn@identifier.quote))))

setMethod("dbDataType", signature(dbObj="JDBCConnection", obj = "ANY"),
          def = function(dbObj, obj, ...) {
            if (is.integer(obj)) "INTEGER"
            else if (is.numeric(obj)) "DOUBLE PRECISION"
            else "VARCHAR(255)"
          }, valueClass = "character")

.sql.qescape <- function(s, identifier=FALSE, quote="\"") {
  s <- as.character(s)
  if (identifier) {
    vid <- grep("^[A-Za-z]+([A-Za-z0-9_]*)$",s)
    if (length(s[-vid])) {
      if (is.na(quote)) stop("The JDBC connection doesn't support quoted identifiers, but table/column name contains characters that must be quoted (",paste(s[-vid],collapse=','),")")
      s[-vid] <- .sql.qescape(s[-vid], FALSE, quote)
    }
    return(s)
  }
  if (is.na(quote)) quote <- ''
  s <- gsub("\\\\","\\\\\\\\",s)
  if (nchar(quote)) s <- gsub(paste("\\",quote,sep=''),paste("\\\\\\",quote,sep=''),s,perl=TRUE)
  paste(quote,s,quote,sep='')
}

setMethod("dbWriteTable", "JDBCConnection", def=function(conn, name, value, overwrite=TRUE, append=FALSE, ...) {
  ac <- .jcall(conn@jc, "Z", "getAutoCommit")
  overwrite <- isTRUE(as.logical(overwrite))
  append <- if (overwrite) FALSE else isTRUE(as.logical(append))
  if (is.vector(value) && !is.list(value)) value <- data.frame(x=value)
  if (length(value)<1) stop("value must have at least one column")
  if (is.null(names(value))) names(value) <- paste("V",1:length(value),sep='')
  if (length(value[[1]])>0) {
    if (!is.data.frame(value)) value <- as.data.frame(value, row.names=1:length(value[[1]]))
  } else {
    if (!is.data.frame(value)) value <- as.data.frame(value)
  }
  fts <- sapply(value, dbDataType, dbObj=conn)
  if (dbExistsTable(conn, name)) {
    if (overwrite) dbRemoveTable(conn, name)
    else if (!append) stop("Table `",name,"' already exists")
  } else if (append) stop("Cannot append to a non-existing table `",name,"'")
  fdef <- paste(.sql.qescape(names(value), TRUE, conn@identifier.quote),fts,collapse=',')
  qname <- .sql.qescape(name, TRUE, conn@identifier.quote)
  if (ac) {
    .jcall(conn@jc, "V", "setAutoCommit", FALSE)
    on.exit(.jcall(conn@jc, "V", "setAutoCommit", ac))
  }
  if (!append) {
    ct <- paste("CREATE TABLE ",qname," (",fdef,")",sep= '')
    dbSendUpdate(conn, ct)
  }
  if (length(value[[1]])) {
    inss <- paste("INSERT INTO ",qname," VALUES(", paste(rep("?",length(value)),collapse=','),")",sep='')
    for (j in 1:length(value[[1]]))
      dbSendUpdate(conn, inss, list=as.list(value[j,]))
  }
  if (ac) dbCommit(conn)
})

setMethod("dbCommit", "JDBCConnection", def=function(conn, ...) {.jcall(conn@jc, "V", "commit"); TRUE})
setMethod("dbRollback", "JDBCConnection", def=function(conn, ...) {.jcall(conn@jc, "V", "rollback"); TRUE})

##=== JDBCResult
## jr - result set, md - metadata, stat - statement
## Since the life of a result set depends on the life of the statement, we have to explicitly
## save the later as well (and close both at the end)

setClass("JDBCResult", representation("DBIResult", jr="jobjRef", md="jobjRef", stat="jobjRef", pull="jobjRef"))

setMethod("fetch", signature(res="JDBCResult", n="numeric"), def=function(res, n, block=8L, ...) {
  cols <- .jcall(res@md, "I", "getColumnCount")
  block <- as.integer(block)
  if (length(block) != 1L) stop("invalid block size")
  if (cols < 1L) return(NULL)
  l <- list()
  cts <- rep(0L, cols)
  for (i in 1:cols) {
    ct <- .jcall(res@md, "I", "getColumnType", i)
    if (ct == -5 | ct ==-6 | (ct >= 2 & ct <= 8)) {
      l[[i]] <- numeric()
      cts[i] <- 1L
    } else
      l[[i]] <- character()
    names(l)[i] <- .jcall(res@md, "S", "getColumnName", i)
  }
  rp <- res@pull
  if (is.jnull(rp)) {
    rp <- .jnew("info/urbanek/Rpackage/RJDBC/JDBCResultPull", .jcast(res@jr, "java/sql/ResultSet"), .jarray(as.integer(cts)))
    .verify.JDBC.result(rp, "cannot instantiate JDBCResultPull hepler class")
  }
  if (n < 0L) { ## infinite pull
    stride <- 32768L  ## start fairly small to support tiny queries and increase later
    while ((nrec <- .jcall(rp, "I", "fetch", stride, block)) > 0L) {
      for (i in seq.int(cols))
        l[[i]] <- c(l[[i]], if (cts[i] == 1L) .jcall(rp, "[D", "getDoubles", i) else .jcall(rp, "[Ljava/lang/String;", "getStrings", i))
      if (nrec < stride) break
      stride <- 524288L # 512k
    }
  } else {
    nrec <- .jcall(rp, "I", "fetch", as.integer(n), block)
    for (i in seq.int(cols)) l[[i]] <- if (cts[i] == 1L) .jcall(rp, "[D", "getDoubles", i) else .jcall(rp, "[Ljava/lang/String;", "getStrings", i)
  }
  # as.data.frame is expensive - create it on the fly from the list
  attr(l, "row.names") <- c(NA_integer_, length(l[[1]]))
  class(l) <- "data.frame"
  l
})

setMethod("dbClearResult", "JDBCResult",
          def = function(res, ...) { .jcall(res@jr, "V", "close"); .jcall(res@stat, "V", "close"); TRUE },
          valueClass = "logical")

setMethod("dbGetInfo", "JDBCResult", def=function(dbObj, ...) list(has.completed=TRUE), valueClass="list")

## this is not needed for recent DBI, but older implementations didn't provide default methods
setMethod("dbHasCompleted", "JDBCResult", def=function(res, ...) TRUE, valueClass="logical")

setMethod("dbColumnInfo", "JDBCResult", def = function(res, ...) {
  cols <- .jcall(res@md, "I", "getColumnCount")
  l <- list(field.name=character(), field.type=character(), data.type=character())
  if (cols < 1) return(as.data.frame(l))
  for (i in 1:cols) {
    l$field.name[i] <- .jcall(res@md, "S", "getColumnName", i)
    l$field.type[i] <- .jcall(res@md, "S", "getColumnTypeName", i)
    ct <- .jcall(res@md, "I", "getColumnType", i)
    l$data.type[i] <- if (ct == -5 | ct ==-6 | (ct >= 2 & ct <= 8)) "numeric" else "character"
  }
  as.data.frame(l, row.names=1:cols)
},
          valueClass = "data.frame")