##=== JDBCDriver
setClass("JDBCDriver", representation("DBIDriver", identifier.quote="character", jdrv="jobjRef", options="list"))
setClass("JDBCConnection", representation("DBIConnection", jc="jobjRef", identifier.quote="character", options="list", auto.commit="logical"))
##=== 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", env="environment", conn="JDBCConnection"))
setGeneric("dbOption", function(dbo, name, default) default)
setMethod("dbOption", "JDBCDriver", function(dbo, name, default) if (name %in% names(dbo@options)) dbo@options[[name]] else default)
setMethod("dbOption", "JDBCConnection", function(dbo, name, default) if (name %in% names(dbo@options)) dbo@options[[name]] else default)
setMethod("dbOption", "JDBCResult", function(dbo, name, default) dbOption(dbo@conn, name, default))
JDBC <- function(driverClass='', classPath='', identifier.quote=NA, ...) {
opts <- list(...)
## we allow the user to supply the class itself in case they got
## it through some other means (like findDrivers())
if (is(driverClass, "jobjRef") || (is.list(driverClass) && length(driverClass) > 0 && is(driverClass[[1L]], "jobjRef"))) {
if (is.list(driverClass)) driverClass <- driverClass[[1L]]
if (!isTRUE(.jcall(.jfindClass("java.sql.Driver"), "Z", "isInstance", .jcast(driverClass, "java.lang.Object"))))
stop("Provided class object is not a subclass of java.sql.Driver")
return(new("JDBCDriver", identifier.quote=as.character(identifier.quote), jdrv=driverClass, options=opts))
}
## 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 (is.null(driverClass) || !nzchar(driverClass)) ## NULL driver
return(new("JDBCDriver", identifier.quote=as.character(identifier.quote), jdrv=.jnull("java.sql.Driver")))
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)
}
findDrivers <- function(classPath="", service="java.sql.Driver", loader=NULL) {
## we have to make sure we have a JVM
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"))
l <- if (is.jnull(loader))
.jcall("java.util.ServiceLoader", "Ljava/util/ServiceLoader;", "load", .jfindClass(service))
else
.jcall("java.util.ServiceLoader", "Ljava/util/ServiceLoader;", "load", .jfindClass(service), .jcast(loader, "java.lang.ClassLoader"))
i <- .jcall(l, "Ljava/util/Iterator;", "iterator")
d <- list()
while (.jcall(i, "Z", "hasNext"))
d <- c(d, list(.jcall(i, "Ljava/lang/Object;", "next")))
d
}
## construct list of class names all the way down to Object
## It is guarded by tryCatch() so should always return, possibly character()
## NOTE: uses Java calls so exceptions must be cleared prior, it will
## clear exceptions if it fails itself
.classes <- function(x) {
cl <- character()
tryCatch(
if (!is.jnull(x)) {
c <- .jcall(x, "Ljava/lang/Class;", "getClass")
while(!is.jnull(c)) {
cl <- c(cl, .jcall(c, "S", "getName"))
c <- .jcall(c, "Ljava/lang/Class;", "getSuperclass")
}
}, error=function(e) {
warning("Error while collecting class hierarchy in Java error handing")
.jcheck(TRUE)
})
cl
}
## calls .jgetEx(TRUE) and raises a JDBC.exception condition including
## class hierarchy of the Java exception
## returns TRUE invisibly if there is no exception
.verify.ex <- function (..., statement, class=character(), call=sys.call(-1)) {
statement.txt <- if (missing(statement)) "" else paste0("\n Statement: ", statement)
if (missing(statement)) statement <- NULL
x <- .jgetEx(TRUE)
if (!is.jnull(x))
stop(errorCondition(paste0(..., "\n JDBC ERROR: ",.jcall(x, "S", "getMessage"), statement.txt), call=call,
desc=paste0(...), jex=x, statement=statement, class=c(class, "JDBC.exception", .classes(x))))
invisible(TRUE)
}
## requires result to be non-NULL or else calls .verify.ex() and raises an exception (even if there is no Java exception)
## The error has always at least JDBC.result.error class
.verify.JDBC.result <- function (result, ..., statement) {
if (is.jnull(result)) {
.verify.ex(..., statement=statement, class="JDBC.result.error", call=sys.call(-2))
## if we get here then there is no exception - just no result
statement.txt <- if (missing(statement)) "" else paste0("\n Statement: ", statement)
if (missing(statement)) statement <- NULL
stop(errorCondition(paste0(..., statement.txt), desc=paste0(..., statement.txt), statement=statement, class="JDBC.result.error", call=sys.call(-1)))
}
invisible(TRUE)
}
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='', ..., dbOptions) {
## We used to try DriverManager first, but now we don't use DriverManager if there
## is a driver, because DriverManager is NOT dynamic and will fail to locate drivers
## that have been added after the JVM has started. Also it ignores ... parameters.
jc <- if (is.jnull(drv@jdrv))
.jcall("java/sql/DriverManager","Ljava/sql/Connection;","getConnection", as.character(url)[1], as.character(user)[1], as.character(password)[1], check=FALSE)
else NULL
if (is.null(jc) && !is.jnull(drv@jdrv)) {
oex <- .jgetEx(TRUE)
p <- .jnew("java/util/Properties")
if (length(user)==1 && nzchar(user)) .jcall(p, "Ljava/lang/Object;", "setProperty", "user", as.character(user))
if (length(password)==1 && nzchar(password)) .jcall(p, "Ljava/lang/Object;", "setProperty", "password", as.character(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, check=FALSE)
}
.verify.JDBC.result(jc, "Unable to connect JDBC to ",url)
opts <- drv@options
if (!missing(dbOptions) && is.list(dbOptions))
for (opt in names(dbOptions))
opts[[opt]] <- dbOptions[[opt]]
if (is.logical(opts$autocommit) && length(opts$autocommit) == 1L) {
.jcall(jc, "V", "setAutoCommit", opts$autocommit)
.verify.ex("Unable to set autocommit to ", opts$autocommit)
}
ac <- .jcall(jc, "Z", "getAutoCommit")
.verify.ex("Unable to determine autocommit state")
new("JDBCConnection", jc=jc, identifier.quote=drv@identifier.quote, options=opts, auto.commit=ac)
}, valueClass="JDBCConnection")
### JDBCConnection
setMethod("dbDisconnect", "JDBCConnection", def=function(conn, ...)
{.jcall(conn@jc, "V", "close"); TRUE})
## new DBI API?
if (!is.null(asNamespace("DBI")$dbIsValid)) {
setMethod("dbIsValid", "JDBCConnection", def=function(dbObj, timeout=0, ...)
(!is.jnull(dbObj@jc)) &&
## SAS JDBC driver is broken and doesn't implement isValid() even though it is
## part of the JDBC 2.0 standard (JDK 1.6, 2006), so fall back to isClosed() on error
tryCatch(.jcall(dbObj@jc, "Z", "isValid", as.integer(timeout)[1]),
error=function(e) !.jcall(dbObj@jc, "Z", "isClosed")))
setMethod("dbIsValid", "JDBCResult", def=function(dbObj, ...)
!(is.jnull(dbObj@jr) || .jcall(dbObj@jr, "Z", "isClosed")))
}
## populate query parameters - non-vectorised version only
## ldots are typically list(...) and only unnamed args will
## be used, while all elements from list= will be used
.fillStatementParameters <- function(s, ldots=NULL, list=NULL) {
## remove named arguments from ldots as they are assumed to be
## additional method arguments and not part of the query
if (length(ldots) && !is.null(names(ldots)))
ldots <- ldots[names(ldots) == ""]
l <- c(ldots, list)
if (length(l) < 1) return (NULL)
for (i in 1:length(l)) {
v <- l[[i]]
if (length(v) > 1)
stop("Vectorized parameters are only supported in batch-updates via dbSendUpdate(), not in queries")
if (is.null(v) || is.na(v)) { # map NAs to NULLs (courtesy of Axel Klenk)
sqlType <- if (is.integer(v)) 4L else if (is.numeric(v)) 8L else 12L
.jcall(s, "V", "setNull", i, sqlType)
} else if (is.integer(v))
.jcall(s, "V", "setInt", i, v)
else if (is.numeric(v))
.jcall(s, "V", "setDouble", i, as.double(v))
else
.jcall(s, "V", "setString", i, as.character(v))
}
}
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=statement)
.fillStatementParameters(s, list(...), list)
r <- .jcall(s, "Ljava/sql/ResultSet;", "executeQuery", check=FALSE)
.verify.JDBC.result(r, "Unable to retrieve JDBC result set for ", statement=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=statement)
.fillStatementParameters(s, list(...), list)
r <- .jcall(s, "Ljava/sql/ResultSet;", "executeQuery", check=FALSE)
.verify.JDBC.result(r, "Unable to retrieve JDBC result set", statement=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=statement)
r <- .jcall(s, "Ljava/sql/ResultSet;", "executeQuery", as.character(statement)[1], check=FALSE)
.verify.JDBC.result(r, "Unable to retrieve JDBC result set", statement=statement)
}
md <- .jcall(r, "Ljava/sql/ResultSetMetaData;", "getMetaData", check=FALSE)
.verify.JDBC.result(md, "Unable to retrieve JDBC result set meta data in dbSendQuery", statement=statement)
new("JDBCResult", jr=r, md=md, stat=s, env=new.env(parent=emptyenv()), conn=conn)
})
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, max.batch=10000L) {
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=statement)
on.exit(.jcall(s, "V", "close")) # same as ORA issue below and #4
.fillStatementParameters(s, list(...), list)
r <- .jcall(s, "Ljava/sql/ResultSet;", "executeQuery", check=FALSE)
.verify.JDBC.result(r, "Unable to retrieve JDBC result set", statement=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 create JDBC prepared statement", statement=statement)
on.exit(.jcall(s, "V", "close")) # this will fix issue #4 and http://stackoverflow.com/q/21603660/2161065
l <- list(...)
## strip named arguments from ... but not list
if (!is.null(names(l))) l <- l[names(l) == ""]
l <- c(l, list)
names(l) <- NULL
if (length(l)) {
if (length(tl <- table(sapply(l, length))) > 1) stop("all parameters must have the same length")
if (as.integer(names(tl)) > 1) { ## batch insert
bx <- .jnew("info/urbanek/Rpackage/RJDBC/JDBCBatchExecute", s, length(l))
.verify.JDBC.result(bx, "Unable to create batch-insert object")
for (o in l) {
if (is.integer(o)) .jcall(bx, "V", "addIntegers", o)
else if (is.numeric(o)) .jcall(bx, "V", "addDoubles", o)
else .jcall(bx, "V", "addStrings", as.character(o))
}
.jcall(bx, "V", "execute", as.integer(max.batch))
.verify.JDBC.result(bx, "Unable to execute batch-insert query", statement=statement)
} else {
.fillStatementParameters(s, l)
.jcall(s, "I", "executeUpdate", check=FALSE)
}
} else
.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=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)
}
.verify.ex("execute JDBC update query failed in dbSendUpdate", statement=statement)
})
setMethod("dbGetQuery", signature(conn="JDBCConnection", statement="character"),
def=function(conn, statement, ..., n=-1, block=dbOption(conn, "fetch.block", 2048L), use.label=TRUE,
lossy=dbOption(conn, "fetch.lossy", TRUE), tz=dbOption(conn, "fetch.tz", ""),
posix.ts=dbOption(conn, "fetch.posix.ts", TRUE)
) {
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, n, block=block, use.label=use.label, lossy=lossy, tz=tz, posix.ts=posix.ts)
})
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, conn) {
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(), env=new.env(parent=emptyenv()), conn=conn)
fetch(res, -1)
}
setMethod("dbListTables", "JDBCConnection", def=function(conn, pattern="%", schema=NULL, ...) {
md <- .jcall(conn@jc, "Ljava/sql/DatabaseMetaData;", "getMetaData", check=FALSE)
.verify.JDBC.result(md, "Unable to retrieve JDBC database metadata")
schema <- if (is.null(schema)) .jnull("java/lang/String") else as.character(schema)[1L]
r <- .jcall(md, "Ljava/sql/ResultSet;", "getTables", .jnull("java/lang/String"),
schema, 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="%", schema=NULL, ...) {
md <- .jcall(conn@jc, "Ljava/sql/DatabaseMetaData;", "getMetaData", check=FALSE)
.verify.JDBC.result(md, "Unable to retrieve JDBC database metadata")
schema <- if (is.null(schema)) .jnull("java/lang/String") else as.character(schema)[1L]
r <- .jcall(md, "Ljava/sql/ResultSet;", "getTables", .jnull("java/lang/String"),
schema, 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, conn)
})
setMethod("dbExistsTable", "JDBCConnection", def=function(conn, name, schema=NULL, ...) length(dbListTables(conn, name, schema)) > 0)
setMethod("dbRemoveTable", "JDBCConnection", def=function(conn, name, silent=FALSE, ...)
if (silent) tryCatch(dbRemoveTable(conn, name, silent=FALSE), error=function(e) FALSE) else dbSendUpdate(conn, paste("DROP TABLE", name)))
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, conn)
})
## There is a bug in DBI which consturcts invalid SQL in its default method for
## name=character. So we have to make sure it doesn't get picked by making sure
## we also set a character method even if we don't actually require it.
setMethod("dbReadTable", signature(conn="JDBCConnection", name="character"), def=function(conn, name, ...)
dbGetQuery(conn, paste("SELECT * FROM",.sql.qescape(name,TRUE,conn@identifier.quote)), ...))
## cover all the other cases where the user likely intended a coersion
setMethod("dbReadTable", signature(conn="JDBCConnection", name="ANY"), def=function(conn, name, ...)
dbGetQuery(conn, paste("SELECT * FROM",.sql.qescape(as.character(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=FALSE, append=FALSE, force=FALSE, field.types=NULL, ..., max.batch=10000L) {
ac <- .jcall(conn@jc, "Z", "getAutoCommit")
overwrite <- isTRUE(as.logical(overwrite))
append <- isTRUE(as.logical(append))
if (overwrite && append) stop("overwrite=TRUE and append=TRUE are mutually exclusive")
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)
}
if (isTRUE(as.logical(force))) {
if (overwrite) dbRemoveTable(conn, name, silent=TRUE)
} else if (dbExistsTable(conn, name)) {
if (overwrite) dbRemoveTable(conn, name)
else if (!append) stop("Table `",name,"' already exists")
} else append <- FALSE ## if the table doesn't exist, append has no meaning
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) {
fts <- if (is.null(field.types)) sapply(value, dbDataType, dbObj=conn) else field.types
if (length(fts) != length(names(value))) stop("field.types must have the same length as the number of columns")
fdef <- paste(.sql.qescape(names(value), TRUE, conn@identifier.quote), fts, collapse=',')
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='')
## make sure everything is a character other than real/int
list <- lapply(value, function(o) if (!is.numeric(o)) as.character(o) else o)
dbSendUpdate(conn, inss, list=list)
}
if (ac) dbCommit(conn)
invisible(TRUE)
})
setMethod("dbCommit", "JDBCConnection", def=function(conn, ...) {
.jcall(conn@jc, "V", "commit")
.verify.ex("commit failed")
if (!is.na(conn@auto.commit)) {
.jcall(conn@jc, "V", "setAutoCommit", conn@auto.commit)
.verify.ex("resetting auto-commit failed")
}
invisible(TRUE)
})
setMethod("dbRollback", "JDBCConnection", def=function(conn, ...) {
.jcall(conn@jc, "V", "rollback")
.verify.ex("rollback failed")
if (!is.na(conn@auto.commit)) {
.jcall(conn@jc, "V", "setAutoCommit", conn@auto.commit)
.verify.ex("resetting auto-commit failed")
}
invisible(TRUE)
})
setMethod("dbBegin", "JDBCConnection", def=function(conn, force=FALSE, ...) {
ac <- .jcall(conn@jc, "Z", "getAutoCommit")
.verify.ex("cannot determine transaction state")
if (ac) {
.jcall(conn@jc, "V", "setAutoCommit", FALSE)
.verify.ex("disabling auto-commit failed")
} else {
## if auto-commit is disabled there can be two reasons:
## - either it is a nested dbBegin() -> error or
## - the connection has been started with disabled auto-commit
## (not the default, but possible and allowed - see #97)
if (!force && !isTRUE(!conn@auto.commit))
stop("JDBC connection is already in transaction mode")
}
invisible(TRUE)
})
## NOTE: if you modify any defaults or add arguments, also check dbGetQuery() which attempts to pass those through!
setMethod("fetch", signature(res="JDBCResult", n="numeric"),
def=function(res, n, block=dbOption(res, "fetch.block", 2048L), use.label=TRUE,
lossy=dbOption(res, "fetch.lossy", TRUE), tz=dbOption(res, "fetch.tz", "GMT"),
posix.ts=dbOption(res, "fetch.posix.ts", TRUE),
...) {
getColumnLabel <- if(use.label) "getColumnLabel" else "getColumnName"
cols <- .jcall(res@md, "I", "getColumnCount")
block <- as.integer(block)
if (length(block) != 1L) stop("invalid block size")
if (cols < 1L) return(NULL)
l <- vector("list", cols)
cts <- rep(0L, cols) ## column type (as per JDBC)
rts <- rep(0L, cols) ## retrieval types (0 = string, 1 = double, 2 = integer, 3 = POSIXct)
for (i in 1:cols) {
## possible retrieval:
## getDouble(), getTimestamp() and getString()
## [NOTE: getBigDecimal() is native for all numeric() types]
## could cehck java.sql.Timestamp which has .getTime() in millis
cts[i] <- ct <- .jcall(res@md, "I", "getColumnType", i)
l[[i]] <- character()
## NOTE: this is also needed in dbColumnInfo() - see also JDBC.types
## -7 BIT, -6 TINYINT, 5 SMALLINT, 4 INTEGER, -5 BIGINT
## 6 FLOAT, 7 REAL, 8 DOUBLE, 2 NUMERIC, 3 DECIMAL
## 1 CHAR, 12 VARCHAR, -1 LONGVARCHAR
## 91 DATE, 92 TIME, 93 TIMESTAMP
## -2 BINARY, -3 VARBINARY, -4 LONGVARBINARY
## 0 NULL, 1111 OTHER, 2000 JAVA_OBJECT
## 16 BOOLEAN, 1.8+: 2013 TIME_WITH_TIMEZONE,
## 2014 TIMESTAMP_WITH_TIMEZONE
##
## integer-compatible typse
if (ct == 4L || ct == 5L || ct == -6L) {
l[[i]] <- integer()
rts[i] <- 2L
} else if (ct == -5L | (ct >= 2L & ct <= 8L)) { ## BIGINT and various float/num types
## some numeric types may exceed double precision (see #83)
## those must be retrieved as strings
##
## check precision for NUMERIC/DECIMAL
cp <- switch(as.character(ct),
`2` =, `3` = .jcall(res@md, "I", "getPrecision", i),
`-5`= 20L, ## BIGINT
0L)
if (cp <= 15 || isTRUE(lossy)) { ## safe to retrieve
l[[i]] <- numeric()
rts[i] <- 1L
}
} else if (ct >= 91L && ct <= 93L && isTRUE(posix.ts)) { ## DATE/TIME/TS
l[[i]] <- .POSIXct(numeric(), tz)
rts[i] <- 3L
} else if (ct == -7L) { ## BIT
l[[i]] <- logical()
rts[i] <- 4L
}
names(l)[i] <- .jcall(res@md, "S", getColumnLabel, i)
}
## print(list(templates=l, types=rts))
## print(types)
rp <- res@env$pull
if (is.jnull(rp)) {
rp <- .jnew("info/urbanek/Rpackage/RJDBC/JDBCResultPull", .jcast(res@jr, "java/sql/ResultSet"), .jarray(as.integer(rts)))
.verify.JDBC.result(rp, "cannot instantiate JDBCResultPull helper class")
res@env$pull <- rp
}
ret.fn <- list( ## retrieval functions for the different types
function(i) .jcall(rp, "[Ljava/lang/String;", "getStrings", i),
function(i) .jcall(rp, "[D", "getDoubles", i),
function(i) .jcall(rp, "[I", "getIntegers", i),
function(i) .jcall(rp, "[D", "getDoubles", i),
function(i) as.logical(.jcall(rp, "[I", "getIntegers", i)))
if (n < 0L) { ## infinite pull - collect (using pairlists) & join
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]] <- pairlist(l[[i]], ret.fn[[rts[i] + 1L]](i))
if (nrec < stride) break
stride <- 524288L # 512k
}
for (i in seq.int(cols)) l[[i]] <- unlist(l[[i]], TRUE, FALSE)
} else {
nrec <- .jcall(rp, "I", "fetch", as.integer(n), block)
for (i in seq.int(cols)) l[[i]] <- ret.fn[[rts[i] + 1L]](i)
}
## unlisting can strip attrs so do POSIXct at the end for TSs
ts.col <- rts == 3L
if (any(ts.col)) for (i in which(ts.col)) l[[i]] <- .POSIXct(l[[i]], tz)
# 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"
.remap.types(l, cts)
})
setMethod("dbClearResult", "JDBCResult",
def = function(res, ...) {
.jcall(res@jr, "V", "close")
.jcall(res@stat, "V", "close")
res@env$pull <- .jnull()
TRUE
},
valueClass = "logical")
setMethod("dbGetInfo", "JDBCResult", def=function(dbObj, ...)
list(
has.completed=dbHasCompleted(dbObj)
), valueClass="list")
setMethod("dbHasCompleted", "JDBCResult", def=function(res, ...) {
pull <- res@env$pull
comp <- if (is.jnull(pull)) .jcall(res@jr, "Z", "isClosed") else .jcall(pull, "Z", "completed")
.jcheck(TRUE)
comp
},
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(), precision=integer(), type.id=integer())
if (cols < 1) return(as.data.frame(l))
for (i in 1:cols) {
l$name[i] <- .jcall(res@md, "S", "getColumnLabel", 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"
l$field.name[i] <- .jcall(res@md, "S", "getColumnName", i)
l$type.id[i] <- ct
l$precision[i] <- .jcall(res@md, "I", "getPrecision", i)
}
as.data.frame(l, row.names=1:cols)
},
valueClass = "data.frame")
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.