Nothing
####################################################################### SQRL ###
# Wrapper about RODBC. On load, SQRL automatically generates a like-named user-
# interface function to each DSN it finds on the system. These functions enable
# immediate interaction with each data source, since channels and communication
# parameters are managed behind the scenes. The general philosophy is to require
# the least possible typing from the user, while allowing the greatest possible
# flexibility in how commands are entered. This approach emphasises the source
# and query over concatenation functions and control parameters. The interfaces
# accept multi-statement SQL scripts, allowing the use of scripts developed in
# other applications without modification or fragmentation. The script parser
# supports query parameterisation via embedded R expressions, the feedback of
# intermediate results, reusable procedures, conditional submission, loops, and
# early returns. Secondary features include the protection of connection handles
# from rm(), automatic recovery from lost connections, the promotion of remote
# ODBC exceptions to local R errors, optional automatic closure of connections
# between queries, and visual indication of which connections are open and of
# where and whether queries or fetches are in progress.
# Mike Lee, South Titirangi, 7 March 2020.
################################################################### CONTENTS ###
# srqlHaus Private. Environment. Stores data-source parameters.
# srqlHelp Private. Environment. Stores interface-help temp files.
# SqrlAll() Private. Broadcasts a command to every SQRL source.
# SqrlCache() Private. Interfaces with srqlHaus (only point of contact).
# SqrlClose() Private. Closes data source connection channels.
# SqrlConfig() Private. Sets SQRL/RODBC parameters from a config file.
# SqrlDefault() Private. Defines and returns default parameter values.
# SqrlDefile() Private. Extracts parameter values from container files.
# SqrlDelegate() Private. Delegates commands to appropriate functions.
# SqrlDSNs() Private. Registers existing DSN data sources with SQRL.
# SqrlEscape() Private. Escapes strings for help-file compatibility.
# SqrlFace() Private. Interfaces with the SQRL:Face environment.
# SqrlHelp() Private. Displays run-time help for interface functions.
# SqrlHelper() Private. Generates run-time help for interface functions.
# SqrlIndicator() Private. Toggles display of open-connection indicators.
# SqrlInterface() Private. Defines and/or deletes data source interfaces.
# SqrlIsOpen() Private. Tests whether or not source channels are open.
# SqrlOff() Private. Closes all channels, detaches and unloads SQRL.
# SqrlOpen() Private. Opens connection channels to data sources.
# SqrlParam() Private. Gets and sets data source SQRL/RODBC parameters.
# SqrlParams() Private. Defines and returns various parameter groupings.
# SqrlParse() Private. Reads SQL (and/or R) statements from a script.
# SqrlPath() Private. Checks if args are the path to an existing file.
# SqrlPing() Private. Sets and submits ping queries to data sources.
# SqrlPL() Private. Detects procedural (PL) blocks within scripts.
# SqrlProc() Private. Checks if a value names a stored procedure.
# SqrlShell() Private. Relays commands from interfaces to delegator.
# SqrlStatement() Private. Assembles SQL statements from listed components.
# SqrlSource() Private. Registers/defines new data sources with SQRL.
# SqrlSources() Private. Look for, and summarise, known data sources.
# SqrlSubmit() Private. Submits SQL, retrieves results, handles errors.
# SqrlSubScript() Private. Relays data between SqrlParse() and SqrlSubmit().
# SqrlTry() Private. Silent error catching, with warning suppression.
# SqrlValue() Private. Wrapper to SqrlParam(). Keeps secrets secret.
# sqrlAll() Public. Wrapper to SqrlAll(). See above.
# sqrlInterface() Public. Wrapper to SqrlInterface(). See above.
# sqrlOff() Public. Wrapper to SqrlOff(). See above.
# sqrlSource() Public. Wrapper to SqrlSource(). See above.
# sqrlSources() Public. Wrapper to SqrlSources(). See above.
# .onLoad() Private. Attaches SQRL:Face and finds sources, on load.
# .onUnload() Private. Detaches the SQRL:Face environment, on unload.
############################################################### ENVIRONMENTS ###
# Environment for caching data source parameters. Not exported. The user will
# not, without some effort, be able to view or modify objects within this.
srqlHaus <- new.env(parent = emptyenv())
# Environment for tracking temp files for the dynamic run-time help system. Not
# exported. The user will not be able to easily view or modify objects within.
srqlHelp <- new.env(parent = emptyenv())
# There will also exist a public environment, attached to the R search path as
# 'SQRL:Face', by the .onLoad() function, when the package is loaded.
########################################################## PRIVATE FUNCTIONS ###
SqrlAll <- function(argsl,
envir = parent.frame())
{
# Applies the same command to each of the (currently defined) SQRL sources.
# Args:
# argsl : A list of arguments, to be passed unaltered to SqrlDelegate().
# envir : An environment, beneath which any embedded R script is evaluated.
# Returns:
# A list (by SQRL source name) of the results of running the argsl
# command(s) on each of the SQRL sources. SQRL source names are unique.
# SQRL Calls:
# SqrlCache(), SqrlShell().
# SQRL Callers:
# SqrlSources(), sqrlAll().
# User:
# Has no direct access, but is able to supply (only) the argsl argument,
# from sqrlAll(). That function ensures argsl is a list. Since argsl is
# otherwise unrestricted, no validity checking is required at this stage.
# Give the command to each data source in turn. Retrieve the results. Fatal
# errors will block sending the command to further sources. Opting not to wrap
# in try(), because stopping may be preferable under many circumstances.
results <- list()
for (datasource in SqrlCache("*"))
{
# Assigning NULL to a list element[[]] removes the element, whereas
# assigning list(NULL) to element[] leaves the element with a NULL value.
results[datasource] <- list(SqrlShell(datasource, envir, argsl))
}
# Return the results (listed by SQRL data source name).
return(results)
}
SqrlCache <- function(datasource = "",
exists = NULL,
create = FALSE,
delete = FALSE)
{
# Checks, creates, lists and gets data source cache environments.
# Args:
# datasource : The name of a data source, or '*' for all known data sources.
# exists : If set to TRUE or FALSE, test if a cache exists or doesn't.
# create : If set to TRUE, create a cache for the data source.
# delete : If set to TRUE, delete an existing data source cache.
# Returns:
# Either an environment handle, a logical (when performing an existence
# check), a character vector (when listing all known data sources), or
# invisible NULL (after removing a data source's cache).
# SQRL Calls:
# SqrlClose(), SqrlInterface(), SqrlParam(), SqrlParams(), srqlHaus.
# SQRL Callers:
# SqrlAll(), SqrlDefault(), SqrlDelegate(), SqrlDSNs(), SqrlOff(),
# SqrlParam(), SqrlSource(), SqrlSources(), sqrlInterface().
# User:
# Has no direct access, but is able to supply (only) the datasource argument
# via SqrlSource(), which verifies existence of that source before passing
# the argument on. Further validity checks are not required.
# Defines the name for data source <datasource>'s cache environment.
cachename <- paste(".", datasource, sep = "!")
# If the exists argument was specified, return whether or not the cache exists
# (whether or not the data source is known to SQRL). Use of exists as an
# argument (variable) does not interfere with base::exists(), the function.
# When exists is TRUE (FALSE), we return TRUE when the cache does (does not)
# exist (i.e., the source is (is not) known).
if (!is.null(exists))
{
ex <- exists(cachename, srqlHaus, mode = "environment", inherits = FALSE)
return(ex == exists)
}
# If the delete flag was set, close any open connection to the source, delete
# its interface, delete its cache (this completes deregistration from SQRL),
# and return invisible NULL. The garbage collector ought to take care of any
# parameters within the cache.
if (delete)
{
if (exists(cachename, srqlHaus, mode = "environment", inherits = FALSE))
{
SqrlClose(datasource)
SqrlInterface(datasource, "remove")
SqrlParam(datasource, "reset", SqrlParams("secret"))
SqrlParam(datasource, "reset", SqrlParams("semi-secret"))
remove(list = cachename, pos = srqlHaus, inherits = FALSE)
}
return(invisible(NULL))
}
# If datasource is specified as '*', return a character vector of all data
# source names for which a SQRL cache exists.
if (datasource == "*")
{
cachenames <- objects(srqlHaus, all.names = TRUE, pattern = "^\\.!")
if (length(cachenames) < 1L)
{
return(character(0L))
}
is.cache <- sapply(as.list(cachenames),
function(x) exists(x, srqlHaus, mode = "environment", inherits = FALSE))
cachenames <- cachenames[is.cache]
return(substring(cachenames, nchar(".!") + 1L))
}
# If the create argument was specified as TRUE, create a new cache for the
# specified data source. Abort if the cache (or like-named object) exists.
if (create)
{
if (exists(cachename, srqlHaus, inherits = FALSE))
{
stop("Source cache already exists.")
}
cache <- new.env(parent = emptyenv())
assign(cachename, cache, srqlHaus)
SqrlParam(datasource, "name", datasource)
return(cache)
}
# Otherwise, abort if the cache does not exist.
if (!exists(cachename, srqlHaus, mode = "environment", inherits = FALSE))
{
stop("Cache does not exist.")
}
# The cache exists; return a handle to it.
return(get(cachename, srqlHaus, mode = "environment", inherits = FALSE))
}
SqrlClose <- function(datasource = "")
{
# Closes the channel to the specified data source.
# Args:
# datasource : The name of a data source whose channel is to be closed.
# Returns:
# Invisible NULL, after closing the channel and removing the handle.
# SQRL Calls:
# SqrlParam(), SqrlTry().
# RODBC Calls:
# odbcClose().
# SQRL Callers:
# SqrlCache(), SqrlDelegate(), SqrlParse(), SqrlIsOpen(), SqrlOff().
# User:
# Has no direct access, unable to pass argument indirectly. No argument
# validity checks are required.
# Return invisible NULL if the channel is already closed.
if (is.null(SqrlParam(datasource, "channel")))
{
return(invisible(NULL))
}
# Attempt to close the channel (which may, or may not, actually be open).
SqrlTry(RODBC::odbcClose(SqrlParam(datasource, "channel")), warn = FALSE)
# Whatever the situation, nullify the connection handle immediately. If the
# channel somehow survived the close attempt, this makes it unusable. The
# SqrlParam() function will remove any visible connection indicators.
SqrlParam(datasource, "channel", NULL)
# Return invisible NULL.
return(invisible(NULL))
}
SqrlConfig <- function(datasource = "",
config = "")
{
# Assigns SQRL/RODBC parameter values, for a data source, from a file or list.
# Args:
# datasource : The name of a known (to SQRL) data source.
# config : The path of a configuration file, or a list of named values.
# Returns:
# The imported configuration, as an invisible list of (name, value) pairs.
# When no configuration file is specified, this function acts as a getter,
# and returns a list of all SQRL/RODBC parameters and their current values.
# SQRL Calls:
# SqrlDefile(), SqrlParse(), SqrlInterface(), SqrlParam(), SqrlParams(),
# SqrlPath(), SqrlValue().
# SQRL Callers:
# SqrlDelegate(), SqrlHelp(), SqrlSource().
# User:
# Has no direct access, but is able to pass the config argument (only) via
# SqrlDelegate(). That function vets the value, and ensures config is either
# a list (of named values) or a character string. In the latter case, the
# string ought to be the path of an actual (existing, readable) config file,
# but this is not guaranteed (and so is checked here).
# Parameter values will be copied into this list, before setting or returning.
conf <- list()
# If no config was specified, return the data source's configuration as a list
# of named SQRL/RODBC parameter values (with any secrets obliterated).
if (identical(class(config), class(character()))
&& (nchar(config) < 1L))
{
params <- SqrlParams("all")
params <- params[!(params %in% SqrlParams("omit-from-config"))]
for (param in params)
{
conf[param] <- list(SqrlValue(datasource, param))
}
return(conf)
}
# If a list of named elements was supplied, extract parameter values from it.
if (identical(class(config), class(list()))
&& !is.null(names(config))
&& all(grepl("[[:graph:]]", names(config))))
{
# If any name should be replicated, the final occurrence is taken
for (i in seq_along(config))
{
conf[trimws(names(config)[i])] <- list(config[[i]])
}
# Otherwise, a file path should have been supplied as a character string.
} else
{
# Abort if that file does not exist.
filepath <- SqrlPath(config)
if (is.null(filepath))
{
stop("File not found.")
}
# Slurp the file, and parse it as an R script.
ftext <- readLines(filepath, warn = FALSE)
flang <- parse(text = ftext, keep.source = FALSE)
# An environment within which to evaluate the script. Inherits functions
# from base, but not variables from the global environment.
cfenv <- new.env(parent = baseenv())
# Take each expression from the script, wrap it in a list, and evaluate.
# Where this results in a named list, interpret the expression as a request
# to set a value for the SQRL/RODBC parameter of that name, and add that
# name-value pair to the config list. When a name appears within the script
# multiple times, only the last value is used.
for (expr in flang)
{
etext <- paste0(deparse(expr), collapse = "\n")
lexp <- parse(text = paste0("list", "(", etext, ")"), keep.source = FALSE)
lval <- eval(lexp, cfenv)
if ((length(lval) == 1L)
&& !is.null(names(lval)))
{
conf[names(lval)] <- lval
}
}
}
# Ignore any request to set the channel.
conf <- conf[names(conf) != "channel"]
# If 'interface' is among the parameters to be set, then set it first (since
# it's the one most likely to fail). If this does fail, then no further
# parameter values will be set (SqrlInterface() will throw an exception).
if ("interface" %in% names(conf))
{
value <- SqrlDefile("interface", conf[["interface"]])
SqrlInterface(datasource, value)
conf["interface"] <- list(SqrlValue(datasource, "interface"))
}
# Defining the library is another special case.
if ("library" %in% names(conf))
{
value <- SqrlDefile("library", conf[["library"]])
if (is.null(value))
{
SqrlParam(datasource, "reset", "library")
} else
{
SqrlParse(datasource, value, libmode = TRUE)
}
conf["library"] <- list(SqrlValue(datasource, "library"))
}
# Assign all other values found (besides those of 'interface' and 'library').
# The driver parameter is set last, to override any default driver set as a
# side effect in the course of setting dsn (should that have been set). By
# the above construction, list-member (parameter) names are unique.
params <- names(conf)
params <- params[!(params %in% c("interface", "library"))]
params <- c(params[params != "driver"], params[params == "driver"])
for (parameter in params)
{
value <- SqrlDefile(parameter, conf[[parameter]])
conf[parameter] <- list(SqrlValue(datasource, parameter, value))
}
# Return the (sorted, secrets-obscured) configuration, invisibly.
return(invisible(conf[order(names(conf))]))
}
SqrlDefault <- function(datasource = "",
parameter = "")
{
# Defines and returns default parameter values.
# Args:
# datasource : The name of a known (to SQRL) data source.
# parameter : The name of a single specific parameter.
# Returns:
# The default value of the named parameter for the named data source.
# SQRL Calls:
# SqrlCache(), SqrlParam().
# SQRL Callers:
# SqrlParam().
# User:
# Has no direct access, but is able to supply (only) parameter via
# SqrlDelegate(), which does the vetting. No further checks are required.
# Obtain a handle to the data source's SQRL cache.
cacheenvir <- SqrlCache(datasource)
# Return the default value of the specified parameter.
return(switch(parameter,
# Parameters for RODBC::odbcConnect() and/or RODBC::odbcDriverConnect().
"dsn" = "",
"uid" = as.character(Sys.info()["user"]),
"pwd" = "",
"connection" = "",
"case" = "nochange",
"believeNRows" = !grepl("SQLite", SqrlParam(datasource, "driver"),
ignore.case = TRUE),
"colQuote" = if (grepl("MySQL", SqrlParam(datasource, "driver"),
ignore.case = TRUE)) {"`"} else {"\""},
"tabQuote" = SqrlParam(datasource, "colQuote"),
"interpretDot" = TRUE,
"DBMSencoding" = "",
"rows_at_time" = 100L,
"readOnlyOptimize" = FALSE,
# Parameters for RODBC::sqlQuery().
# Also uses believeNRows and rows_at_time, as above.
"channel" = NULL,
"errors" = TRUE,
"as.is" = FALSE,
"max" = 0L,
"buffsize" = 1000L,
"nullstring" = NA_character_,
"na.strings" = "NA",
"dec" = as.character(getOption("dec")),
"stringsAsFactors" = FALSE,
# Parameters for SQRL.
"*" = objects(cacheenvir, all.names = TRUE),
"aCollapse" = ",",
"autoclose" = FALSE,
"driver" = "",
"interface" = NULL,
"lCollapse" = "",
"library" = character(),
"libstack" = list(),
"name" = datasource,
"ping" = NULL,
"prompt" = substr(datasource, 1L, 1L),
"pstack" = list(cacheenvir),
"result" = NULL,
"retry" = TRUE,
"scdo" = TRUE,
"verbose" = FALSE,
"visible" = FALSE,
"wintitle" = paste0("(", datasource, ")"),
# No other default parameter values are defined (abort and notify).
stop("Unknown parameter.")))
}
SqrlDefile <- function(parameter = "",
value = "",
evaluate = FALSE)
{
# Recursively substitutes file paths with contained parameter values.
# Args:
# parameter : A single parameter name.
# value : Either a final value or a file path (or components thereof).
# evaluate : Whether or not to attempt to evaluate value as an expression.
# Returns:
# A value for the parameter, either as supplied or as found within the
# supplied file (alternative).
# SQRL Calls:
# SqrlDefile() (self), SqrlParams(), SqrlPath(), SqrlTry().
# SQRL Callers:
# SqrlConfig(), SqrlDefile() (self), SqrlDelegate(), SqrlParse(),
# SqrlSource(), sqrlInterface().
# User:
# Has no direct access, but is able to supply (only) parameter and value via
# SqrlParam() from SqrlDelegate() and/or SqrlConfig(). The parameter is
# guaranteed to be a string, and no further checks are required. The value
# may turn out to be unsuitable, but that is left for SqrlParam() to decide.
# If the value is to represent a file path, it must be a non-empty, non-blank,
# character vector (or list of character vectors). If the value is anything
# besides these, return it unmodified. The reason for returning both blank and
# empty character vectors here (before evaluation) is to take them as literal
# values (rather than as R expressions; they would evaluate to NULL).
if (!((identical(class(value), class(character()))
&& (length(value) > 0L)
&& any(nzchar(trimws(value))))
|| (identical(class(value), class(list()))
&& (length(value) > 0L)
&& all(rapply(rapply(value, class, how = "list"),
identical, classes = "ANY", deflt = NULL,
how = "unlist", class(character())))
&& any(nzchar(rapply(value, trimws))))))
{
return(value)
}
# See if the value corresponds to the path of a readable file. If so, this is
# that path. If not, this is NULL.
path <- SqrlPath(value)
# If the value is not the path of a readable file, then return either the
# unmodified value, or the (if possible and so requested) evaluated value.
if (is.null(path))
{
# The value is not a path. If it is not to be evaluated, return it as is.
if (!evaluate)
{
return(value)
}
# Otherwise, if the value doesn't evaluate, return it unmodified.
evaluated <- SqrlTry(eval(parse(text = value, keep.source = FALSE),
new.env(parent = baseenv())))
if (evaluated$error)
{
return(value)
}
# If the value evaluated to something odd (for example, 'ls' evaluates to a
# function), return it unmodified.
eclass <- class(evaluated$value)
if (!(identical(eclass, class(NULL))
|| identical(eclass, class(logical()))
|| identical(eclass, class(character()))
|| identical(eclass, class(numeric()))
|| identical(eclass, class(integer()))))
{
return(value)
}
# The value could be evaluated; return the evaluated value.
return(evaluated$value)
}
# Otherwise, the value specifies the path of a readable file. If the parameter
# is path-valued, then return that path.
if (parameter %in% SqrlParams("path-valued"))
{
return(path)
}
# Slurp the file.
ftxt <- readLines(path, warn = FALSE)
# If the file can't be parsed and evaluated, or if no 'parameter = value'
# assignment is found, assume the file text is a literal parameter value.
value <- trimws(ftxt)
value <- value[nzchar(value)]
# Attempt to parse the file as an R script.
fexp <- SqrlTry(parse(text = ftxt, keep.source = FALSE))
# If the file parsed, attempt to evaluate its R expressions (within an
# environment that inherits functions from base, but not variables from the
# global environment, or the evaluation environment of any parent file).
if (!fexp$error)
{
fenv <- new.env(parent = baseenv())
for (expr in fexp$value)
{
etxt <- paste0(deparse(expr), collapse = "\n")
lexp <- parse(text = paste0("list", "(", etxt, ")"), keep.source = FALSE)
lval <- SqrlTry(eval(lexp, fenv))
# Should an error occur, revert to the default value (literal script).
if (lval$error)
{
value <- trimws(ftxt)
value <- value[nzchar(value)]
break
}
# If the expression was of the form 'parameter = value', take that value.
if (identical(names(lval$value), parameter))
{
value <- lval$value[[1L]]
}
}
}
# Put the extracted value back into this function, in case it is another
# file path (recursive call, infinite loops are possible). Given that the
# current value is a file path, we evaluate the next value (since it is to be
# read from file as text), whether or not the current value was evaluated.
return(SqrlDefile(parameter, value))
}
SqrlDelegate <- function(datasource = "",
envir = parent.frame(),
args.list)
{
# Interpret the command, and forward to the appropriate handler.
# Args:
# datasource : The name of a known data source.
# envir : An R environment, from which variables are inherited.
# args.list : A list of arguments, to be interpreted and actioned.
# Returns:
# The result of the command (normally a data frame, sometimes a string).
# SQRL Calls:
# SqrlCache(), SqrlClose(), SqrlConfig(), SqrlDefile(), SqrlParse(),
# SqrlHelp(), SqrlIndicator(), SqrlInterface(), SqrlIsOpen(), SqrlOpen(),
# SqrlParam(), SqrlParams(), SqrlPath(), SqrlProc(), SqrlSources(),
# SqrlStatement(), SqrlSubmit(), SqrlTry(), SqrlValue().
# RODBC Calls:
# sqlColumns(), sqlTables(), sqlTypeInfo().
# SQRL Callers:
# SqrlParse() (via sqrl()), SqrlShell().
# User:
# User has no direct access, but is able to supply (only) the args.list
# argument from sqrlAll() and/or any data source interface (including
# intra-script sqrl() functions). Since args.list is unrestricted (it could
# be SQL), no argument validity checking is performed.
# Count the number of supplied arguments.
args.count <- length(args.list)
# If no command was given, open a channel to the data source. If no channel
# exists, a new channel is opened. If a channel exists, but wasn't open after
# all (after besure = TRUE pings the data source to check), we replace the
# dead channel with a new one. If a channel exists and is open, we do nothing
# else. Returns the configuration invisibly, enabling interface()$parameter.
if (args.count == 0L)
{
isopen <- SqrlIsOpen(datasource, besure = TRUE)
if (!isopen)
{
SqrlOpen(datasource)
isopen <- SqrlIsOpen(datasource)
}
config <- SqrlConfig(datasource)
config[["source"]] <- SqrlValue(datasource, "source")
config[["isopen"]] <- isopen
return(invisible(config[order(names(config))]))
}
# Obtain the stated names of the supplied arguments. This may be NULL (no
# names at all), or a character vector (with "" for any unnamed elements).
# Names need not be unique. These names cannot be NAs.
args.names <- names(args.list)
# Expand lists of named arguments.
if (is.null(args.names)
|| any(nchar(args.names) == 0L))
{
# Obtain the indices of any unnamed arguments.
i <- seq(args.count)
if (!is.null(args.names))
{
i <- i[nchar(args.names) == 0L]
}
# Unpack unnamed lists of (syntactically correctly) named members, except
# where that would place a named argument before an unnamed argument.
j <- length(i)
while ((j > 0L)
&& identical(class(args.list[[i[j]]]), class(list()))
&& (length(args.list[[i[j]]]) > 0L)
&& !is.null(names(args.list[[i[j]]]))
&& !any(is.na(names(args.list[[i[j]]])))
&& (all(names(args.list[[i[j]]]) ==
make.names(names(args.list[[i[j]]])))))
{
k <- seq_along(args.list)
args.list <- c(args.list[k[k < i[j]]],
args.list[[i[j]]],
args.list[k[k > i[j]]])
j <- j - 1L
}
# Update the number of (unpacked) arguments, and their names.
args.count <- length(args.list)
args.names <- names(args.list)
}
# When all arguments are named, treat them as either parameterised queries to
# be submitted, or as SQRL parameter values to be (re)set.
if (!is.null(args.names)
&& all(nchar(args.names) > 0L))
{
# When there is only one argument, and it is named 'verbatim', expect a
# single character string to be submitted directly (unmodified, without
# going through the SQRL concatenator, parser, or R-substitution process).
if ((length(args.names) == 1L)
&& (args.names == "verbatim"))
{
if ((length(args.list) != 1L)
|| (class(args.list[[1L]]) != class(character()))
|| (length(args.list[[1L]]) != 1L))
{
stop("Verbatim query not a single character string.")
}
return(SqrlSubmit(datasource, args.list[[1L]]))
}
# Prohibit the use of more than one of the names 'file', 'proc', and
# 'query', since it is unclear which refers to the script and which is a
# (are) parameter(s) to the that.
if (sum(c("file", "proc", "query") %in% args.names) > 1L)
{
stop("The file, proc, and query arguments are mutually exclusive.")
}
# If one of the names in 'proc', then submit the named procedure, and treat
# any other (named) arguments as parameters to that procedure. It is this
# function's responsibility to verify the existence of the procedure. When
# multiple arguments are named 'proc', the first of them is taken as the
# procedure while the others are treated as arguments to that procedure.
if ("proc" %in% args.names)
{
index <- which(args.names == "proc")[1L]
script <- SqrlProc(datasource, args.list[[index]])
if (is.null(script))
{
stop("Procedure not defined.")
}
params <- args.list[seq_along(args.list) != index]
result <- withVisible(
SqrlParse(datasource, script, envir, params, literal = TRUE))
SqrlParam(datasource, "result", result$value, override = TRUE)
if (!result$visible)
{
return(invisible(result$value))
}
return(result$value)
}
# If one of the names in 'file', then submit a query from the file, and
# treat any other (named) arguments as parameters to that query. It is this
# function's responsibility to verify the existence and readability of the
# file before passing it to SqrlParse(). When multiple arguments are named
# 'file', the first of them is taken as the query file while the others are
# treated as arguments to that query.
if ("file" %in% args.names)
{
index <- which(args.names == "file")[1L]
file.path <- SqrlPath(args.list[[index]])
if (is.null(file.path))
{
stop("File not found.")
}
params <- args.list[seq_along(args.list) != index]
result <- withVisible(SqrlParse(datasource, file.path, envir, params))
SqrlParam(datasource, "result", result$value, override = TRUE)
if (!result$visible)
{
return(invisible(result$value))
}
return(result$value)
}
# If one of the names is 'query', then pass the query to SqrlParse() (as a
# script, not as a file name), with any other arguments as named parameters.
# When multiple arguments are named 'query', the first of them is taken as
# the query, while the others are treated as parameters of that query.
if ("query" %in% args.names)
{
index <- which(args.names == "query")[1L]
script <- SqrlTry(SqrlStatement(datasource, list(args.list[[index]])))
if (script$error)
{
stop(script$value)
}
script <- script$value
params <- args.list[seq_along(args.list) != index]
result <- withVisible(SqrlParse(datasource, script, envir, params, TRUE))
SqrlParam(datasource, "result", result$value, override = TRUE)
if (!result$visible)
{
return(invisible(result$value))
}
return(result$value)
}
# Otherwise, interpret each name as that of a parameter, and assign each
# value accordingly. The name 'reset' is a special case (reset specified
# parameters to their default values). The driver parameter is set last,
# to override any default driver that may have been set as a side effect
# in the course of setting the dsn parameter. Names need not be unique.
if (any(args.names %in% SqrlParams("read-only")))
{
stop("Parameter is read-only.")
}
result <- list()
indices <- seq_along(args.list)
drivers <- args.names == "driver"
indices <- c(indices[!drivers], indices[drivers])
for (index in indices)
{
param <- args.names[index]
if (param == "config")
{
# SqrlConfig() returns a list with unique names.
conf <- SqrlConfig(datasource, args.list[[index]])
for (cpar in names(conf))
{
result[cpar] <- list(conf[[cpar]])
}
} else
{
if (param == "interface")
{
value <- SqrlDefile(param, args.list[[index]])
result[param] <- list(SqrlInterface(datasource, value))
} else if (param == "library")
{
if (is.null(args.list[[index]]))
{
SqrlParam(datasource, "reset", param)
} else
{
path <- SqrlPath(args.list[[index]])
if (is.null(path))
{
libdef <- SqrlTry(
SqrlStatement(datasource, list(args.list[[index]])))
if (libdef$error)
{
stop(libdef$value)
}
SqrlParse(datasource, libdef$value, envir,
libmode = TRUE, literal = TRUE)
} else
{
SqrlParse(datasource, path, envir,
libmode = TRUE, literal = FALSE)
}
}
result[param] <- list(SqrlValue(datasource, param))
} else if (param == "reset")
{
# SqrlValue() returns a list of default values with unique names.
values <- SqrlValue(datasource, param, args.list[[index]])
result[names(values)] <- values
} else
{
value <- SqrlDefile(param, args.list[[index]])
result[param] <- list(SqrlValue(datasource, param, value))
}
}
}
if (!is.null(names(result)))
{
result <- result[order(names(result))]
}
return(invisible(result))
}
# When both named and unnamed arguments exist, and all named arguments trail
# all unnamed arguments, then interpret the unnamed arguments as defining a
# script (one way or another), and the named arguments as its parameters.
args.kindex <- which(nchar(args.names) > 0L)[1L]
if (!is.null(args.names)
&& all(nchar(args.names[args.kindex:args.count]) > 0L))
{
unnamed <- args.list[seq((args.kindex - 1L))]
params <- args.list[seq(args.kindex, args.count)]
# If the unnamed arguments name a stored procedure, use that.
if (!is.null(script <- SqrlProc(datasource, unnamed)))
{
literal <- TRUE
# If, instead, the unnamed arguments define a file path, read and use that.
} else if (!is.null(script <- SqrlPath(unnamed)))
{
literal <- FALSE
# If, instead, the single unnamed argument is 'config', set and return that.
} else if ((args.kindex == 2L)
&& identical(trimws(unnamed), "config"))
{
return(SqrlConfig(datasource, params))
# Otherwise, treat the unnamed arguments as a literal script.
} else
{
script <- SqrlTry(SqrlStatement(datasource, unnamed))
if (script$error)
{
stop(script$value)
}
script <- script$value
literal <- TRUE
}
# Submit the script and its parameters. Retrieve and return the result.
result <- withVisible(SqrlParse(datasource, script, envir, params, literal))
SqrlParam(datasource, "result", result$value, override = TRUE)
if (!result$visible)
{
return(invisible(result$value))
}
return(result$value)
}
# When even one unnamed argument trails at least one named argument, abort.
if (!is.null(args.names)
&& any(nchar(args.names) > 0L))
{
stop("All unnamed arguments must precede all named arguments.")
}
# Otherwise (when none of the arguments are named), attempt to interpret them
# as a list of subcommands, or as file-path components, or as a procedure
# name, or as specific SQRL commands (consisting of a command word, or a
# parameter name, and, optionally, a value to go with that).
# If the entire command names a procedure, submit that stored procedure.
procedure <- SqrlProc(datasource, args.list)
if (!is.null(procedure))
{
result <- withVisible(
SqrlParse(datasource, procedure, envir, literal = TRUE))
SqrlParam(datasource, "result", result$value, override = TRUE)
if (!result$visible)
{
return(invisible(result$value))
}
return(result$value)
}
# If the entire command specifies a path, try sourcing SQL from that file.
file.path <- SqrlPath(args.list)
if (!is.null(file.path))
{
result <- withVisible(SqrlParse(datasource, file.path, envir))
SqrlParam(datasource, "result", result$value, override = TRUE)
if (!result$visible)
{
return(invisible(result$value))
}
return(result$value)
}
# When the first argument is not a single character string, interpret all the
# arguments as components of a query, and submit that. This is performed here,
# because the grepl() logic below gets upset when args.list[[1L]] is a vector.
if (!identical(class(args.list[[1L]]), class(character()))
|| (length(args.list[[1L]]) != 1L))
{
statement <- SqrlTry(SqrlStatement(datasource, args.list))
if (statement$error)
{
stop(statement$value)
}
result <- withVisible(
SqrlParse(datasource, statement$value, envir, literal = TRUE))
SqrlParam(datasource, "result", result$value, override = TRUE)
if (!result$visible)
{
return(invisible(result$value))
}
return(result$value)
}
# Extract the first word from the first supplied argument.
first.word <- sub("^[^[:graph:]]*([[:graph:]]+).*$", "\\1",
args.list[[1L]])[1L]
# If the first word looks like standard SQL, submit the unaltered command.
if (tolower(first.word) %in% SqrlParams("sql-keywords"))
{
statement <- SqrlTry(SqrlStatement(datasource, args.list))
if (statement$error)
{
stop(statement$value)
}
result <- withVisible(
SqrlParse(datasource, statement$value, envir, literal = TRUE))
SqrlParam(datasource, "result", result$value, override = TRUE)
if (!result$visible)
{
return(invisible(result$value))
}
return(result$value)
}
# If the first supplied argument contains more than one word, the other words
# consist of everything except the first word (pasted together).
if (grepl("[[:graph:]]+[^[:graph:]]+[[:graph:]]+", args.list[[1L]]))
{
other.words <- trimws(sub(first.word, "", paste(args.list, collapse = ""),
fixed = TRUE))
only.word <- ""
# Otherwise (the first supplied argument is a single word), if only one
# argument was supplied, then the (that) first word is the only word.
} else if (args.count == 1L)
{
only.word <- first.word
other.words <- ""
# Otherwise, if precisely two arguments were supplied, then the other words
# are the second argument verbatim (could be any object, not just a string).
} else if (args.count == 2L)
{
only.word <- ""
other.words <- args.list[[2L]]
# Otherwise, the other words consist of all the supplied arguments besides the
# first (paste these together).
} else
{
only.word <- ""
other.words <- paste(args.list[-1L], collapse = "")
}
# If the only word is 'close', close the data source channel.
if ("close" == only.word)
{
return(SqrlClose(datasource))
}
# If the first word is 'columns', call RODBC::sqlColumns() on the remainder.
if ("columns" == first.word)
{
if (first.word == only.word)
{
stop("Table not specified.")
}
SqrlOpen(datasource)
SqrlIndicator(datasource, "query")
result <- SqrlTry(RODBC::sqlColumns(
channel = SqrlParam(datasource, "channel"),
sqtable = other.words,
errors = SqrlParam(datasource, "errors"),
as.is = TRUE))
SqrlIndicator(datasource, "done")
if (result$error
&& SqrlParam(datasource, "errors"))
{
stop(result$value)
}
SqrlParam(datasource, "result", result$value, override = TRUE)
return(result$value)
}
# If the first word is 'config', get or set the configuration.
if ("config" == first.word)
{
return(SqrlConfig(datasource, other.words))
}
# If the first word is 'help', or some multiple of '?', and the other words
# are 'text', 'html', or absent, then provide help. We test for those other
# words here, because (for example) 'help volatile table' is valid Teradata,
# and "help 'contents'" is valid MySQL. Neither allows just 'help' alone.
if ((("help" == first.word)
|| grepl("^[?]+$", first.word))
&& ((first.word == only.word)
|| identical(tolower(other.words), "html")
|| identical(tolower(other.words), "text")))
{
return(SqrlHelp(datasource, other.words))
}
# If the only word is 'interface', return the interface function name.
if ("interface" == only.word)
{
return(SqrlValue(datasource, only.word))
}
# If the first word is 'interface', change the interface function.
if ("interface" == first.word)
{
value <- SqrlDefile(first.word, other.words, evaluate = TRUE)
return(SqrlInterface(datasource, value))
}
# If the only word is 'isopen' (or if words one and two are 'is open'), return
# the channel's open status (TRUE for open, FALSE otherwise). This calls with
# besure = TRUE, to ping the source and make certain of the openness status.
if (("isopen" == only.word)
|| (("is" == first.word)
&& ("open" == other.words)))
{
return(SqrlIsOpen(datasource, besure = TRUE))
}
# If the first word is 'library', treat the other words as a library file or
# literal script (to be imported). If the other word is a literal NULL, then
# this is an alias for reset. The getter case, wherein 'library' is the only
# word, is handled below (with the other SQRL parameters).
if (("library" == first.word)
&& (first.word != only.word))
{
if (is.null(other.words))
{
SqrlParam(datasource, "reset", first.word)
} else
{
SqrlParse(datasource, other.words, envir, libmode = TRUE,
literal = is.null(SqrlPath(other.words)))
}
return(invisible(SqrlValue(datasource, "library")))
}
# If the only word is 'Library', return the full library definition.
if ("Library" == only.word)
{
return(SqrlParam(datasource, "library"))
}
# If the only word is 'open', open a channel to the specified data source.
if ("open" == only.word)
{
return(SqrlOpen(datasource))
}
# If the first word is 'primarykeys', then call RODBC::sqlPrimaryKeys() on the
# remaining words (which ought to be table or database.table).
if ("primarykeys" == first.word)
{
if (first.word == only.word)
{
stop("Table not specified.")
}
SqrlOpen(datasource)
SqrlIndicator(datasource, "query")
result <- SqrlTry(RODBC::sqlPrimaryKeys(
channel = SqrlParam(datasource, "channel"),
sqtable = other.words,
errors = SqrlParam(datasource, "errors"),
as.is = TRUE))
SqrlIndicator(datasource, "done")
if (result$error
&& SqrlParam(datasource, "errors"))
{
stop(result$value)
}
SqrlParam(datasource, "result", result$value, override = TRUE)
return(result$value)
}
# If the only word is 'remove', then deregister the source from SQRL.
if ("remove" == only.word)
{
return(SqrlCache(datasource, delete = TRUE))
}
# If the first word is 'reset', then reset the stated parameters.
if ("reset" == first.word)
{
return(invisible(SqrlValue(datasource, first.word, other.words)))
}
# If the only word is 'settings', return that subset of the configuration.
if ("settings" == only.word)
{
s <- SqrlConfig(datasource)
return(s[!(names(s) %in% SqrlParams("omit-from-settings"))])
}
# If the only word is 'source', return the (placeholder substituted, secrets
# obliterated) source definition (either a DSN or a connection string).
if ("source" == only.word)
{
return(SqrlValue(datasource, "source"))
}
# If the command is 'sources', return the data source summary table.
if ("sources" == only.word)
{
return(SqrlSources())
}
# If the first word is 'tables', call RODBC::sqlTables() on the data source.
if ("tables" == first.word)
{
schema <- NULL
if ("tables" != only.word)
{
schema <- other.words
}
SqrlOpen(datasource)
SqrlIndicator(datasource, "query")
result <- SqrlTry(RODBC::sqlTables(
channel = SqrlParam(datasource, "channel"),
errors = SqrlParam(datasource, "errors"),
as.is = TRUE,
schema = schema))
SqrlIndicator(datasource, "done")
if (result$error
&& SqrlParam(datasource, "errors"))
{
stop(result$value)
}
SqrlParam(datasource, "result", result$value, override = TRUE)
return(result$value)
}
# If the first word is 'typeinfo', call RODBC::sqlTypeInfo() on the others.
if ("typeinfo" == first.word)
{
SqrlOpen(datasource)
type <- if (first.word == only.word) {"all"} else {other.words}
SqrlIndicator(datasource, "query")
info <- SqrlTry(RODBC::sqlTypeInfo(
channel = SqrlParam(datasource, "channel"),
type = type,
errors = SqrlParam(datasource, "errors"),
as.is = TRUE))
SqrlIndicator(datasource, "done")
if (info$error
&& SqrlParam(datasource, "errors"))
{
stop(info$value)
}
SqrlParam(datasource, "result", info$value, override = TRUE)
return(info$value)
}
# When the first word is an SQRL/RODBC parameter, get or set that parameter.
if (first.word %in% SqrlParams("all"))
{
# When getting, return the parameter's value (except for secrets, such as
# passwords, which are returned obliterated), visibly.
if (first.word == only.word)
{
return(SqrlValue(datasource, first.word))
}
# Allow getting, but not setting, of the channel parameter from here.
if (first.word %in% SqrlParams("read-only"))
{
stop("Parameter is read-only.")
}
# Set the parameter's value to the supplied other words, then return the
# (secrets-obscured) value, invisibly.
value <- SqrlDefile(first.word, other.words, evaluate = TRUE)
return(invisible(SqrlValue(datasource, first.word, value)))
}
# Otherwise, submit the original unaltered command, via the parser.
statement <- SqrlTry(SqrlStatement(datasource, args.list))
if (statement$error)
{
stop(statement$value)
}
result <- withVisible(
SqrlParse(datasource, statement$value, envir, literal = TRUE))
SqrlParam(datasource, "result", result$value, override = TRUE)
if (!result$visible)
{
return(invisible(result$value))
}
return(result$value)
}
SqrlDSNs <- function(import = "all")
{
# Import data source names (DSNs), and create interfaces for them.
# Args:
# import : The RODBC::odbcDataSources() type; 'all', 'user', or 'system'.
# Returns:
# Invisible NULL, after registering DSNs with SQRL.
# SQRL Calls:
# SqrlCache(), SqrlInterface(), SqrlParam(), SqrlParams().
# RODBC Calls:
# odbcDataSources().
# SQRL Callers:
# SqrlSources(), .onLoad().
# User:
# Has no direct access. Is able to supply the argument from sqrlSources(),
# via SqrlSources(), but it is vetted there and no further validity checks
# are required.
# Import a list (named character vector) of registered data sources (DSNs).
sources <- RODBC::odbcDataSources(type = import)
# The list may contain empty names when unixODBC is incorrectly configured.
# Such names cause SqrlParam(datasource, "driver", sources[datasource])
# (below) to throw an error (sources[""] is NA_character_). This prevents SQRL
# from loading, and that prevents its installation. Removing such elements
# re-enables both. However, the incorrect configuration will still prevent
# SQRL (and RODBC) from connecting to any data source.
sources <- sources[nzchar(names(sources))]
# Filter out Microsoft Access, dBASE, and Excel sources.
unwanted <- paste(SqrlParams("unwanted-sources"), collapse = "|")
sources <- sources[!grepl(unwanted, sources, ignore.case = TRUE)]
# If any of the sources was previously unknown (has no associated cache), then
# create a new cache for it. Store some valuables in the cache, then attempt
# to generate an interface for the source (failure to do so is non-fatal).
# A user-defined source will prevent importing a DSN of the same name. Source
# names might not be unique (multiple same-named DSNs may appear within a
# unixODBC .odbc.ini file), in which case only the first instance is imported
# (and this is also what unixODBC uses when a reference to that DSN is made).
for (datasource in names(sources))
{
if (SqrlCache(datasource, exists = FALSE))
{
SqrlCache(datasource, create = TRUE)
SqrlParam(datasource, "dsn", datasource)
SqrlParam(datasource, "driver", sources[datasource])
SqrlInterface(datasource, datasource, vital = FALSE)
}
}
# Return invisible NULL.
return(invisible(NULL))
}
SqrlEscape <- function(value = "",
plain = FALSE)
{
# Formats parameter values for inclusion in help files.
# Args:
# value : Either a list (source configuration) or a single character string.
# plain : If TRUE, do not escape % characters (R documentation comments).
# Returns:
# The input values, converted to strings and (by default) with %s escaped.
# SQRL Calls:
# None.
# SQRL Callers:
# SqrlHelp().
# User:
# Has no direct access, but is able to control the supplied values through
# parameter settings (interface name, ping query, and so on). These are
# converted to strings and escaped. No further checking is required.
# Deparse and escape the entire configuration parameter-value list.
# Any RODBC channel is reduced to its integer label.
# Any library is truncated to its first element (plus an ellipsis).
if (identical(class(value), class(list())))
{
if (!is.null(value[["channel"]]))
{
value[["channel"]] <- as.numeric(value[["channel"]])
}
if ("library" %in% names(value))
{
if (!is.null(value[["library"]])
&& (length(value[["library"]]) > 1L))
{
value[["library"]] <- paste0(deparse(value[["library"]][1L]), ", ...")
} else
{
value[["library"]] <- deparse(value[["library"]])
}
if (!plain)
{
value[["library"]] <- gsub("%", "\\\\%", value[["library"]])
}
}
for (name in names(value)[names(value) != "library"])
{
value[[name]] <- deparse(value[[name]])
if (!plain)
{
value[[name]] <- gsub("%", "\\\\%", value[[name]])
}
}
return(value)
}
# The value is a single character-string.
# For R documentation (.Rd) output, return it with any %s escaped.
if (!plain)
{
return(gsub("%", "\\\\%", value))
}
# For plain-text output, return the string verbatim.
return(value)
}
SqrlFace <- function(interface = "",
set = NULL,
exists = NULL,
clashes = NULL,
delete = FALSE)
{
# Checks, sets, gets, and removes data source user-interface functions.
# Args:
# interface : The name (a string) of a SQRL interface function, or NULL.
# set : Is supplied, this definition is assigned to the interface.
# exists : If TRUE or FALSE, test whether or not the interface exists.
# clashes : If Boolean, test for an object name conflict with interface.
# delete : If TRUE, delete the interface.
# prime : If TRUE, create and attach the interface environment.
# Returns:
# Either the interface (function) definition, a logical existence or
# name-conflict indicator, or invisible NULL (when deleting).
# SQRL Calls:
# SQRL:Face.
# SQRL Callers:
# SqrlInterface().
# User:
# Has no direct access, but is able to pass-in the interface argument (only)
# from SqrlInterface() or SqrlSource(). Both of these check that interface
# is a unique (non-clashing) and assignable name. No further checks needed.
# When acting as a setter; make the assignment, return the result invisibly.
# This does not alter the data source's 'interface' parameter.
if (!is.null(set))
{
def <- eval(parse(text = set, keep.source = FALSE))
assign(interface, def, "SQRL:Face")
return(invisible(def))
}
# If the exists argument was specified, return whether or not the interface
# exists (as a function). When exists is TRUE (FALSE), we return TRUE when the
# interface does (does not) exist.
if (!is.null(exists))
{
if (is.null(interface))
{
return(FALSE == exists)
}
ex <- exists(interface, "SQRL:Face", mode = "function", inherits = FALSE)
return(ex == exists)
}
# If the clashes argument was specified, return whether or not the interface
# name is already taken by some other function, in SQRL:Face, the global
# environment, or any of their ancestor (parent, etc.) environments. When
# clashes is TRUE (FALSE), we return TRUE when there is (not) a conflict.
if (!is.null(clashes))
{
if (exists(interface, "SQRL:Face", mode = "function", inherits = TRUE)
|| exists(interface, globalenv(), mode = "function", inherits = TRUE))
{
return(clashes)
}
return(!clashes)
}
# Delete the interface function, on request. This does not alter the data
# source's 'interface' parameter.
if (delete)
{
suppressWarnings(
remove(list = interface, pos = "SQRL:Face", inherits = FALSE))
return(invisible(NULL))
}
# Acting as a getter; return the interface function.
return(get(interface, "SQRL:Face", mode = "function", inherits = FALSE))
}
SqrlHelp <- function(datasource = "",
type = "",
clean = FALSE)
{
# Displays run-time generated help for SQRL interface functions.
# Args:
# datasource : The name of a known data source.
# type : The requested help format ('text' or 'html').
# clean : If set to TRUE, any old temp files are removed.
# Returns:
# Invisible NULL, after displaying help.
# SQRL Calls:
# SqrlHelp() (self), SqrlHelper(), SqrlPath(), SqrlTry(), srqlHelp.
# tools Calls:
# Rd2HTML(), Rd2txt() (only if the tools package is installed).
# utils Calls:
# browseURL(), help() (only if utils is attached).
# SQRL Callers:
# SqrlDelegate(), SqrlHelp() (self), .onLoad(), .onUnload().
# User:
# Has no direct access, but is able to submit (only) the 'type' argument.
# That is coerced to an allowed value, and no further checks are required.
# If the clean argument was set, prune any old temp files and return the temp
# files list (after creating an empty list if the list does not yet exist).
if (clean)
{
if (!exists("temps", srqlHelp, inherits = FALSE))
{
return(assign("temps", character(0L), srqlHelp))
}
temps <- get("temps", srqlHelp, inherits = FALSE)
temps <- temps[file.exists(temps)]
temps <- temps[!suppressWarnings(file.remove(temps))]
return(assign("temps", temps, srqlHelp))
}
# Unless a supported help type was supplied, use the default help type.
# This may be NULL valued. Types are not case sensitive.
type <- tolower(type)
if (!identical(type, "text")
&& !identical(type, "html"))
{
type <- tolower(getOption("help_type"))
}
# If the utils package (which provides the help() function) is not loaded, or
# if the tools package (which converts Rd files) is unavailable, then display
# text-format help on the R console.
if (!("package:utils" %in% search())
|| (length(find.package("tools", quiet = TRUE)) == 0L))
{
return(cat(SqrlHelper(datasource, plaintext = TRUE), sep = "\n"))
}
# The tools package is available. We shall dynamically generate tailored help
# for the invoking (data source's) interface function. This involves temp
# files. Remove any existing SQRL temp files (from any prior SqrlHelp() call).
temps <- SqrlHelp(clean = TRUE)
# Generate R documentation (Rd) formatted help, and write it to a temp file.
rdfile <- tempfile(fileext = ".Rd")
temps <- assign("temps", c(temps, rdfile), srqlHelp)
writeLines(SqrlHelper(datasource), rdfile)
# Detect and handle RStudio, which does things a bit differently (different
# viewer, different style, different file location rules). For RStudio, the
# 'type' argument is ignored (help is only provided in HTML format).
if (nzchar(Sys.getenv("RSTUDIO_USER_IDENTITY")))
{
# Rstudio's viewer seems to want a style file in the same directory as the
# help (HTML) file (and only wants the file name of that CSS file, not its
# full path). That compels us to copy a style file to this temp file.
csstemp <- tempfile(fileext = ".css")
temps <- assign("temps", c(temps, csstemp), srqlHelp)
# Set a default cascading style sheet. This won't exist within the temp
# directory, in which case the viewer will apply default styling when it
# does not find the CSS file (no harm done, but not aesthetically ideal).
cssfile <- "R.css"
# These locations are where we think the RStudio and R style files will be.
# The two styles are different, so the RStudio file is preferred.
cssfiles <- c(file.path(Sys.getenv("RSTUDIO_PANDOC"),
"../../resources/R.css"),
file.path(R.home(), "library/base/html/R.css"))
# If we find, and can copy, the RStudio file, use that. Otherwise, if we
# find, and can copy, the base R file, use that. If we find neither, the
# default style will apply.
for (css in cssfiles)
{
if (!is.null(SqrlPath(css))
&& file.copy(css, csstemp))
{
cssfile <- csstemp
break
}
}
# Convert the Rd to HTML, write that to another temp file, open that in the
# RStudio viewer, and return invisible NULL. Note the use of basename().
htmlfile <- tempfile(fileext = ".html")
assign("temps", c(temps, htmlfile), srqlHelp)
if (SqrlTry(tools::Rd2HTML(rdfile, htmlfile, package = "SQRL",
stylesheet = basename(cssfile)))$error)
{
# If that fails, show plain-text help on the R console.
return(cat(SqrlHelper(datasource, plaintext = TRUE), sep = "\n"))
}
getOption("viewer")(htmlfile)
return(invisible(NULL))
}
# If the help type is 'html', convert the Rd to HTML, write that to another
# temp file, open that file in the default browser, and return invisible NULL.
if (identical(type, "html"))
{
htmlfile <- tempfile(fileext = ".html")
assign("temps", c(temps, htmlfile), srqlHelp)
cssfile <- paste0(R.home(), "/library/base/html/R.css")
if (SqrlTry(tools::Rd2HTML(rdfile, htmlfile, package = "SQRL",
stylesheet = cssfile))$error)
{
# If that fails, show plain-text help on the R console.
return(cat(SqrlHelper(datasource, plaintext = TRUE), sep = "\n"))
}
utils::browseURL(htmlfile)
return(invisible(NULL))
}
# Otherwise, convert the Rd to text, write that to another temp file, open
# that file in the default text viewer (pager), and return invisible NULL.
txtfile <- tempfile(fileext = ".txt")
assign("temps", c(temps, txtfile), srqlHelp)
if (SqrlTry(tools::Rd2txt(rdfile, txtfile, package = "SQRL"))$error)
{
# If that fails, show plain-text help on the R console.
return(cat(SqrlHelper(datasource, plaintext = TRUE), sep = "\n"))
}
file.show(txtfile)
return(invisible(NULL))
}
SqrlHelper <- function(datasource = "",
plaintext = FALSE)
{
# Generates help for SQRL interface functions during run-time.
# Args:
# datasource : The name of a known data source.
# plaintext : If TRUE, returns plain text instead of R documentation.
# Returns:
# A character vector of dynamically-generated help, containing a listing of
# the current datasource configuration, in either R documentation (Rd) or
# plain text format.
# SQRL Calls:
# SqrlConfig(), SqrlEscape().
# SQRL Callers:
# SqrlHelp().
# User:
# Has no direct access, but is able to control the datasource parameter
# settings (interface name, ping query, and so on). These are handled by
# SqrlEscape(), so no checks are required here.
# Select R documentation (Rd) formatting commands or plain text substitutes.
# We do this rather than gsub() Rd to plain text, in case any of the below
# inexplicably appear within a SQRL parameter.
p <- if (plaintext) 2L else 1L
ba <- switch(p, "\\acronym{", "") # Begin acronym highlighting.
ea <- switch(p, "}", "") # End acronym highlighting.
bc <- switch(p, "\\code{", "'") # Begin code highlighting.
ec <- switch(p, "}", "'") # End code highlighting.
bd <- switch(p, "\\description{", "Description:\n") # Begin description.
ed <- switch(p, "}", "") # End description (section).
bf <- switch(p, "\\file{", "'") # Begin filename highlighting.
ef <- switch(p, "}", "'") # End filename highlighting.
bh <- switch(p, "\\section{", "") # Begin new section.
eh <- switch(p, "}", ":\n") # End current section.
bp <- switch(p, "{\\preformatted{", "") # Begin preformatted region.
ep <- switch(p, "}}", "") # End preformatted region.
bq <- switch(p, "\\sQuote{", "'") # Begin single-quoted text.
eq <- switch(p, "}", "'") # End single-quoted text.
bt <- switch(p, "\\title{", "") # Begin title text.
et <- switch(p, "}", "\n") # End title text.
tb <- switch(p, "", " ") # Tab indent for plain text.
# Obtain the current source configuration (all parameter values).
config <- SqrlConfig(datasource)
# Extract the driver from the configuration, and escape any % characters
# (these are the Rd comment symbol, even within \preformatted{} sections).
if (grepl("[[:graph:]]", config[["driver"]]))
{
driver <- paste0(bf, SqrlEscape(config[["driver"]], plaintext), ef)
} else
{
driver <- "unknown or undefined"
}
# Extract and escape the data source's (SQRL) name.
if (identical(config[["name"]], config[["interface"]]))
{
dsrc <- "of the same name"
} else
{
dsrc <- paste0(bf, SqrlEscape(config[["name"]], plaintext), ef)
}
# Establish the channel status, and choose the appropriate phrase.
if (is.null(config[["channel"]]))
{
ochan <- "closed"
} else
{
ochan <- "open"
}
# Construct example queries, appropriate to the source's driver.
if (grepl("oracle|db2", driver, ignore.case = TRUE))
{
query1 <- "select 1 from dual"
query2 <- "\"select \", sample(6, 1), \" from dual\""
} else
{
query1 <- "select 1"
query2 <- "\"select \", sample(6, 1)"
}
# Extract and escape the interface function's name.
iface <- SqrlEscape(config[["interface"]], plaintext)
# Set a package name for plain text output, or a document title for Rd format.
if (plaintext)
{
doctitle <- ""
package <- " (package:SQRL)"
} else
{
doctitle <- paste0("\\name{", iface, "}")
package <- ""
}
# Escape and list all parameter values.
config <- SqrlEscape(config, plaintext)
csc <- paste(names(config), "=", config)
# Construct and return the help, as either plain text or R documentation (Rd
# format), as was requested.
c(doctitle,
paste0(bt, "ODBC Interface Function ", bq, iface, eq, package, et),
bd,
paste0(tb, "The function ", bc, iface, ec,
" is an interface to the data source ", dsrc, "."),
paste0(tb, "The ", ba, "ODBC", ea, " driver is ", driver, "."),
paste0(tb, "Communications are ", ochan, "."),
ed,
paste0(bh, "Listing Sources", eh, bp),
paste0(tb, "# View the associated source definition."),
paste0(tb, iface, "(\"source\")"),
"",
paste0(tb, "# See all data sources and their interfaces."),
paste0(tb, iface, "(\"sources\")"),
ep,
paste0(bh, "Opening and Closing", eh, bp),
paste0(tb, "# Open a connection to the data source."),
paste0(tb, iface, "()"),
"",
paste0(tb, "# Check if the connection is open."),
paste0(tb, iface, "(\"isopen\")"),
"",
paste0(tb, "# Close the connection."),
paste0(tb, iface, "(\"close\")"),
"",
paste0(tb, "# Close the connection when not in use."),
paste0(tb, iface, "(autoclose = TRUE)"),
ep,
paste0(bh, "Submitting Queries", eh, bp),
paste0(tb, "# Submit a query."),
paste0(tb, iface, "(\"", query1, "\")"),
"",
paste0(tb, "# Submit a compound query."),
paste0(tb, iface, "(", query2, ")"),
"",
paste0(tb, "# Submit a query from file."),
paste0(tb, iface, "(\"my/file.sql\")"),
"",
paste0(tb, "# Submit a parameterised query from file."),
paste0(tb, iface, "(\"rhaphidophoridae.sqrl\", genus = \"gymnoplectron\")"),
"",
paste0(tb, "# Force submission as a query."),
paste0(tb, iface, "(query = \"help\")"),
ep,
paste0(bh, "Communication Parameters", eh, bp),
paste0(tb, "# Get a named parameter value."),
paste0(tb, iface, "(\"uid\")"),
"",
paste0(tb, "# Set a named parameter value."),
paste0(tb, iface, "(visible = TRUE)"),
"",
paste0(tb, "# Reset a parameter to its default value."),
paste0(tb, iface, "(reset = \"nullstring\")"),
"",
paste0(tb, "# List all parameter values."),
paste0(tb, iface, "(\"config\")"),
"",
paste0(tb, "# Set multiple parameter values from file."),
paste0(tb, iface, "(config = \"path/to/config/file\")"),
ep,
paste0(bh, "Further Assistance", eh, bp),
paste0(tb, "# Additional usage examples."),
paste0(tb, "?sqrlUsage"),
"",
paste0(tb, "# Detailed parameter descriptions."),
paste0(tb, "?sqrlParams"),
ep,
paste0(bh, "Current Settings", eh, bp),
paste0(tb, csc),
ep)
}
SqrlIndicator <- function(datasource = "",
action = "",
marker = "all")
{
# Alters the display-state of open-connection (channel) indicators.
# Args:
# datasource : The name of a known (to SQRL) data source.
# action : One of 'show', 'hide', 'busy', or 'done'.
# marker : One of 'prompt', 'wintitle', or 'all' (the default).
# Returns:
# Invisible NULL, after making the requested indicator changes.
# SQRL Calls:
# SqrlParam().
# utils Calls:
# getWindowTitle(), setWindowTitle() (only if the utils package is attached,
# and these two functions exist within it on the current OS/platform).
# SQRL Callers:
# SqrlDelegate(), SqrlParam(), SqrlPing(), SqrlSubmit().
# User:
# Has no direct access, and is unable to indirectly supply any of the
# arguments. Argument validity checks are not required.
# TRUE if the indicators are potentially visible (when the data source's
# channel is open). No test of openness is made here; that should be performed
# (where necessary) before calling this function.
visible <- (interactive()
&& SqrlParam(datasource, "visible"))
# TRUE if, and only if, the prompt is to be altered.
do.prompt <- (visible
&& (marker %in% c("all", "prompt")))
# TRUE if, and only if, the window title is to be altered.
# The get/setWindowTitle() functions only exist on Windows versions of R,
# and only work with Rgui, R Console, and Rterm (not with RStudio).
# We test ("package:utils" %in% search()), rather than
# requireNamespace("utils", quietly = TRUE), because, if utils is attached,
# we then need to look inside it to see whether or not the get & set functions
# exist. This doesn't work without attachment (having the namespace available
# does not suffice). We could promote our utils reliance from suggests to
# depends, in the package description file, but would rather not have this
# strict requirement (this indicator feature is nice to have, but not
# absolutely necessary). Utils is normally attached on start-up, anyhow.
do.title <- (visible
&& (marker %in% c("all", "wintitle"))
&& ("package:utils" %in% search())
&& exists("getWindowTitle", where = "package:utils",
mode = "function", inherits = FALSE)
&& exists("setWindowTitle", where = "package:utils",
mode = "function", inherits = FALSE))
# When the action is 'show', apply (append and/or prepend) the indicator(s).
if (action == "show")
{
# Append window title-bar open-channel indicator.
if (do.title)
{
indic <- SqrlParam(datasource, "wintitle")
if (grepl("[[:graph:]]", indic))
{
utils::setWindowTitle(title = sub("\\s+$", "",
paste(sub("\\s+$", "", utils::getWindowTitle()), indic)))
}
}
# Prepend command-prompt open-channel indicator.
if (do.prompt)
{
indic <- SqrlParam(datasource, "prompt")
options(prompt = paste0(indic, getOption("prompt")))
}
# Return invisible NULL.
return(invisible(NULL))
}
# When the action is 'hide', remove the indicator(s). This will work (as in,
# does nothing, quietly) if the indicators aren't actually on to begin with.
# Where this can go wrong, is when the open indicators are defined as, say,
# 'A', and 'AB'. Removal of 'A" from 'ABA' might leave 'BA'. So don't do that.
if (action == "hide")
{
# Remove one open-channel indicator from the window title.
if (do.title)
{
indic <- SqrlParam(datasource, "wintitle")
if (grepl("[[:graph:]]", indic))
{
windowtitle <- utils::getWindowTitle()
if (grepl(indic, windowtitle, fixed = TRUE))
{
position <- max(gregexpr(indic, windowtitle, fixed = TRUE)[[1L]])
before <- sub("\\s+$", "", substring(windowtitle, 1L, position - 1L))
after <- substring(windowtitle, position + nchar(indic))
utils::setWindowTitle(title = sub("\\s+$", "", paste0(before, after)))
}
}
}
# Remove one open-channel indicator from the R prompt.
if (do.prompt)
{
indic <- SqrlParam(datasource, "prompt")
if (nchar(indic) > 0L)
{
options(prompt = sub(indic, "", getOption("prompt"), fixed = TRUE))
}
}
# Return invisible NULL.
return(invisible(NULL))
}
# When the action is 'query', 'fetch', or 'ping', append a job-in-progress
# marker ('*', '+', or '?', respectively) to the data source's window title
# indicator, then return invisible NULL. This will work (as in, does nothing,
# quietly) if the indicator isn't actually on.
if (action %in% c("query", "fetch", "ping"))
{
glyph <- switch(action, "query" = "*", "fetch" = "+", "ping" = "?")
if (do.title)
{
indic <- SqrlParam(datasource, "wintitle")
glyphed <- paste0(indic, glyph)
if (grepl("[[:graph:]]", indic))
{
windowtitle <- utils::getWindowTitle()
for (unglyphed in paste0(indic, c(" ", "*", "+", "?", "")))
{
if (grepl(unglyphed, windowtitle, fixed = TRUE))
{
utils::setWindowTitle(title = sub("\\s+$", "",
sub(unglyphed, glyphed, windowtitle, fixed = TRUE)))
break
}
}
}
}
return(invisible(NULL))
}
# When the action is 'done', remove a job-in-progress marker ('*', '+', '?')
# from the data source's window title indicator, then return invisible NULL.
# This will work (does nothing, quietly) if no marker is actually present.
if (action == "done")
{
if (do.title)
{
indic <- SqrlParam(datasource, "wintitle")
unglyphed <- paste0(indic, " ")
if (grepl("[[:graph:]]", indic))
{
windowtitle <- utils::getWindowTitle()
for (glyphed in paste0(indic, c("*", "+", "?")))
{
if (grepl(glyphed, windowtitle, fixed = TRUE))
{
utils::setWindowTitle(title = sub("\\s+$", "",
sub(glyphed, unglyphed, windowtitle, fixed = TRUE)))
break
}
}
}
}
return(invisible(NULL))
}
# This should be unreachable, but if we were to arrive here, return NULL.
return(invisible(NULL))
}
SqrlInterface <- function(datasource = "",
interface = "",
vital = TRUE)
{
# Constructs a user-interface to a specified data source.
# Args:
# datasource : The name of a known data source.
# interface : The name to use for that data source's interface.
# vital : When set to FALSE, name conflicts are non-fatal.
# Returns:
# A function (named <interface>) for interacting with the data source.
# Any pre-existing interface to that data source will be deleted.
# If interface is not specified, the interface name defaults to the data
# source name (sans whitespace). When interface == "remove", no new
# interface is created, but any existing interface will be deleted. (There
# is no loss of generality, since "remove" is prohibited as an interface
# name due to its conflicting with the base::remove() function.)
# SQRL Calls:
# SqrlFace(), SqrlInterface() (self), SqrlParam().
# SQRL Callers:
# SqrlCache(), SqrlConfig(), SqrlDelegate(), SqrlDSNs(), SqrlInterface()
# (self), SqrlOff(), SqrlParam(), SqrlSource(), sqrlInterface().
# User:
# Has no direct access, but is able to indirectly supply the datasource
# argument via sqrlInterface(), and through SqrlSources() by editing the
# registered data source names (DSNs) prior to loading SQRL. The user can
# indirectly supply the interface argument via sqrlInterface(),
# SqrlDelegate(), and through SqrlSources() by editing the DSNs prior to
# loading SQRL. The user cannot indirectly supply the vital argument. In
# all cases, existence of the datasource is established before calling this
# function. The interface value could be anything, and is checked here.
# This is the user-interface function-body definition for the data source.
uibody <- paste0("function(...) {SqrlShell(\"", datasource,
"\", base::parent.frame(), base::list(...))}")
# Abort on invalid interface (name). Allowed values are NULL or a character
# string. The requested name may, or may not, be available and assignable.
if (!is.null(interface)
&& (!identical(class(interface), class(character()))
|| (length(interface) != 1L)
|| !nzchar(trimws(interface))))
{
if (!vital)
{
return(invisible(NULL))
}
stop("Invalid interface name.")
}
# Remove any name and leading or trailing whitespace from the interface
# argument. Applying trimws() to NULL would produce character(0). The
# as.character() function removes any name attribute the string may have.
if (!is.null(interface))
{
interface <- trimws(as.character(interface))
}
# Isolate the previous interface (NULL when no interface was defined).
preface <- SqrlParam(datasource, "interface")
# On a request to delete the data source's interface, if we can confirm the
# interface object retains its original SQRL definition, then we delete that
# object. Either way, the interface is deregistered in the data source's
# cache, and an invisible NULL is returned.
if (is.null(interface)
|| identical(interface, "remove"))
{
if (!is.null(preface))
{
if (SqrlFace(preface, exists = TRUE))
{
fun <- paste(deparse(SqrlFace(preface)), collapse = "")
if (gsub("[[:space:]]+", "", fun) == gsub("[[:space:]]+", "", uibody))
{
SqrlFace(preface, delete = TRUE)
}
}
SqrlParam(datasource, "interface", NULL)
}
return(invisible(NULL))
}
# Check that the preface actually is a SQRL interface, and set NULL otherwise.
# To be an interface, it must be registered within the source parameter cache,
# exist as a function, and have the precise uibody definition (above).
if (!is.null(preface)
&& (SqrlFace(preface, exists = FALSE)
|| (gsub("[[:space:]]+", "",
paste(deparse(SqrlFace(preface)), collapse = ""))
!= gsub("[[:space:]]+", "", uibody))))
{
preface <- NULL
SqrlParam(datasource, "interface", NULL)
}
# If no interface was specified, use the data source name (sans whitespace).
if (nchar(interface) < 1L)
{
interface <- gsub("[[:space:]]+", "", datasource)
}
# If the interface already exists (under the same name), return it (silently).
# The above chack on preface guarantees existence within envir when not NULL.
if (!is.null(preface)
&& (preface == interface))
{
return(invisible(interface))
}
# Ensure the interface name is assignable. Non-assignability is usually fatal,
# but when vital == FALSE the function exists normally (SqrlSources() uses
# this when auto-generating functions, since 'A<<B' is a valid DSN name).
if (interface != make.names(interface))
{
if (!vital)
{
return(invisible(NULL))
}
stop("Unassignable interface name.")
}
# Abort if some other object already exists under the chosen name.
# Usually, these conflicts are fatal, but when vital == FALSE the function
# exits normally (SqrlSources() uses this when auto-generating interfaces).
if (SqrlFace(interface, clashes = TRUE))
{
if (!vital)
{
return(invisible(NULL))
}
stop("Interface name conflict.")
}
# If the data source already has an interface (under some other name), then
# delete that existing interface (before continuing).
if (!is.null(preface)
&& (preface != interface))
{
SqrlInterface(datasource, "remove")
}
# Assign the interface function to the chosen name. Note that changing the
# interface (name) does not change the wintitle or prompt strings. Those are
# both based upon the (invariant) data source name.
SqrlFace(interface, uibody)
# Register that assignment within the data source's cache. Again, this does
# not alter the (data source name based) wintitle or prompt strings.
SqrlParam(datasource, "interface", interface)
# Return the name of the new user-interface function (invisibly).
return(invisible(interface))
}
SqrlIsOpen <- function(datasource = "",
besure = FALSE)
{
# Tests whether or not an open ODBC channel exists to the data source.
# Args:
# datasource : The name of a data source.
# besure : Check thoroughly (ping the source) when this is set to TRUE.
# Returns:
# TRUE if the data source exists, and SQRL has an open channel to it.
# FALSE, otherwise.
# SQRL Calls:
# SqrlClose(), SqrlParam(), SqrlPing(), SqrlTry().
# RODBC Calls:
# odbcGetInfo().
# SQRL Callers:
# SqrlDelegate(), SqrlOpen(), SqrlParam(), SqrlSource(), SqrlSources(),
# SqrlSubmit().
# User:
# Has no direct access, and is unable to indirectly supply either argument.
# Argument validity checks are not required.
# Attempt to obtain the channel parameter value for the specified data source.
channel <- SqrlTry(SqrlParam(datasource, "channel"), warn = FALSE)
# Return FALSE when the datasource is invalid (does not exist => is not open).
if (channel$error)
{
return(FALSE)
}
# Isolate the value of the channel parameter (strip the SqrlTty() error flag).
channel <- channel$value
# Return FALSE when the channel is closed (and we knew that).
if (is.null(channel))
{
return(FALSE)
}
# Return FALSE when the channel is not an RODBC handle (in which case we may
# have mistakenly thought the channel was open, since it was non-null valued).
if (!identical(class(channel), "RODBC"))
{
SqrlClose(datasource)
return(FALSE)
}
# Attempt to obtain channel information. This will fail if the channel has
# been closed from our end, or is not of RODBC class (repeating, in effect,
# the test above), but will succeed if the channel has been closed from the
# other end (and we were previously unaware of that).
info <- SqrlTry(RODBC::odbcGetInfo(channel), warn = FALSE)
# Return FALSE when the channel is closed (but we thought it was open).
if (info$error)
{
SqrlClose(datasource)
return(FALSE)
}
# When besure is FALSE (the default), we only check openness from our end.
# That being the case, return TRUE if we get to this point (the channel
# appears to be open from our end) and we're not going to be more thorough.
if (!besure)
{
return(TRUE)
}
# Otherwise (when we want to be thorough), ping the source to make sure.
# If the ping succeeds, the connection must be open.
if (SqrlPing(datasource))
{
return(TRUE)
}
# The ping failed; the connection is not open after all (has been dropped at
# the source's end). Formally close it at this end, before returning the
# openness status (FALSE).
SqrlClose(datasource)
return(FALSE)
}
SqrlOff <- function()
{
# Close SQRL channels, deactivate SQRL.
# Args:
# None.
# Returns:
# Invisible NULL, after closing channels and detaching SQRL.
# SQRL Calls:
# SqrlCache(), SqrlClose(), SqrlInterface(), SqrlTry().
# RODBC Calls:
# odbcCloseAll().
# SQRL Callers:
# sqrlOff().
# User:
# User has no direct access, and there are no arguments.
# SQRL data sources correspond to child environments of srqlHaus. For each
# of these, close any open channel, remove any interface, and delete any data
# within the source cache (may contain passwords and so on). The garbage
# collector ought to take care of the cached data after we detach srqlHaus,
# but it's best to be immediate and sure. Operations are wrapped in silent
# try(), because we don't want one hiccup to block any other activity.
for (datasource in SqrlCache("*"))
{
SqrlTry(SqrlClose(datasource), warn = FALSE)
SqrlTry(SqrlInterface(datasource, "remove"), warn = FALSE)
cache <- SqrlCache(datasource)
SqrlTry(remove(list = objects(pos = cache, all.names = TRUE), pos = cache),
warn = FALSE)
}
# Detach the public SQRL:Face (interfaces) environment. The garbage collector
# should handle the rest. Again, wrapped in try() so that a failure here won't
# have knock-on effects.
SqrlTry(detach("SQRL:Face"), warn = FALSE)
# Detach and unload the SQRL package. The .onUnload() function attempts to
# detach SQRL:Face once again (but this doesn't matter).
SqrlTry(detach("package:SQRL", unload = TRUE), warn = FALSE)
# Return invisible NULL.
return(invisible(NULL))
}
SqrlOpen <- function(datasource = "")
{
# Opens a channel to a data source.
# Args:
# datasource : The name of a data source.
# Returns:
# Invisible NULL, after creating and caching the data source channel.
# Will throw a fatal exception should the connection attempt fail.
# SQRL Calls:
# SqrlIsOpen(), SqrlParam(), SqrlParams(), SqrlPing(), SqrlTry().
# RODBC Calls:
# odbcConnect(), odbcDriverConnect()
# SQRL Callers:
# SqrlDelegate(), SqrlSubmit().
# User:
# Has no direct access. Is unable to supply the only argument.
# Argument validity checks are not required.
# If an open channel already exists, do not attempt to open another.
if (SqrlIsOpen(datasource, besure = TRUE))
{
return(invisible(NULL))
}
# RODBC will prompt the user (via dialog box) for missing information (uid,
# pwd, etc.) only in Rgui. In Rterm, RStudio, etc., pwd must be contained in
# the DSN or connection string, or the pwd parameter must be set, prior to
# attempting to connect. Otherwise, a (connection failure) error will result.
# If a connection string has been defined for this source, connect using that.
connection <- as.character(SqrlParam(datasource, "connection"))
if (nchar(connection) > 0L)
{
for (param in SqrlParams("substitutable"))
{
connection <- gsub(paste0("<", param, ">"), SqrlParam(datasource, param),
connection, fixed = TRUE)
}
channel <- SqrlTry(
RODBC::odbcDriverConnect(
connection = connection,
case = SqrlParam(datasource, "case"),
believeNRows = SqrlParam(datasource, "believeNRows"),
colQuote = SqrlParam(datasource, "colQuote"),
tabQuote = SqrlParam(datasource, "tabQuote"),
interpretDot = SqrlParam(datasource, "interpretDot"),
DBMSencoding = SqrlParam(datasource, "DBMSencoding"),
rows_at_time = SqrlParam(datasource, "rows_at_time"),
readOnlyOptimize = SqrlParam(datasource, "readOnlyOptimize")))
# Otherwise (no string), connect using the registered data source name (DSN).
} else
{
# If a user-ID and/or password has been defined, use the defined value (this
# overrides any corresponding value that may be defined within the DSN).
# Otherwise, use '' (rather than the default values), which causes RODBC to
# go with any values in the DSN (and to ask for missing values in Rgui).
# We can't just send the default values, because these will override any
# corresponding values on the DSN (which is unlikely to be the preferred
# behaviour). We do still want a non-empty default user-id, since this is
# useful when connecting via a string incorporating the <uid> placeholder.
uid <- ""
pwd <- ""
if (SqrlParam(datasource, "uid", isdefined = TRUE))
{
uid <- SqrlParam(datasource, "uid")
}
if (SqrlParam(datasource, "pwd", isdefined = TRUE))
{
pwd <- SqrlParam(datasource, "pwd")
}
channel <- SqrlTry(
RODBC::odbcConnect(
dsn = SqrlParam(datasource, "dsn"),
uid = uid,
pwd = pwd,
case = SqrlParam(datasource, "case"),
believeNRows = SqrlParam(datasource, "believeNRows"),
colQuote = SqrlParam(datasource, "colQuote"),
tabQuote = SqrlParam(datasource, "tabQuote"),
interpretDot = SqrlParam(datasource, "interpretDot"),
DBMSencoding = SqrlParam(datasource, "DBMSencoding"),
rows_at_time = SqrlParam(datasource, "rows_at_time"),
readOnlyOptimize = SqrlParam(datasource, "readOnlyOptimize")))
}
# Halt and notify on failure to connect. Might just be an incorrect password,
# but could also be a network or server outage, etc. Fatal error, regardless.
# When RODBC::odbcConnect or RODBC::odbcDriverConnect encounter a failure to
# connect, they do not stop with an error message, but instead return -1 and
# throw warning messages with the details.
if (channel$error
|| !identical(class(channel$value), "RODBC"))
{
stop("Connection attempt failed.")
}
# Looks like a valid connection channel was established. Record handle.
channel <- SqrlParam(datasource, "channel", channel$value)
# Double-check. If the connection attempt was unsuccessful, halt and notify.
if (!SqrlIsOpen(datasource))
{
stop("Connection attempt failed.")
}
# Scrape uid, dsn, and driver from the channel's connection attribute (in case
# the user should have entered something new). Mis-scraping will not kill the
# open channel, but it will produce an incorrect view in SqrlConfig(), and
# will prevent network drop-out recovery in SqrlSubmit(). We blank the uid
# parameter first, because if it does not appear in the channel's connection
# string, then it could be anything (when contained within a DSN, perhaps).
SqrlParam(datasource, "uid", "", override = TRUE)
cstring <- attr(channel, "connection.string")
cstrings <- unlist(strsplit(cstring, ';'))
for (param in SqrlParams("scrapeable-channel"))
{
pattern <- paste0("^", param, "=")
matches <- grepl(pattern, cstrings, ignore.case = TRUE)
if (any(matches))
{
index <- which(matches)[1L]
value <- trimws(sub(pattern, "", cstrings[index], ignore.case = TRUE))
SqrlParam(datasource, param, trimws(gsub("^\\{|\\}$", "", value)),
override = TRUE)
}
}
# If no ping has been defined for this data source, attempt to find (set) one.
if (is.null(SqrlParam(datasource, "ping")))
{
SqrlPing(datasource, set = TRUE)
}
# Return invisible NULL.
return(invisible(NULL))
}
SqrlParam <- function(datasource = "",
parameter = "",
set,
override = FALSE,
isdefined = NULL)
{
# Gets and sets named SQRL/RODBC control parameters for a data source.
# Args:
# datasource : The name of a known (to SQRL) data source.
# parameter : The name of a SQRL or RODBC control parameter.
# set : The value to assign to that parameter (optional).
# override : If set to TRUE, open status does not block value changes.
# isdefined : If set to TRUE, return whether or not a value is defined.
# Returns:
# The value of the named parameter for the named data source. If the set
# argument is specified, then the new value is returned (invisibly) after
# its assignment to the parameter (new passwords are not returned).
# SQRL Calls:
# SqrlCache(), SqrlDefault(), SqrlIndicator(), SqrlInterface(),
# SqrlIsOpen(), SqrlParam() (self), SqrlParams().
# RODBC Calls:
# odbcDataSources().
# SQRL Callers:
# SqrlCache(), SqrlClose(), SqrlConfig(), SqrlDefault(), SqrlDelegate(),
# SqrlDSNs(), SqrlParse(), SqrlIndicator(), SqrlInterface(), SqrlIsOpen(),
# SqrlOpen(), SqrlParam() (self), SqrlPing(), SqrlProc(), SqrlShell(),
# SqrlStatement(), SqrlSource(), SqrlSubmit(), SqrlSubScript(),
# SqrlStatement(), SqrlValue(), sqrlInterface().
# User:
# Has no direct access, but is able to supply (only) parameter and set via
# SqrlDelegate() and/or SqrlConfig(), by way of SqrlValue(). SqrlDelegate()
# vets parameter while the SqrlConfig() does not (although it will restrict
# parameter to being a string, and is write-only). Neither vets set, and
# that must be performed here. (SqrlValue() merely passes-through.)
# Obtain a handle to the data source's SQRL cache.
cacheenvir <- SqrlCache(datasource)
# When the defined flag is either TRUE or FALSE, return only whether or not a
# (default-overriding) value has been set (exists) for the parameter.
if (!is.null(isdefined))
{
if (exists("pstack", cacheenvir, inherits = FALSE))
{
ps <- get("pstack", cacheenvir, inherits = FALSE)
return(exists(parameter, ps[[length(ps)]], inherits = TRUE) == isdefined)
}
return(exists(parameter, cacheenvir, inherits = FALSE) == isdefined)
}
# When the parameter is 'reset', the set argument should be a vector of
# parameter names for which the default values are to be restored.
if (identical(parameter, "reset"))
{
# Coerce parameters to a character vector (sort() doesn't handle lists).
set <- as.character(unlist(set))
# Retain only those (unique) parameter names that are in the official list.
params <- sort(unique(set[set %in% SqrlParams("all")]))
# If we are left with no parameters to reset, return invisible NULL.
if (length(params) < 1L)
{
return(invisible(NULL))
}
# Construct a named list of the default values for those parameters.
news <- vector(mode(list()), length(params))
names(news) <- params
for (param in params)
{
news[param] <- list(SqrlDefault(datasource, param))
}
# Retain only those parameters for which a value has been set. Any others
# must necessarily already be at their defaults (resetting does nothing).
params <- params[params %in% SqrlParam(datasource, "*")]
# When all parameters are at their defaults, invisibly return them.
if (length(params) < 1L)
{
return(invisible(news))
}
# Abort if any of the supplied parameters are write-protected ('name')
# or read-only ('channel').
if (any(params %in% SqrlParams("write-protected"))
|| any(params %in% SqrlParams("read-only")))
{
stop("Cannot reset protected parameter.")
}
# If the connection is open, we cannot reset any locked-while-open
# parameters (abort if such a request has been made), and we must also
# change any visible indicators (if those parameters are to be reset).
# This is a bit of a kludge; here we set any visible indicators to values
# that are identical to their defaults, then (later, below) we remove those
# set values, leaving the actual defaults in place.
if (SqrlIsOpen(datasource))
{
if (!override
&& any(params %in% SqrlParams('locked-while-open')))
{
stop("Cannot reset parameter while connection is open.")
}
if ("visible" %in% params)
{
SqrlParam(datasource, "visible",
SqrlDefault(datasource, "visible"), override)
}
if (SqrlParam(datasource, "visible"))
{
if ("prompt" %in% params)
{
SqrlParam(datasource, "prompt",
SqrlDefault(datasource, "prompt"), override)
}
if ("wintitle" %in% params)
{
SqrlParam(datasource, "wintitle",
SqrlDefault(datasource, "wintitle"), override)
}
}
}
# Interface removal is a special case, handled by SqrlInterface().
# Failure to re-apply the original (default) interface is non-fatal.
if ("interface" %in% params)
{
SqrlInterface(datasource, "remove")
SqrlInterface(datasource, datasource, vital = FALSE)
news["interface"] <- list(SqrlParam(datasource, "interface"))
params <- params[params != "interface"]
if (length(params) < 1L)
{
return(invisible(news))
}
}
# Remove the parameter-value definitions (restores default values).
remove(list = params, pos = cacheenvir)
# Invisibly return the new parameter-values (i.e., their defaults). Default
# values are never secret or semi-secret, so these can go back to the user.
return(invisible(news))
}
# When no value is supplied for the set argument, act as a getter.
if (missing(set))
{
# Obtain the temporary parameter-values (environments) stack (a list).
pstack <- if (exists("pstack", cacheenvir, inherits = FALSE))
{
get("pstack", cacheenvir, inherits = FALSE)
} else
{
SqrlDefault(datasource, "pstack")
}
# If the stack itself was sought, return it.
if (parameter == "pstack")
{
return(pstack)
}
# Otherwise, extract the last environment from the temporary-values stack.
# This inherits from the previous environment (and so on, to the first).
pstack <- pstack[[length(pstack)]]
# When there is no set value (temporary or cached) for the parameter,
# return its default. Default values are never secret or semi-secret.
if (!exists(parameter, pstack, inherits = TRUE))
{
return(SqrlDefault(datasource, parameter))
}
# Take care with regard to whom we supply secret parameter values.
if (parameter %in% SqrlParams("secret"))
{
# If we don't see an internal call of this function (i.e., it appears to
# have been called from outside of the namespace), return the default.
calls <- gsub("\\(.*", "", .traceback(0L))
i <- which(calls == "SqrlParam")
if (length(i) < 1L)
{
return(SqrlDefault(datasource, parameter))
}
# Likewise, if we don't see who called this function, return the default.
i <- max(i) + 1L
if (i > length(calls))
{
return(SqrlDefault(datasource, parameter))
}
# If the caller is aware, return either the default value (if such has
# been set) or a dummy value (when some non-default value has been set).
if (calls[i] %in% SqrlParams("aware"))
{
value <- get(parameter, pstack, inherits = TRUE)
if (identical(value, SqrlDefault(datasource, parameter)))
{
return(value)
}
return("*")
}
# If the caller is neither aware nor informed, return the default value.
if (!(calls[i] %in% SqrlParams("informed")))
{
return(SqrlDefault(datasource, parameter))
}
# Take care with regard to whom we supply semi-secret parameter values.
} else if (parameter %in% SqrlParams("semi-secret"))
{
# If we don't see an internal call of this function (i.e., it appears to
# have been called from outside of the namespace), return the default.
calls <- gsub("\\(.*", "", .traceback(0L))
i <- which(calls == "SqrlParam")
if (length(i) < 1L)
{
return(SqrlDefault(datasource, parameter))
}
# Likewise, if we don't see who called this function, return the default.
i <- max(i) + 1L
if (i > length(calls))
{
return(SqrlDefault(datasource, parameter))
}
# If the caller is neither aware nor informed, return the default value.
if (!(calls[i] %in% c(SqrlParams("aware"), SqrlParams("informed"))))
{
return(SqrlDefault(datasource, parameter))
}
}
# The parameter is not secret, or the caller is allowed to know its value.
# Return the current (temporary or cached) value.
return(get(parameter, pstack, inherits = TRUE))
}
# The set argument has been supplied; act as a setter (cache and return).
# First, we coerce the raw value to the expected type for the parameter.
# Normal action is to set the permanent value of the named parameter.
istemp <- FALSE
targetenvir <- cacheenvir
# However, if the parameter is 'pstack' and the set value is named, then this
# is reinterpreted as a request to assign a temporary value (value-of-set) for
# the named parameter (name-of-set) into the most recent environment of the
# temporary values stack (pstack).
if ((parameter == "pstack")
&& !is.null(names(set)))
{
parameter <- names(set)
set <- set[[1L]]
istemp <- TRUE
pstack <- SqrlParam(datasource, "pstack")
targetenvir <- pstack[[length(pstack)]]
if ((length(parameter) != 1L)
|| !(parameter %in% SqrlParams("all")))
{
stop("Unrecognised parameter for temporary assignment.")
}
if (parameter %in% SqrlParams("no-temp-allowed"))
{
stop("Parameter does not support temporary values.")
}
}
# In the special case where the parameter is (still) 'pstack', we have a
# request to expand or contract the temporary-values environments stack.
# If contracting the stack would remove a temporary ping and leave the
# channel open without a ping in the stack, then the temporary ping is
# retained (copied to the stack level below).
if (parameter == "pstack")
{
pstack <- SqrlParam(datasource, parameter)
ptop <- length(pstack)
if (set == "expand")
{
pstack <- append(pstack, new.env(parent = pstack[[ptop]]))
} else if (length(pstack) >= 2L)
{
tpars <- objects(pstack[[ptop]])
if (("ping" %in% tpars)
&& !SqrlParam(datasource, "autoclose")
&& SqrlIsOpen(datasource, besure = FALSE)
&& (!exists("ping", pstack[[ptop - 1L]], inherits = TRUE)
|| !nzchar(get("ping", pstack[[ptop - 1L]], inherits = TRUE))))
{
assign("ping", get("ping", pstack[[ptop]]), pstack[[ptop - 1L]])
}
verbose <- interactive() && SqrlParam(datasource, "verbose")
remove(list = tpars, pos = pstack[[ptop]])
pstack <- pstack[-ptop]
if ((length(tpars) > 0L)
&& verbose)
{
cat("\n")
for (tpar in tpars)
{
rval <- deparse(SqrlParam(datasource, tpar))
cat("Reverting:", tpar, "=", rval, "\n")
}
cat("\n")
}
}
assign(parameter, pstack, cacheenvir)
return(invisible(set))
}
# In the special case where the connection parameter has been specified as a
# character vector of named and/or unnamed elements, we collapse that vector
# to a single (connection) string. Where present, the vector element names
# become the connection-parameter names within the string.
if ((parameter == "connection")
&& identical(class(set), class(character()))
&& (length(set) > 0L)
&& !any(is.na(set)))
{
if (is.null(names(set))
|| !any(nzchar(names(set))))
{
set <- paste0(set, collapse = ";")
} else
{
set <- paste0(names(set), c("", "=")[nzchar(names(set)) + 1L], set,
collapse = ";")
}
}
# Nullable-string parameters are string-types which accept a set value of NULL
# as an alias for the empty string.
if ((parameter %in% SqrlParams("nullable-string"))
&& is.null(set))
{
set <- ""
}
# Coerce set to the appropriate data type for the specified parameter.
# Firstly, the channel parameter can be either NULL, or of RODBC class.
# This can be set frequently, when the autoclose parameter value is TRUE.
if (parameter %in% SqrlParams("rodbc/null-type"))
{
if (!is.null(set)
&& !identical(class(set), "RODBC"))
{
stop("New parameter value is not a connection handle.")
}
# Parameters that are (non-NA) character-strings. (These include all the
# scrapeable-channel parameters that may be set with each new channel.)
} else if (parameter %in% SqrlParams("string-type"))
{
set <- suppressWarnings(as.character(set))
if ((length(set) != 1L)
|| is.na(set))
{
stop("New parameter value is not a character string.")
}
# Parameters that are logically-valued.
} else if (parameter %in% SqrlParams("boolean-type"))
{
set <- suppressWarnings(as.logical(set))
if (!identical(set, TRUE)
&& !identical(set, FALSE))
{
stop("New parameter value not a logical singleton.")
}
# Parameters that are integer-valued.
} else if (parameter %in% SqrlParams("integer-type"))
{
set <- suppressWarnings(as.integer(set))
if ((length(set) != 1L)
|| is.na(set))
{
stop("New parameter value is not an integer.")
}
# The interface and ping parameters can be character-valued or null-valued.
# Changing the interface parameter value does not change the interface.
} else if (parameter %in% SqrlParams("string/null-type"))
{
if (!is.null(set))
{
set <- suppressWarnings(as.character(set))
if ((length(set) != 1L)
|| is.na(set))
{
stop("New parameter value is not a character string.")
}
}
# The na.strings parameter is a character vector of any length, including 0.
} else if (parameter %in% SqrlParams("character-type"))
{
set <- suppressWarnings(as.character(set))
# The as.is parameter can be a logical, numerical, or character vector.
} else if (parameter %in% SqrlParams("index-type"))
{
# This can be a logical (not NA), a natural number (integer or numeric
# form), a character string (valid name form), or a vector of the same.
# The integer and numeric classes are both of numeric mode.
if (!(is.logical(set)
|| is.numeric(set)
|| is.character(set))
|| any(is.na(set)))
{
stop("Parameter must be of logical, numeric, or character type.")
}
# The colQuote and tabQuote parameters can be either NULL, or character
# vectors of length 0, 1, or 2.
} else if (parameter %in% SqrlParams("quote-type"))
{
if (!is.null(set))
{
set <- suppressWarnings(as.character(set))
if ((length(set) > 2L)
|| any(is.na(set)))
{
stop("New parameter value is not a quotation specifier.")
}
}
# The nullstring parameter is a character string, possibly NA_character_.
} else if (parameter %in% SqrlParams("string/na-type"))
{
set <- suppressWarnings(as.character(set))
if (length(set) != 1L)
{
stop("New parameter value is not a character string.")
}
# Values of the result and library parameters cannot be directly set by the
# user, but NULL is taken to mean remove the current value, which is allowed.
} else if (parameter %in% SqrlParams("nullable-internal"))
{
if (!(override
|| is.null(set)))
{
stop("New parameter value is not NULL.")
}
# Prevent the user from assigning to any name that is not on SqrlParams()'s
# 'all' list. Internal functions may do so, provided the override flag is set.
} else if (!override)
{
stop("Unrecognised parameter.")
}
# We have an acceptable value of set; so now act as a setter (below).
# No further modification of the value occurs, other than whitespace trimming
# for the prompt and wintitle parameters.
# Prevent overwriting (changing) the channel while it is open, with the
# exception that a channel can be nullified (dropped) at any time.
if ((parameter == "channel")
&& exists(parameter, cacheenvir, inherits = FALSE)
&& !is.null(set)
&& SqrlIsOpen(datasource))
{
if (identical(set, SqrlParam(datasource, "channel")))
{
return(invisible(set))
}
stop("Channel cannot be changed while open.")
}
# Prevent changing write-protected parameter values.
if ((parameter %in% SqrlParams("write-protected"))
&& exists(parameter, cacheenvir, inherits = FALSE))
{
if (identical(set, SqrlParam(datasource, parameter)))
{
return(invisible(set))
}
stop("Parameter is write-protected.")
}
# Prevent changing RODBC::odbcConnect() parameters while connection is open.
# (Because those changes would only take effect on opening a new channel.)
# The _default_ values of these 'locked-while-open' parameters cannot be
# changed while the connection is open. Hence, it is permissible to replace
# a currently default value with an identical static value at any time.
# The override condition allows SqrlOpen() to alter some of these (to values
# the user may have entered) when the connection channel is first opened.
if (!override
&& (parameter %in% SqrlParams("locked-while-open"))
&& SqrlIsOpen(datasource))
{
# This shouldn't ever happen, but just in case.
if (istemp)
{
stop(paste0("Cannot set a temporary value for the '", parameter,
"' parameter."))
}
# Throw an error on an attempt to change the parameter value. Must also
# throw an error when attempting to set a secret or semi-secret parameter to
# the value it already has, or else the value could be discovered by trial
# and error.
if ((parameter %in% c(SqrlParams("secret"), SqrlParams("semi-secret")))
|| !identical(set, SqrlParam(datasource, parameter)))
{
stop("Parameter is locked while a connection is open.")
}
# Otherwise, if the current value is a default (when no static value is
# defined), set the (identical) new value as an equivalent static
# replacement (for the default).
if (!exists(parameter, cacheenvir, inherits = FALSE))
{
assign(parameter, set, targetenvir)
}
# Return the (unchanged) value.
return(invisible(set))
}
# The channel parameter is a special case, because we want to toggle the
# indicator state along with a change of channel existence (null/not).
if (parameter == "channel")
{
# This shouldn't ever happen, but just in case.
if (istemp)
{
stop("Cannot set a temporary value for the 'channel' parameter.")
}
# Current value of the channel parameter. NULL is no channel (closed),
# anything else is we think the channel is open (it may or may not be).
current <- SqrlParam(datasource, "channel")
# No channel to channel; show indicators (conditional on settings, mode).
if (is.null(current)
&& !is.null(set))
{
SqrlIndicator(datasource, "show")
# Channel to no channel; hide indicators (conditional on settings, mode)
} else if (!is.null(current)
&& is.null(set))
{
SqrlIndicator(datasource, "hide")
}
# Set the new value. Return it invisibly.
assign(parameter, set, targetenvir)
return(invisible(set))
}
# The connection parameter is a special case, since we want to extract further
# parameter values from it, if we can. This may fail if any of the parameter
# values contain = or ;, but none of the test systems allow these characters
# in DSNs, passwords, etc. Does any system? See related 'scrape' comments
# within SqrlOpen().
if (parameter == "connection")
{
# This shouldn't ever happen, but just in case.
if (istemp)
{
stop("Cannot set a temporary value for the 'connection' parameter.")
}
# Unless the connection string contains a DSN placeholder ('<dsn>'),
# delete any dsn definition.
if (!grepl("<dsn>", set))
{
SqrlParam(datasource, "reset", "dsn", override)
}
# RODBC::odbcConnect() likes to know the driver (from which it determines
# whether or not it's dealing with MySQL). While we're doing that, we may as
# well attempt to extract some other parameter values, first. We make sure
# the driver parameter is done last, because setting a value for dsn sets
# driver as a side effect, and we may want to override that.
spars <- SqrlParams("scrapeable-string")
for (param in c(spars[spars != "driver"], spars[spars == "driver"]))
{
if (grepl(paste0(param, "\\s*="), set, ignore.case = TRUE))
{
assignee <- paste0("^.*", param, "\\s*=")
value <- sub(assignee, "", set, ignore.case = TRUE)
value <- trimws(sub(";.*$", "", value))
# 'user' and 'username' are connection string aliases for 'uid'.
if (param %in% SqrlParams("uid-aliases"))
{
param <- "uid"
# 'password' is a connection string alias for 'pwd'.
} else if (param %in% SqrlParams("pwd-aliases"))
{
param <- "pwd"
}
# SQRL accepts <uid> (etc.) as connection string template place holders
# (to be replaced with current values at connection time). We don't want
# to override default or previous values with these.
if (value != paste0("<", param, ">"))
{
SqrlParam(datasource, param, value, override)
}
}
}
# Set the (unaltered) connection string, return invisibly.
assign(parameter, set, targetenvir)
return(invisible(set))
}
# Setting the dsn parameter is a special case, because we simultaneously
# reset the connection parameter unless the connection string contains a
# '<dsn>' placeholder. If the DSN is defined on the local system, then we
# also set the driver parameter to the DSN's value, as obtained from
# RODBC::odbcDataSources().
if (parameter == "dsn")
{
if (istemp)
{
stop("Cannot set a temporary value for the 'dsn' parameter.")
}
if (!grepl("<dsn>", SqrlParam(datasource, "connection")))
{
SqrlParam(datasource, "reset", "connection", override)
}
assign(parameter, set, targetenvir)
sources <- RODBC::odbcDataSources("all")
if ((nzchar(set))
&& (set %in% names(sources)))
{
SqrlParam(datasource, "driver", sources[set], override)
}
return(invisible(set))
}
# Setting the ping to NULL (its default value) is a special case enacted by
# deleting any existing value (leaving the default in effect). This simplifies
# finding valid pings in the (temporary parameter values) pstack.
if (is.null(set)
&& (parameter == "ping"))
{
SqrlParam(datasource, "reset", parameter)
return(SqrlParam(datasource, parameter))
}
# The prompt and wintitle parameters are special cases, because, if the old
# prompt or wintitle is currently visible, it must be removed before changing
# the parameter value, and then the new value must be applied.
if (parameter %in% c("prompt", "wintitle"))
{
if (istemp)
{
stop(paste0("Cannot set a temporary value for the '", parameter,
"' parameter."))
}
set <- trimws(set)
if (set != SqrlParam(datasource, parameter))
{
isopen <- SqrlIsOpen(datasource)
if (isopen)
{
SqrlIndicator(datasource, "hide", parameter)
}
assign(parameter, set, targetenvir)
if (isopen)
{
SqrlIndicator(datasource, "show", parameter)
}
}
return(invisible(set))
}
# The visible parameter is a special case, because, if the channel is open,
# both prompt and window title changes (addition or removal) must be made.
if (parameter == "visible")
{
if (istemp)
{
stop("Cannot set a temporary value for the 'visible' parameter.")
}
if (set != SqrlParam(datasource, "visible"))
{
isopen <- SqrlIsOpen(datasource)
if (isopen
&& !set)
{
SqrlIndicator(datasource, "hide")
}
assign(parameter, set, targetenvir)
if (isopen
&& set)
{
SqrlIndicator(datasource, "show")
}
}
return(invisible(set))
}
# The libstack parameter is a special case, because the set value is appended
# to the top layer of the existing stack (rather than replacing the stack).
if (parameter == "libstack")
{
# This shouldn't ever happen (unless the libstack storage mechanism is
# changed to having a library within each layer of the pstack stack), but
# we check here anyway, just in case.
if (istemp)
{
stop("Cannot alter procedures via <with>.")
}
# A NULL value is interpreted as a request to remove the stack.
if (is.null(set))
{
if (exists(parameter, cacheenvir, inherits = FALSE))
{
remove(list = parameter, pos = cacheenvir)
}
return(invisible())
}
# It is not possible to directly assign the lib[n][name] element within the
# cache environment, so we have to pull the stack pointer back here, modify
# the local copy, and then point the cache environment at this new copy.
lib <- SqrlParam(datasource, parameter)
# Unnamed strings are used as special stack-control values.
if (is.null(names(set)))
{
# When set is 'expand', add a new layer to the top of the stack (list).
if (set == "expand")
{
lib[[length(lib) + 1L]] <- character()
# Otherwise, set will be 'contract'; remove the top layer of the stack.
} else
{
lib[[length(lib)]] <- NULL
}
# Named strings are procedure definitions, to be added to the topmost layer
# of the stack.
} else
{
lib <- SqrlParam(datasource, parameter)
lib[[length(lib)]][names(set)] <- as.character(set)
}
assign(parameter, lib, cacheenvir)
return(invisible())
}
# The library parameter is a special case, because the set value is appended
# to the existing library (rather than replacing it).
if (parameter == "library")
{
# This shouldn't ever happen, but just in case.
if (istemp)
{
stop("Cannot alter library via <with>.")
}
# A NULL value is interpreted as a request to reset (empty) the library.
if (is.null(set))
{
return(SqrlParam(datasource, "reset", parameter))
}
# Otherwise, the value can only have come from SqrlParse(), and will be a
# named string (procedure definition). Add that definition to the library.
# It is not possible to directly assign the lib[name] element within the
# cache environment.
lib <- SqrlParam(datasource, parameter)
lib[names(set)] <- as.character(set)
lib <- lib[order(names(lib))]
assign(parameter, lib, cacheenvir)
return(invisible(set))
}
# For all other cases, set and (invisibly) return the new parameter value.
assign(parameter, set, targetenvir)
return(invisible(set))
}
SqrlParams <- function(group = "")
{
# Returns any one of various useful parameter groupings.
# Args:
# group : The (string) name (description) of a parameter group.
# Returns:
# A character vector of the names of all parameters in the group.
# SQRL Calls:
# None.
# SQRL Callers:
# SqrlCache(), SqrlConfig(), SqrlDefile(), SqrlDelegate(), SqrlDSNs(),
# SqrlParse(), SqrlOpen(), SqrlParam(), SqrlSource(), SqrlSources(),
# SqrlValue(), sqrlAll().
# User:
# Has no direct access, and is unable to supply the argument. Validity
# checks are not required.
# Parameter-group definitions (find and return).
return(switch(group,
# All public (user-visible) parameter names, whether RODBC or SQRL.
"all" = c("aCollapse",
"as.is",
"autoclose",
"believeNRows",
"buffsize",
"case",
"channel",
"colQuote",
"connection",
"DBMSencoding",
"dec",
"driver",
"dsn",
"errors",
"interface",
"interpretDot",
"lCollapse",
"library",
"max",
"na.strings",
"name",
"nullstring",
"ping",
"prompt",
"pwd",
"readOnlyOptimize",
"result",
"retry",
"rows_at_time",
"scdo",
"stringsAsFactors",
"tabQuote",
"uid",
"verbose",
"visible",
"wintitle"),
# Functions (not parameters) allowed to know whether or not secrets exist.
"aware" = c("SqrlValue"),
# Parameters of Boolean-singleton type (TRUE/FALSE, not NA).
"boolean-type" = c("autoclose",
"believeNRows",
"errors",
"interpretDot",
"readOnlyOptimize",
"retry",
"scdo",
"stringsAsFactors",
"verbose",
"visible"),
# Parameters of character-vector type (any length, including zero).
"character-type" = c("na.strings"),
# Parameters not to copy when duplicating an existing SQRL data source.
"don't-copy" = c("channel",
"interface",
"libstack",
"name",
"prompt",
"result",
"wintitle"),
# Parameters of index type (logical, numerical, or character vectors).
"index-type" = c("as.is"),
# Functions (not parameters) allowed to know secrets.
"informed" = c("SqrlOpen",
"SqrlSource"),
# Parameters of integer-singleton type (not NA).
"integer-type" = c("buffsize",
"max",
"rows_at_time"),
# Parameters that cannot be changed while the connection channel is open.
"locked-while-open" = c("believeNRows",
"case",
"colQuote",
"connection",
"DBMSencoding",
"driver",
"dsn",
"interpretDot",
"readOnlyOptimize",
"rows_at_time",
"tabQuote",
"uid"),
# Parameters whose values are lists of named values.
"named-values" = c("library"),
# Parameters for which temporary working values cannot be assigned.
"no-temp-allowed" = c("autoclose",
"channel",
"interface",
"library",
"name",
"prompt",
"result",
"visible",
"wintitle"),
# Parameters the user can make NULL, but whose values are otherwise only
# settable by private SQRL functions.
"nullable-internal" = c("library",
"result"),
# String-type parameters that accept NULL as an alias for the empty string.
"nullable-string" = c("connection",
"DBMSencoding",
"driver",
"dsn",
"prompt",
"pwd",
"uid",
"wintitle"),
# Parameters that are omitted from the SqrlConfig() configuration list.
"omit-from-config" = c("result"),
# Parameters to omit from the 'settings' subset of the configuration list.
"omit-from-settings" = c("channel",
"connection",
"driver",
"dsn",
"library",
"name",
"ping",
"pwd",
"result",
"uid"),
# Parameters that can be file-path valued (excluded from SqrlDefile()).
"path-valued" = c("driver",
"dsn",
"library"),
# Aliases for 'pwd' (within the 'scrapeable-string' parameter set).
"pwd-aliases" = c("password"),
# Parameters of quote type can be NULL, or character-vectors of length <= 2.
"quote-type" = c("colQuote",
"tabQuote"),
# Parameters that cannot be set (written) by the user.
"read-only" = c("channel"),
# Parameters that are of RODBC type (can be NULL valued).
"rodbc/null-type" = c("channel"),
# Parameters that can have their values scraped from an open channel object.
"scrapeable-channel" = c("driver",
"dsn",
"uid"),
# Parameters that can have their values scraped from a connection string.
"scrapeable-string" = c("driver",
"dsn",
"password",
"pwd",
"uid",
"user",
"username"),
# Parameters whose actual values are never returned to the user.
"secret" = c("password",
"pwd"),
# Parameters whose values may contain a secret component.
"semi-secret" = c("connection"),
# Parameters appearing in the data source summary table, in table column
# order (not in alphabetical order).
"source-table" = c("name",
"interface",
"open",
"driver"),
# Keywords used for SQL script identification in SqrlDelegate().
"sql-keywords" = c("select",
"create",
"drop",
"update",
"insert"),
# Parameters that are of character-string (singleton) type (non-NA).
"string-type" = c("aCollapse",
"case",
"connection",
"DBMSencoding",
"dec",
"driver",
"dsn",
"lCollapse",
"name",
"prompt",
"pwd",
"uid",
"wintitle"),
# Parameters that are of character-string type, with NAs allowed.
"string/na-type" = c("nullstring"),
# Parameters that are of string type, or else can be NULL valued.
"string/null-type" = c("interface",
"ping"),
# Parameters that can take template-form within a connection string.
"substitutable" = c("driver",
"dsn",
"pwd",
"uid"),
# Aliases for 'uid' (within the 'scrapeable-string' parameter set).
"uid-aliases" = c("user",
"username"),
# Names to filter-out when obtaining DSNs.
"unwanted-sources" = c("Access",
"dBASE",
"Excel"),
# Parameters that are write-once (even by SQRL, not just the user).
"write-protected" = c("name"),
# This should never happen.
stop("Unknown parameter group.")))
}
SqrlParse <- function(datasource = "",
script = "",
envir = parent.frame(),
params = NULL,
literal = FALSE,
libmode = FALSE)
{
# Read a SQRL-script file and submit its content to a data source.
# Args:
# datasource : The name of a known data source.
# script : The path of a script file, or an actual script, as a string.
# envir : An R environment (script is executed in a child of this).
# params : A named list of R parameters for the script.
# literal : If set to TRUE, script is a literal script (not a file path).
# libmode : If TRUE, scripts are copied to the library parameter.
# Returns:
# Result of submitting the script.
# SQRL Calls:
# SqrlClose(), SqrlDefile(), SqrlDelegate (via sqrl()), SqrlParam(),
# SqrlParams(), SqrlPL(), SqrlStatement(), SqrlSubScript(), SqrlTry().
# utils Calls:
# head() (only if utils is attached).
# SQRL Callers:
# SqrlConfig(), SqrlDelegate().
# User:
# Has no direct access, but is able to submit (only) the script argument
# (only) via SqrlDelegate(). When script is a file path, SqrlDelegate() will
# already have confirmed the file's existence and readability. When it's not,
# SqrlDelegate() will have set literal TRUE.
# Expand the temporary library stack by one layer, and ensure that layer is
# removed whenever, and however, this function exits (cleanly or otherwise).
SqrlParam(datasource, "libstack", "expand", override = TRUE)
on.exit(SqrlParam(datasource, "libstack", "contract", override = TRUE))
# Expand the temporary parameter stack by one layer, and ensure that layer is
# removed whenever, and however, this function exits (cleanly or otherwise).
SqrlParam(datasource, "pstack", "expand")
on.exit(SqrlParam(datasource, "pstack", "contract"), add = TRUE)
# When the script argument is a file path, slurp the entirety of that file.
# No ordinary script would be so large that this should be a problem.
if (!literal)
{
script <- paste(readLines(script, warn = FALSE, skipNul = TRUE),
collapse = "\n")
}
# Script delimiter definitions (regular expression patterns).
patterns <- c(
tag.r = "<r>",
tag.endr = "</r>",
tag.do = "<do>",
tag.stop = "<stop>",
tag.result = "<result[[:blank:]]*->[[:blank:]]*[^[:space:]>]+>",
tag.if = "<if[[:blank:]]*\\(",
tag.elseif = "<else[[:blank:]]*if[[:blank:]]*\\(",
tag.else = "<else>",
tag.endif = "</if>",
tag.while = "<while[[:blank:]]*\\(",
tag.endwhile = "</while>",
tag.return = "<return[[:blank:]]*\\(",
tag.close = "<close>",
tag.proc = "<proc",
tag.endproc = "</proc>",
tag.with = "<with>",
tag.endwith = "</with>",
end.expression = ")>",
comment.begin = "/\\*",
comment.end = "\\*/",
comment.line = "--",
comment.r = "#",
end.of.line = "\n",
quote.single = "'",
quote.double = "\"",
semi.colon = ";")
# Scan the script for delimiter positions (pos), types (pat), and character
# sequence lengths (len). For example, one delim might be pat = 'tag.result',
# starting at character pos = 145 of script, and len = 13 characters long
# The actual delimiter is then substring(script, pos, pos + len - 1), which in
# most cases (besides tag.result) is an invariant pattern. In our example, the
# delimiter might be '<result -> x>' (13 characters).
pos = NULL
pat = NULL
len = NULL
for (pattern in names(patterns))
{
matches <- gregexpr(patterns[pattern], script, ignore.case = TRUE)[[1L]]
positions <- as.integer(matches)
if ((length(positions) > 1L)
|| (positions > 0L))
{
pos <- c(pos, positions)
pat <- c(pat, rep(pattern, length(positions)))
len <- c(len, attr(matches, "match.length"))
}
}
# Sort the delimiters (if any exist) into ascending (script) positional order.
if (length(pos) > 1L)
{
ord <- order(pos)
pos <- pos[ord]
pat <- pat[ord]
len <- len[ord]
}
# The total number of delimiters (of all kinds) found in the script.
num.delims <- length(pos)
# The total number of characters (invisible or otherwise) within the script.
nchar.script <- nchar(script)
# Create a new environment as a child of the invoking environment.
# SqrlParse() evaluates R expressions (including the post-processing) within
# this environment (rather than the invoking environment) so as to avoid
# overwriting variables within the invoking environment.
sqrl.env <- new.env(parent = envir)
# When this is an initial (unnested) call, create an interface for making
# nested calls, and block the regular interface and public sqrl functions.
# Any nested calls will inherit these assignments.
if (length(SqrlParam(datasource, "libstack")) == 1L)
{
# Prevent calling the invoking interface from within the script. This is for
# correct autoclose behaviour, which is achieved by the tracking of call
# nesting within SqrlDelegate(). The stop() function prepends the offending
# function name to the error message (so we don't have to).
if (!is.null(SqrlParam(datasource, "interface")))
{
assign(SqrlParam(datasource, "interface"),
function(...) {stop("Calls from within scripts are blocked.")},
sqrl.env)
}
# Block calling any of the public sqrlXXX() functions from within a script.
# This is for autoclose behaviour (nesting tracking) and to prevent a call
# of one data source's interface from modifying the settings of any other.
# The stop() function prepends the offending function's name to the message.
for (fun in c("All", "Off", "Interface", "Source", "Sources"))
{
assign(paste0("sqrl", fun),
function(...) {stop("Calls from within scripts are blocked.")},
sqrl.env)
}
# Assign an interface to whichever datasource is running the script, into
# the working environment. This interface works even when the datasource has
# no devoted (regular) interface (in which case the script must have been
# passed from sqrlAll()). This function is an intra-script replacement of
# the regular interface (blocked above). It preserves nesting and makes
# scripts interface-name indifferent (i.e., improves portability). Whereas
# regular interfaces call SqrlShell(), this replacement goes directly to
# SqrlDelegate(), so that autoclosure only occurs upon exiting the initial
# (un-nested) user's command-line call.
assign("sqrl", eval(parse(text = paste0("function(...) {SqrlDelegate(\"",
datasource, "\", base::parent.frame(), base::list(...))}"),
keep.source = FALSE)), sqrl.env)
}
# Assign any supplied parameters to the processing environment. The supplied
# parameter names might not be unique, in which case the last value applies.
for (i in seq_along(params))
{
# When a parameter is called 'args', and is a non-empty list within which
# every member has a legitimate R-variable name, then individiually assign
# each of its members into the processing environment (rather than assigning
# the whole list, 'args', as a single object).
if ((names(params)[i] == "args")
&& identical(class(params[[i]]), class(list()))
&& (length(params[[i]]) > 0L)
&& (!is.null(names(params[[i]])))
&& (all(names(params[[i]]) == make.names(names(params[[i]])))))
{
for (j in seq_along(params[[i]]))
{
assign(names(params[[i]])[j], params[[i]][[j]], sqrl.env)
}
# Otherwise, assign the named object to the processing environment.
} else
{
assign(names(params)[i], params[[i]], sqrl.env)
}
}
# Default result. The result is a list of two components; value and visible,
# as per withVisible(). This function will return the last non-empty value.
result <- withVisible(invisible(character(0L)))
# The SQL statement in progress (the script may contain multiple statements).
statement <- list()
# A stack, upon which to store (while) loop return (start) points.
loop.points <- integer()
# A stack, upon which to store the results of nested conditionals.
cond.stack <- logical()
# Result of evaluating the last (innermost nested) condition.
cond.current <- TRUE
# A stack, upon which to store whether or not any of the previous alternative
# conditions within an if, else if, else structure have yet evaluated to TRUE.
else.stack <- logical()
# Initialise the procedural language extension tracker.
pl <- SqrlPL(NULL)
# Delimiter counter/index (to pos, pat, and len). Range is [1 : num.delims].
i <- 1L
# Character counter/index (to script). Range is [1 : nchar.script].
k <- 1L
# Parse the script, submit SQL, evaluate and substitute R.
while (i <= num.delims)
{
# Remove comments from SQL (both to-end-of-line and block).
# The main reason for this, is that some data sources are (have been) known
# to reject queries with more than one block of comments at the beginning.
# A second reason is that RODBC's error messages may include the submitted
# script, which is easier to read if we've cleaned it up. The flip side is
# that our parsing (rather than the source's) had better get things right.
if ((i <= num.delims)
&& (pat[i] %in% c("comment.line", "comment.begin")))
{
# Append any preceding fragment to the script, unless within the block of
# an untrue conditional expression.
if (cond.current)
{
# Isolate unappended (to the statement) script preceding this comment.
phrase <- substring(script, k, pos[i] - 1L)
# Remove trailing whitespace (including vertical) from the phrase.
# (Only before to-end-of-line comments.)
if (pat[i] == "comment.line")
{
phrase <- sub("[[:space:]]*$", "", phrase)
}
# Remove trailing whitespace from each internal line of the phrase.
phrase <- gsub("[[:blank:]]+\n", "\n", phrase)
# Remove vertical whitespace from within the phrase.
phrase <- gsub("\n+", "\n", phrase)
# Update the procedural-language state tracker.
pl <- SqrlPL(pl, phrase)
# Append the phrase to the statement (unless the phrase is empty).
# This is an error when the script is meant to define a library.
if (nchar(phrase) > 0L)
{
statement <- append(statement, phrase)
}
}
# Scan through the subsequent script delimiters, until the comment
# concludes with either an end-of-file, or appropriate delimiter.
end.marker <- switch(pat[i],
comment.line = "end.of.line",
comment.begin = "comment.end")
i <- i + 1L
while ((i <= num.delims)
&& (pat[i] != end.marker))
{
i <- i + 1L
}
# Reposition the start-of-phrase index immediately after the end of the
# comment. When the comment ends with a newline, the index is placed on
# that newline (so that the next phrase will begin with the newline).
k <- if (i <= num.delims) {
if (end.marker == "end.of.line") {pos[i]} else {pos[i] + len[i]}
} else {nchar.script + 1L}
# Advance to the next script delimiter.
i <- i + 1L
}
# Incorporate (single & double) quote-enclosed strings verbatim within SQL.
# That is; ignore anything that looks like a delimiter, but is in a string.
if ((i <= num.delims)
&& (pat[i] %in% c("quote.single", "quote.double")))
{
# Append any preceding fragment to the script, unless within the block of
# an untrue conditional expression.
if (cond.current)
{
# Isolate unappended (to the statement) script preceding this string.
phrase <- substring(script, k, pos[i] - 1L)
# Remove trailing whitespace from each internal line of the phrase.
phrase <- gsub("[[:blank:]]+\n", "\n", phrase)
# Remove vertical whitespace from within the phrase.
phrase <- gsub("\n+", "\n", phrase)
# Update the procedural-language state tracker.
pl <- SqrlPL(pl, phrase)
# Append the phrase to the statement (unless the phrase is empty).
if (nchar(phrase) > 0L)
{
statement <- append(statement, phrase)
}
}
# Reposition the start-of-phrase index on (including) the beginning quote.
k <- pos[i]
# Scan through the subsequent script delimiters, until the string
# concludes with either an end-of-file, or matching quote delimiter.
# We only test for \ escaped quotes here (once already in quote mode,
# which also guarantees i > 1). Some SQLs use doubled quotes within quoted
# strings to represent quote literals. This is supported here, via the
# following mechanism: 'x''' is read as two adjacent strings, 'x' and '',
# which are eventually collapsed together (with an empty string between),
# restoring the original 'x''' in the final SQL statement (string).
closing.quote <- pat[i]
i <- i + 1L
while ((i <= num.delims)
&& ((pat[i] != closing.quote)
|| ((attr(regexpr(
paste0("\\\\*", patterns[closing.quote], "$"),
substring(script, pos[i - 1L], pos[i])),
"match.length") %% 2L) == 0L)))
{
i <- i + 1L
}
# Append the quoted string to the statement. Verbatim, quotes included.
# Unless within the block of an untrue conditional expression.
if (cond.current)
{
statement <- append(statement, if (i <= num.delims) {
substring(script, k, pos[i])
} else {substring(script, k)})
}
# Position the start-of-phrase index immediately after the closing quote.
k <- if (i <= num.delims) {pos[i] + len[i]} else {nchar.script + 1L}
# Advance to the next script delimiter.
i <- i + 1L
}
# Ignore remainder of script when encountering a 'stop' tag within SQL.
# The 'stop' tag is mainly used to run partial scripts while bug hunting.
if ((i <= num.delims)
&& (pat[i] == "tag.stop"))
{
if (cond.current)
{
# Isolate any unappended (to the statement) script preceding this stop.
phrase <- substring(script, k, pos[i] - 1L)
# Remove trailing whitespace (including vertical) from the phrase.
phrase <- sub("[[:space:]]*$", "", phrase)
# Remove trailing whitespace from each internal line of the phrase.
phrase <- gsub("[[:blank:]]+\n", "\n", phrase)
# Remove vertical whitespace from within the phrase.
phrase <- gsub("\n+", "\n", phrase)
# Update the procedural-language state tracker.
pl <- SqrlPL(pl, phrase)
# Append the phrase to the statement (unless the phrase is empty).
if (nchar(phrase) > 0L)
{
statement <- append(statement, phrase)
}
}
# Advance the delimiter and phrase indices beyond the end of the script.
# Break immediately (unnecessary). Statement will be submitted afterwards.
# Note that stop tags apply even inside untrue conditional blocks.
i <- num.delims + 1L
k <- nchar.script + 1L
break
}
# Transfer procedure definitions into either the permanent (source
# parameter) or temporary (working stack) library, without modification.
if ((i <= num.delims)
&& (pat[i] == "tag.proc"))
{
# Position of the character immediately before this potential proc tag. If
# it turns out to be an actual proc tag, then this position is needed to
# check for unsubmitted SQL.
k.prime <- pos[i] - 1L
# If this really is a proc tag, there must be nothing but horizontal
# whitespace between the matched pattern and a quotation mark (single or
# double). Since horizontal whitespace is not a matched pattern, that
# quote mark must be the next matched pattern. If it's not, then this is
# not a proc tag after all (is just SQL), and we continue with the next.
i <- i + 1L
if ((i > num.delims)
|| !(pat[i] %in% c("quote.single", "quote.double"))
|| !grepl("^[[:blank:]]*$",
substring(script, pos[i - 1L] + len[i - 1L], pos[i] - 1L)))
{
next
}
# Scan through the subsequent script delimiters, until the string
# concludes with a matching quote delimiter, or we reach the end of the
# file. We only test for \ escaped quotes on the inside of the string.
j <- i
i <- i + 1L
while ((i <= num.delims)
&& ((pat[i] != pat[j])
|| ((attr(regexpr(paste0("\\\\*", patterns[pat[j]], "$"),
substring(script, pos[i - 1L], pos[i])),
"match.length") %% 2L) == 0L)))
{
i <- i + 1L
}
# Stop if the end of the (procedure name) string was not found.
if ((i > num.delims)
|| (pat[i] != pat[j]))
{
stop("Unterminated procedure name.")
}
# Stop if the character immediately after the (name string) closing quote
# is not a (tag-closing) angle bracket ('>').
if (substring(script, pos[i] + 1L, pos[i] + 1L) != ">")
{
stop("Badly formatted proc tag (improperly terminated).")
}
# Stop if there's any unsubmitted SQL before the proc tag.
if (any(grepl("[[:graph:]]", unlist(statement)))
|| any(grepl("[[:graph:]]", substring(script, k, k.prime))))
{
if (libmode)
{
stop("Text outside of a procedure definition.")
}
stop("Unsubmitted SQL preceding a procedure definition.")
}
# Extract the name of the procedure.
proc.name <- substring(script, pos[j] + len[j], pos[i] - 1L)
# Ensure the proc name is not empty or blank, and does not contain any
# control characters (new line, carriage return, tab, vertical tab, etc.)
if (!grepl("[[:graph:]]", proc.name)
|| grepl("[[:cntrl:]]", proc.name))
{
stop("Invalid procedure name.")
}
# We have found one proc tag within a SQL section (not within an R block).
nproc <- 1L
rblock <- FALSE
# Reposition the start-of-phrase index immediately after the proc tag.
k <- pos[i] + 2L
# Scan the procedure definition (stepping by delimiter), to find its end.
while ((i <= num.delims)
&& (nproc > 0L))
{
# Advance to the next delimiter.
i <- i + 1L
# The end of the script concludes the definition, as does a stop tag.
if ((i > num.delims)
|| (pat[i] == "tag.stop"))
{
break
}
# Ignore delimiters within comments (advance to the end of the comment).
if (pat[i] %in% c("comment.line", "comment.begin"))
{
end.marker <- switch(pat[i],
comment.line = "end.of.line",
comment.begin = "comment.end")
i <- i + 1L
while ((i <= num.delims)
&& (pat[i] != end.marker))
{
i <- i + 1L
}
# Ignore delimiters within R comments (only when within an R section).
} else if (rblock
&& (pat[i] == "comment.r"))
{
i <- i + 1L
while ((i <= num.delims)
&& (pat[i] != "end.of.line"))
{
i <- i + 1L
}
# Ignore delimiters within quotes (advance to the end of the quote).
} else if (pat[i] %in% c("quote.single", "quote.double"))
{
closing.quote <- pat[i]
i <- i + 1L
while ((i <= num.delims)
&& ((pat[i] != closing.quote)
|| ((attr(regexpr(
paste0("\\\\*", patterns[closing.quote], "$"),
substring(script, pos[i - 1L], pos[i])),
"match.length") %% 2L) == 0L)))
{
i <- i + 1L
}
# R sections begin with either an <R> or <result> tag.
} else if ((i <= num.delims)
&& (pat[i] %in% c("tag.r", "tag.result")))
{
rblock <- TRUE
# R sections are terminated by </R> or <do> tags (revert to SQL).
} else if (rblock
&& (pat[i] %in% c("tag.endr", "tag.do")))
{
rblock <- FALSE
# R sections are also terminated by an extra semicolon (revert to SQL).
} else if (rblock
&& (pat[i] == "semi.colon")
&& (pat[i - 1L] %in% c("end.of.line", "semi.colon"))
&& !grepl("[[:graph:]]",
substring(script,
pos[i - 1L] + len[i - 1L],
pos[i] - 1L)))
{
rblock <- FALSE
# Upon meeting an end-of-procedure tag, decrement the nested-procedures
# counter. These tags are recognised both within SQL and R sections, and
# terminate the later (reverting to SQL).
} else if (pat[i] == "tag.endproc")
{
nproc <- nproc - 1L
rblock <- FALSE
# Upon meeting a start-of-procedure tag within a SQL section, increment
# the nested-procedure counter. These tags are not recognised within R,
# for consistency with the primary (extra-procedural) R-block parser
# (below). That parser does not recognise </proc> tags either (which we
# do here), but it is not applied within an open procedural definition.
} else if (!rblock
&& (pat[i] == "tag.proc")
&& (pat[i + 1L] %in% c("quote.single", "quote.double"))
&& grepl("^[[:blank:]]*$",
substring(script, pos[i] + len[i], pos[i + 1L] - 1L)))
{
closing.quote <- pat[i + 1L]
j <- i + 1L
i <- i + 2L
while ((i <= num.delims)
&& ((pat[i] != closing.quote)
|| ((attr(regexpr(
paste0("\\\\*", patterns[closing.quote], "$"),
substring(script, pos[i - 1L], pos[i])),
"match.length") %% 2L) == 0L)))
{
i <- i + 1L
}
if (i <= num.delims)
{
pname <- substring(script, pos[j] + len[j], pos[i] - 1L)
if (grepl("[[:graph:]]", pname)
&& !grepl("[[:cntrl:]]", pname)
&& substring(script, pos[i] + 1L, pos[i] + 1L) == ">")
{
nproc <- nproc + 1L
}
}
}
}
# If no closing tag was found, the procedure ends with the script. Extract
# the procedure, and move the start-of-phrase index beyond the end of the
# script (indicating there's no unprocessed script remaining).
if (i > num.delims)
{
proc.body <- substring(script, k, nchar.script)
k <- nchar.script + 1L
# Otherwise, the definition of the procedure ends immediately before the
# closing tag (that was found). Extract the procedure, up to the tag.
} else
{
proc.body <- substring(script, k, pos[i] - 1L)
# If the definition was terminated by a stop tag, then ignore the rest
# of the script (move the delimiter and phrase indices beyond its end).
if (pat[i] == "tag.stop")
{
i <- num.delims + 1L
k <- nchar.script + 1L
# Otherwise, the definition was terminated by an end-of-procedure tag.
# Advance the start-of-phrase index to the character after that tag.
} else
{
k <- pos[i] + len[i]
}
}
# Remove leading and trailing whitespace from the procedure. If it
# originally contained one or more trailing newlines, restore one.
tnl <- grepl("\\n[[:space:]]*$", proc.body)
proc.body <- trimws(proc.body)
if (tnl)
{
proc.body <- paste0(proc.body, "\n")
}
# It is possible, outside of library mode, that the procedure definition
# might appear within the block of an untrue conditional, in which case it
# should not be added to the stack.
if (cond.current)
{
# Apply the name to the procedure.
names(proc.body) <- proc.name
# Add the procedure to either the library or the stack. This operation
# requires the use of override = TRUE.
if (libmode)
{
SqrlParam(datasource, "library", proc.body, override = TRUE)
} else
{
SqrlParam(datasource, "libstack", proc.body, override = TRUE)
}
# If verbose, advise the user of the addition.
if (interactive()
&& SqrlParam(datasource, "verbose"))
{
cat("\n")
if (libmode)
{
cat(paste0("Added '", proc.name, "' to the library:\n"))
} else
{
cat(paste0("Defined procedure '", proc.name, "':\n"))
}
cat(proc.body)
cat("\n")
}
}
# Advance to the next script delimiter.
i <- i + 1L
}
# Submit the statement (and retrieve the result) on encountering a 'do' tag
# within SQL.
if ((i <= num.delims)
&& (pat[i] == "tag.do"))
{
# Prohibit query-submission in library mode.
if (libmode)
{
stop("Text outside of a procedure definition.")
}
# Submit the statement, plus any unappended fragment, unless it is within
# the block of an untrue conditional expression.
if (cond.current)
{
# Isolate any unappended (to the statement) script preceding the tag.
phrase <- substring(script, k, pos[i] - 1L)
# Submit the statement (with phrase) and pull the result.
dat <- withVisible(SqrlSubScript(datasource, statement, phrase))
# If there was a result (there was a query), replace the overall result.
if (!is.null(dat$value))
{
result <- dat
}
# Reset the statement (begin the next one afresh).
statement <- list()
# Reset the procedural-language state tracker.
pl <- SqrlPL(NULL)
}
# Reposition the start-of-phrase index immediately after the tag.
k <- pos[i] + len[i]
# Advance to the next script delimiter.
i <- i + 1L
}
# Act upon a semicolon, encountered within SQL. Dependent upon the current
# situation, either submit a query or do nothing.
if ((i <= num.delims)
&& (pat[i] == "semi.colon"))
{
# Prohibit query-submission in library mode.
if (libmode)
{
stop("Text outside of a procedure definition.")
}
# Consider the posibility this semicolon might termintate a complete
# query, only when the scdo parameter is TRUE.
if (SqrlParam(datasource, "scdo"))
{
# Assess the nature of the semicolon, unless it is within the block of
# an untrue conditional expression
if (cond.current)
{
# Isolate any unappended (to the statement) script; up to, and
# including, the semicolon.
phrase <- substring(script, k, pos[i] + len[i] - 1L)
# Remove trailing whitespace from each internal line of the phrase.
phrase <- gsub("[[:blank:]]+\n", "\n", phrase)
# Remove vertical whitespace from within the phrase.
phrase <- gsub("\n+", "\n", phrase)
# Update the procedural-language state tracker.
pl <- SqrlPL(pl, phrase)
# Append the phrase here, to avoid running it through the state
# tracker a second time, if no query is submitted below. The phrase
# can't be empty, because it ends with the semicolon.
statement <- append(statement, phrase)
# The semicolon is considered to terminate a complete SQL statement,
# if we're not in a PL block, or if the PL block has ended. When such
# is the case, a query could be submitted (it might not be, just yet).
if (!pl$block
|| ((pl$begins > 0L)
&& (pl$ends >= pl$begins)))
{
# The terminal semicolon will be treated a do tag (the query will be
# submitted, unless there's nothing but whitespace between it and a
# subsequent do or result tag.
do <- TRUE
if (i < num.delims)
{
j <- which(pat %in% c("tag.do", "tag.result"))
if (any(j > i))
{
j <- min(j[j > i])
do <- !grepl("^[[:space:]]*$",
substring(script, pos[i] + len[i], pos[j] - 1L))
}
}
# When the semicolon is not followed by a do or result tag, submit
# query and retrieve the result.
if (do)
{
# Submit the statement, and pull the result. There ought to be
# something, because the query at least contains the semicolon.
result <- withVisible(SqrlSubScript(datasource, statement))
# Reset the statement (begin the next one afresh).
statement <- list()
# Reset the procedural-language state tracker.
pl <- SqrlPL(NULL)
}
}
}
# Reposition the start-of-phrase index immediately after the marker.
k <- pos[i] + len[i]
}
# Advance to the next script delimiter, whether or not scdo is TRUE, and
# whether or not any query was submitted.
i <- i + 1L
}
# Act upon condition end and else tags, encountered within SQL.
if ((i <= num.delims)
&& (pat[i] %in% c("tag.endif", "tag.endwhile", "tag.else")))
{
# Prohibit R-execution (potential query-submission) in library mode.
if (libmode)
{
stop("Text outside of a procedure definition.")
}
# Remember the type of tag we've encountered.
pat.type = pat[i]
# Throw an exception if we're ending a loop that was never started.
if ((pat.type == "tag.endwhile")
&& cond.current
&& (length(loop.points) < 1L))
{
stop("End without while.")
}
# Throw an exception if we're ending a block that was never started.
if ((pat.type == "tag.endif")
&& length(cond.stack) < 1L)
{
stop("End without if.")
}
# Throw an exception if we've met an else but not a previous if.
if ((pat.type == "tag.else")
&& (length(else.stack) < 1L))
{
stop("Else without if.")
}
# Append any preceding fragment to the statement, unless ending (within)
# the block of an untrue conditional expression.
if (cond.current)
{
# Isolate any unappended (to the statement) script preceding this end.
phrase <- substring(script, k, pos[i] - 1L)
# Remove trailing whitespace (including vertical) from the phrase.
phrase <- sub("[[:space:]]*$", "", phrase)
# Remove trailing whitespace from each internal line of the phrase.
phrase <- gsub("[[:blank:]]+\n", "\n", phrase)
# Remove vertical whitespace from within the phrase.
phrase <- gsub("\n+", "\n", phrase)
# Update the procedural-language state tracker.
pl <- SqrlPL(pl, phrase)
# Append the phrase to the statement (unless the phrase is empty).
if (nchar(phrase) > 0L)
{
statement <- append(statement, phrase)
}
}
# If we've reached the end of an active loop, pop the loop starting index
# from the loop stack, and return to that point of the script.
if ((pat.type == "tag.endwhile")
&& cond.current)
{
i <- loop.points[length(loop.points)]
loop.points <- loop.points[-length(loop.points)]
k <- pos[i]
# Otherwise, we've reached an else, the end of a (TRUE OR FALSE) if block,
# or the end of an inactive (FALSE while) loop. Continue past the tag.
} else
{
# Reposition the start-of-phrase index immediately after the end tag.
k <- pos[i] + len[i]
# Advance to the next script delimiter.
i <- i + 1L
}
# In the case of an else tag, the condition becomes TRUE if all encasing
# conditionals are TRUE (so the else lies within an active block) and all
# previous alternatives (the parent if, and any else ifs) have evaluated
# FALSE (so none of them have already applied).
if (pat.type == "tag.else")
{
# Locate (grab the index of) the current (last) else stack entry.
es <- length(else.stack)
# The current condition becomes TRUE if all encasing conditionals are
# TRUE (so the else belongs to an if-else structure that lies within an
# active outer block) and all previous alternatives (the parent if, and
# any else ifs) have evaluated FALSE (so none of those conditions has
# already applied).
new.cond <- (!else.stack[es]) && all(cond.stack)
cond.current <- new.cond
# The else condition becomes (or is) TRUE if the new condition is TRUE
# (for this alternative) or if any previous else condition (alternative)
# has already been TRUE.
else.stack[es] <- new.cond || else.stack[es]
# Otherwise, in the case of an end tag, pop (restore) the previous
# (encasing) condition from the stack.
} else
{
cond.current <- cond.stack[length(cond.stack)]
cond.stack <- cond.stack[-length(cond.stack)]
}
# In the case of ending an if, remove the current (last) entry from the
# else stack (all alternatives having been exhausted).
if (pat.type == "tag.endif")
{
else.stack <- else.stack[-length(else.stack)]
}
}
# Act upon an if, else-if, while or return tag, encountered within SQL.
if ((i <= num.delims)
&& (pat[i] %in% c("tag.if", "tag.elseif", "tag.while", "tag.return")))
{
# Prohibit R-execution (potential query-submission) in library mode.
if (libmode)
{
stop("Text outside of a procedure definition.")
}
# Remember which type of tag we've encountered, and where we found it.
tag.type <- pat[i]
tag.pos <- i
# Abort on else-if without prior if (avoids an uncontrolled error later).
if ((tag.type == "tag.elseif")
&& (length(else.stack) < 1L))
{
stop("Else-if without if.")
}
# Append any preceding fragment to the statement, unless within the block
# of an untrue conditional expression.
if (cond.current)
{
# Isolate any unappended (to the statement) script preceding this end.
phrase <- substring(script, k, pos[i] - 1L)
# Remove trailing whitespace from each internal line of the phrase.
phrase <- gsub("[[:blank:]]+\n", "\n", phrase)
# Remove vertical whitespace from within the phrase.
phrase <- gsub("\n+", "\n", phrase)
# Update the procedural-language state tracker.
pl <- SqrlPL(pl, phrase)
# Append the phrase to the statement (unless the phrase is empty).
if (nchar(phrase) > 0L)
{
statement <- append(statement, phrase)
}
}
# Advance the start-of-phrase index to the opening expression parenthesis
# (that being the last character of the tag).
k <- pos[i] + len[i] - 1L
# Counters for the number of left and right parentheses within the phrase.
# We don't check the ordering of the parentheses.
lpar <- 0L
rpar <- 0L
# Have not yet located the end (closing parenthesis) of the expression.
complete <- FALSE
# Remove any comments within the R expression (both R and SQL). Because
# this involves parsing (to find the end of the section), we need to work
# through this even when cond.current is FALSE.
rscript <- list()
i <- i + 1L
while (i <= num.delims)
{
# Remove comments from R (including SQL line and block comments).
# This is so we can use SQL comments within the R (looks better under
# SQL syntax highlighting rules within your text editor), and is also
# necessary to allow commenting out of quote markers, <do>, <stop>, and
# </R> tags with R comments (as well as SQL).
if ((i <= num.delims)
&& (pat[i] %in% c("comment.line", "comment.begin", "comment.r")))
{
# Isolate any unappended script preceding this comment, and append it
# to the R-script.
fragment <- substring(script, k, pos[i] - 1L)
rscript <- append(rscript, fragment)
# Count the number of left and right parentheses within the fragment.
lpar <- lpar + nchar(gsub("[^(]", "", fragment))
rpar <- rpar + nchar(gsub("[^)]", "", fragment))
# Scan through the subsequent script delimiters, until the comment
# concludes with either an end-of-file, or appropriate delimiter.
end.marker <- switch(pat[i],
comment.r = "end.of.line",
comment.line = "end.of.line",
comment.begin = "comment.end")
i <- i + 1L
while ((i <= num.delims)
&& (pat[i] != end.marker))
{
i <- i + 1L
}
# Reposition the start-of-phrase index immediately after the end of
# the comment. When the comment ends with a newline, the index is
# placed on that newline (the next phrase will begin with newline).
k <- if (i <= num.delims) {
if (end.marker == "end.of.line") {pos[i]} else {pos[i] + len[i]}
} else {nchar.script + 1L}
}
# Skip over (single, double) quote-enclosed strings (include verbatim).
# (Ignore anything that looks like a delimiter, but is inside a string.)
if ((i <= num.delims)
&& (pat[i] %in% c("quote.single", "quote.double")))
{
# Isolate any unappended script preceding this string literal, and
# append it to the R-script.
fragment <- substring(script, k, pos[i] - 1L)
rscript <- append(rscript, fragment)
# Count the number of left and right parentheses within the fragment.
lpar <- lpar + nchar(gsub("[^(]", "", fragment))
rpar <- rpar + nchar(gsub("[^)]", "", fragment))
# Reposition the start-of-phrase index on top of the opening quote.
k <- pos[i]
# Scan through the script delimiters until reaching the end of the
# quote (ignore all other delimiters found in between). We only test
# for \ escaped quotes here (once already within quote mode, which
# also guarantees that i > 1).
closing.quote <- pat[i]
i <- i + 1L
while ((i <= num.delims)
&& ((pat[i] != closing.quote)
|| ((attr(regexpr(
paste0("\\\\*", patterns[closing.quote], "$"),
substring(script, pos[i - 1L], pos[i])),
"match.length") %% 2L) == 0L)))
{
i <- i + 1L
}
# Append the quoted string literal to the R-script, without counting
# any parentheses that may appear within it.
rscript <- append(rscript, if (i <= num.delims) {
substring(script, k, pos[i])
} else {substring(script, k)})
# Position the start-of-phrase index just after the closing quote.
k <- if (i <= num.delims) {pos[i] + len[i]} else {nchar.script + 1L}
}
# Upon finding an end-of-expression marker, establish whether or not it
# terminates the expression. If not, keep looking. If so, evaluate it.
if ((i <= num.delims)
&& (pat[i] == "end.expression"))
{
# Extract any un-appended fragment preceding (and including) the right
# parenthesis (first character) of the end.expression sequence to the
# expression (R-script).
fragment <- substring(script, k, pos[i])
rscript <- append(rscript, fragment)
# Count the numbers of left and right parentheses within the fragment.
lpar <- lpar + nchar(gsub("[^(]", "", fragment))
rpar <- rpar + nchar(gsub("[^)]", "", fragment))
# Reposition the start-of-phrase index immediately after the right
# parenthesis (first character) of the end.expression sequence.
k <- pos[i] + 1L
# When we have equal numbers of left and right parentheses (both being
# at least one), we consider the expression to be complete and attempt
# to evaluate it. We don't check for correct parenthesis ordering.
if (lpar <= rpar)
{
# The complete expression has been identified and isolated.
complete <- TRUE
# In the case of a first conditional tag (not an else-if), push the
# current conditional mode (cond.current) to the condition stack.
if (!(tag.type %in% c("tag.elseif", "tag.return")))
{
cond.stack <- c(cond.stack, cond.current)
}
# The expression must be evaluated, to determine the condition of
# the upcoming nested block, if this is a leading (if, while, or
# return) conditional and the current condition is TRUE, or if this
# is an alternative condition (else-if), no previous alternative has
# been TRUE (i.e., the current else state is FALSE), and the entire
# conditional stack (which does not include the current condition)
# is TRUE (i.e., we are within an active block of script).
if ((cond.current && (tag.type != "tag.elseif"))
|| ((tag.type == "tag.elseif")
&& !else.stack[length(else.stack)]
&& all(cond.stack)))
{
# Collapse the expression (fragments) and remove the enclosing
# parentheses (in case it contains multiple statements).
cond <- paste0(rscript, collapse = "")
expr <- substring(cond, 2L, nchar(cond) - 1L)
# Evaluate the tag expression. On error, stop with exception.
tval <- SqrlTry(withVisible(eval(
parse(text = expr, keep.source = FALSE),
sqrl.env)))
if (tval$error)
{
stop(tval$value)
}
tval <- tval$value
# In the case of a return tag, return the evaluated expression
# (stop processing the SQRL script, and exit from this point).
# That exit is an exception, if any unsubmitted SQL exists.
if (tag.type == "tag.return")
{
if (any(grepl("[[:graph:]]", unlist(statement))))
{
stop("Unsubmitted SQL preceding a <return> tag.")
}
if (tval$visible)
{
return(tval$value)
}
return(invisible(tval$value))
}
# Otherwise, the expression should be a logical condition,
# replacing the previous condition.
cond.current <- tval$value
# If in verbose mode, output the expression and its evaluation.
if (interactive()
&& SqrlParam(datasource, "verbose"))
{
cat("\n")
cat(paste(trimws(cond), "is", cond.current))
cat("\n")
}
# We require expressions to evaluate to Boolean singletons.
if (!is.logical(cond.current)
|| (length(cond.current) != 1L)
|| is.na(cond.current))
{
stop("Condition neither TRUE nor FALSE.")
}
# If this was a while condition, and if that condition was TRUE,
# then the loop is active and we push its starting location to the
# loop (return point) stack.
if ((tag.type == "tag.while")
&& cond.current)
{
loop.points <- c(loop.points, tag.pos)
}
# If the tag is an else-if, update the current else condition. To
# have arrived at this point with an else-if tag, the current else
# condition must be FALSE. FALSE && cond.current is cond.current.
if ((tag.type == "tag.elseif")
&& cond.current)
{
else.stack[length(else.stack)] <- cond.current
}
# Otherwise, when an encasing conditional is untrue, do not evaluate
# the expression (variables may be undefined). Instead, continue in
# untrue mode until reaching the end of the encasing block. In the
# case of a return tag within an untrue block, perform no action.
} else if (tag.type != "tag.return")
{
cond.current <- FALSE
}
# In the case of an if, copy the current condition onto the else
# stack, for any alternative (else-if, else) blocks to reference.
if (tag.type == "tag.if")
{
else.stack <- c(else.stack, cond.current)
}
# Reposition the start-of-phrase index immediately after the
# terminating (expression closing) tag.
k <- pos[i] + len[i]
# Advance to the next script delimiter.
i <- i + 1L
# Having processed the conditional tag, continue with the script.
break
}
}
# Advance to the next script delimiter.
i <- i + 1L
}
# Throw an exception if we run out of script without ever finding the end
# of the intra-tag expression.
if (!complete)
{
stop("Unterminated intra-tag expression.")
}
}
# Evaluate embedded R (and insert into SQL or produce a result).
if ((i <= num.delims)
&& pat[i] %in% c("tag.r", "tag.result"))
{
# Prohibit R-execution (potential query-submission) in library mode.
if (libmode)
{
stop("Text outside of a procedure definition.")
}
# Remember the mode we're in (either embedded or post-processing).
r.type <- pat[i]
# Process any preceding fragment, unless within the block of an untrue
# conditional expression.
if (cond.current)
{
# Isolate any unappended (to the statement) script preceding this tag.
phrase <- substring(script, k, pos[i] - 1L)
# If this is R post-processing, submit any query beforehand.
if (r.type == "tag.result")
{
# Extract the name of the intermediate variable to which the SQL
# result is to be assigned within the R processing environment.
intermediate <- gsub("^<result\\s*->\\s*|>$", "",
substring(script, pos[i], pos[i] + len[i] - 1L))
# Submit the statement (with phrase) and pull the result.
dat <- withVisible(SqrlSubScript(datasource, statement, phrase,
intermediate, sqrl.env))
# If there was a result (was a query), use it as the overall result.
if (!is.null(dat$value))
{
result <- dat
}
# Reset the statement (begin the next one afresh).
statement <- list()
# Reset the procedural-language state tracker.
pl <- SqrlPL(NULL)
# Otherwise (this is an R substitution into SQL), clean the phrase (but
# do not remove pre-tag trailing whitespace) and then append it to the
# statement. The phrase will never contain a string literal.
} else
{
# Remove trailing whitespace from each internal line of the phrase.
phrase <- gsub("[[:blank:]]+\n", "\n", phrase)
# Remove vertical whitespace from within the phrase.
phrase <- gsub("\n+", "\n", phrase)
# Update the procedural-language state tracker.
pl <- SqrlPL(pl, phrase)
# Append the phrase to the statement (unless the phrase is empty).
if (nchar(phrase) > 0L)
{
statement <- append(statement, phrase)
}
}
}
# Reposition the start-of-phrase index immediately after this tag.
k <- pos[i] + len[i]
# Isolate the R section. Because this involves parsing (to find the end of
# the section), we need to work through this, even when cond.current is
# FALSE.
rscript <- list()
i <- i + 1L
while ((i <= num.delims)
&& !(pat[i] %in% c("tag.endr", "tag.do")))
{
# Remove comments from R (including SQL line and block comments).
# This is so we can use SQL comments within the R (looks better under
# SQL syntax highlighting rules within your text editor), and is also
# necessary to allow commenting-out of quote markers, <do>, <stop>,
# and </R> tags with R comments (as well as SQL).
if ((i <= num.delims)
&& (pat[i] %in% c("comment.line", "comment.begin", "comment.r")))
{
# Isolate any unappended script preceding this comment, and append
# it to the R-script.
rscript <- append(rscript, substring(script, k, pos[i] - 1L))
# Scan through the subsequent script delimiters, until the comment
# concludes with either an end-of-file, or appropriate delimiter.
end.marker <- switch(pat[i],
comment.r = "end.of.line",
comment.line = "end.of.line",
comment.begin = "comment.end")
i <- i + 1L
while ((i <= num.delims)
&& (pat[i] != end.marker))
{
i <- i + 1L
}
# Reposition the start-of-phrase index immediately after the end of
# the comment. When the comment ends with a newline, the index is
# placed on that newline (the next phrase will begin with newline).
k <- if (i <= num.delims) {
if (end.marker == "end.of.line") {pos[i]} else {pos[i] + len[i]}
} else {nchar.script + 1L}
}
# Skip over any (single or double) quote-enclosed strings (include
# them verbatim). (Ignore anything that looks like a delimiter, but
# is inside a string.)
if ((i <= num.delims)
&& (pat[i] %in% c("quote.single", "quote.double")))
{
# Since we're not cleaning-up the R script, we merely scan through
# the script delimiters until reaching the end of the quote (ignore
# all other delimiters found in between). Appending to the R script
# will only occur later (at a comment, or an end-of-R delimiter). We
# only test for \ escaped quotes here (once already within quote mode,
# which also guarantees that i > 1).
closing.quote <- pat[i]
i <- i + 1L
while ((i <= num.delims)
&& ((pat[i] != closing.quote)
|| ((attr(regexpr(
paste0("\\\\*", patterns[closing.quote], "$"),
substring(script, pos[i - 1L], pos[i])),
"match.length") %% 2L) == 0L)))
{
i <- i + 1L
}
}
# Semicolons may delimit R statements, or mark the end of the R section.
if ((i <= num.delims)
&& (pat[i] == "semi.colon"))
{
# Provided scdo is TRUE, if there is nothing but whitespace between
# the semicolon and the start of its line (or the R tag, or the result
# tag, or the previous semicolon), then interpret the semicolon as a
# do tag (the R parser won't accept it, anyway), and stop looking for
# one. We need not append the whitespace to the R script.
if (grepl("^[[:space:]]*$", substring(script, k, pos[i] - 1L))
&& SqrlParam(datasource, "scdo"))
{
break
# Otherwise, the semicolon marks the end of an R statement. Append
# any unappended script, up to and including the semicolon, to the
# R-script. Advance the start-of-phrase index past the semicolon, and
# resume searching for the end of the R section.
} else
{
rscript <- append(rscript, substring(script, k, pos[i]))
k <- pos[i] + len[i]
}
}
# Ignore remainder of script when encountering a 'stop' tag within an
# R post-processing section.
if ((i <= num.delims)
&& (pat[i] == "tag.stop"))
{
# Append the last chunk of R (before the stop tag).
rscript <- append(rscript, substring(script, k, pos[i] - 1L))
# Ignore (skip over) everything else in the script.
i <- num.delims + 1L
k <- nchar.script + 1L
break
}
# We append each line, as we reach its end, to the R-script, only to
# simplify distinguishing R-section from R-statement semicolons.
if ((i <= num.delims)
&& (pat[i] == "end.of.line"))
{
# Append any preceding R (up to and including the line end).
rscript <- append(rscript, substring(script, k, pos[i]))
# Move the start of phrase index to the beginning of the next line.
k <- pos[i] + len[i]
}
# Advance to the next script delimiter.
i <- i + 1L
}
# Evaluate the R script, and process the result, unless within the block
# of an untrue conditional expression.
if (cond.current)
{
# Append the final chunk to the R-script.
phrase <- if (i <= num.delims) {
substring(script, k, pos[i] - 1L)
} else {substring(script, k)}
rscript <- append(rscript, phrase)
# Collapse the rscript (list) to a single string.
rscript <- trimws(paste(rscript, collapse = ""))
# In the case of embedded R, evaluate and append to the encasing SQL.
if ((r.type == "tag.r")
&& (i <= num.delims)
&& (pat[i] == "tag.endr"))
{
sqlisedvalue <- SqrlTry(SqrlStatement(datasource, list(eval(
parse(text = rscript, keep.source = FALSE), sqrl.env))))
if (sqlisedvalue$error)
{
stop(sqlisedvalue$value)
}
pl <- SqrlPL(pl, sqlisedvalue$value)
statement <- append(statement, sqlisedvalue$value)
# Otherwise (R post-processing), evaluate and retain the result.
} else
{
# Stop if there's any unsubmitted SQL before an <R> ... <do> section.
# (SQL is always submitted before a <result> ... <do> section.)
if (any(grepl("[[:graph:]]", unlist(statement))))
{
stop("Unsubmitted SQL preceding an <R> ... <do> section.")
}
# If in verbose mode, output the script (prior to evaluation).
if (interactive()
&& SqrlParam(datasource, "verbose"))
{
cat("\n")
cat(rscript)
cat("\n")
}
# Evaluate the script, and retain the result, only if the script is
# non-empty (in the sense of containing no uncommented statements).
parsed <- SqrlTry(parse(text = rscript, keep.source = FALSE))
if (parsed$error)
{
stop(parsed$value)
}
if (!identical(as.character(parsed$value), character(0L)))
{
# Evaluate the script, retain the result. As above, stop with an
# error should such occur.
result <- SqrlTry(withVisible(eval(parsed$value, sqrl.env)))
if (result$error)
{
stop(result$value)
}
result <- result$value
# If verbose, output (some of) the result. This could be any object,
# with no guarantee of either the head() or print() methods.
if (interactive()
&& SqrlParam(datasource, "verbose"))
{
printed <- FALSE
if ("package:utils" %in% search())
{
top <- SqrlTry(utils::head(result$value))
if (!top$error)
{
printed <- !SqrlTry(print(top$value))$error
if (printed
&& !identical(top$value, result$value))
{
cat("(output truncated)\n")
}
}
}
if (!printed)
{
cat(paste0("(object of class '",
paste0(class(result$value), collapse = " "),
"')\n"))
}
cat("\n")
}
}
}
}
# Reposition the start-of-phrase index immediately after this R section.
k <- if (i <= num.delims) {pos[i] + len[i]} else {nchar.script + 1L}
# Advance to the next script delimiter.
i <- i + 1L
}
# Assign temporary parameter values.
if ((i <= num.delims)
&& (pat[i] == "tag.with"))
{
# Prohibit changing RODBC and/or SQRL parameters in library mode.
if (libmode)
{
stop("Text outside of a procedure definition.")
}
# Stop if there's any unsubmitted SQL before the tag, unless within the
# block of an untrue conditional expression.
if ((cond.current)
&& any(grepl("[[:graph:]]", unlist(statement)))
|| any(grepl("[[:graph:]]", substring(script, k, pos[i] - 1L))))
{
stop("Unsubmitted SQL preceding a <with> block.")
}
# Reposition the start-of-phrase index immediately after the tag.
k <- pos[i] + len[i]
# Isolate the with section. This involves parsing (to find the end of the
# section), even when cond.current is FALSE.
withs <- list()
i <- i + 1L
while ((i <= num.delims)
&& !(pat[i] %in% c("tag.endwith", "tag.stop")))
{
# Remove SQL comments from the with block's R expressions.
if ((i <= num.delims)
&& (pat[i] %in% c("comment.line", "comment.begin")))
{
# Isolate any unappended script preceding this comment, and append
# it to the withs-script.
withs <- append(withs, substring(script, k, pos[i] - 1L))
# Scan through the subsequent script delimiters, until the comment
# concludes with either an end-of-file, or appropriate delimiter.
end.marker <- switch(pat[i],
comment.line = "end.of.line",
comment.begin = "comment.end")
i <- i + 1L
while ((i <= num.delims)
&& (pat[i] != end.marker))
{
i <- i + 1L
}
# Reposition the start-of-phrase index immediately after the end of
# the comment. When the comment ends with a newline, the index is
# placed on that newline (the next phrase will begin with newline).
k <- if (i <= num.delims) {
if (end.marker == "end.of.line") {pos[i]} else {pos[i] + len[i]}
} else {nchar.script + 1L}
}
# Skip over any (single or double) quote-enclosed strings (include
# them verbatim). (Ignore anything that looks like a delimiter, but
# is inside a string.)
if ((i <= num.delims)
&& (pat[i] %in% c("quote.single", "quote.double")))
{
# We only test for \ escaped quotes here (once already within quote
# mode, which also guarantees that i > 1).
closing.quote <- pat[i]
i <- i + 1L
while ((i <= num.delims)
&& ((pat[i] != closing.quote)
|| ((attr(regexpr(
paste0("\\\\*", patterns[closing.quote], "$"),
substring(script, pos[i - 1L], pos[i])),
"match.length") %% 2L) == 0L)))
{
i <- i + 1L
}
}
# Advance to the next script delimiter.
i <- i + 1L
}
# Process the withs script, unless within the block of an untrue
# conditional expression.
if (cond.current)
{
# Append the final chunk to the withs-script.
phrase <- if (i <= num.delims) {
substring(script, k, pos[i] - 1L)
} else {substring(script, k)}
withs <- append(withs, phrase)
# Collapse the withs-script (list) to a single string.
withs <- paste(withs, collapse = "\n")
# Attempt to parse the entire withs-script to an R expression.
# Expressions remain unevaluated at this point.
withs <- SqrlTry(parse(text = withs, keep.source = FALSE))
if (withs$error)
{
stop("Failed to parse <with> block.")
}
withs <- withs$value
# Create a sub-environment of the main-script working environment
# (sqrl.env), within which to evaluate expressions of the withs-script.
w.env <- new.env(parent = sqrl.env)
# Consistently apply the verbose mode in effect prior to the <with>
# block (whether or not the verbose value is changed within the block).
verbose <- interactive() && SqrlParam(datasource, "verbose")
# In verbose mode, add vertical whitespace before showing the values.
if (verbose)
{
cat("\n")
}
# Evaluate each item of the withs-script expression in turn.
for (w.itm in withs)
{
# Deparse this item's expression to text, wrap it in a list, and parse
# back to an expression. This ought to succeed, since the expression
# has been parsed before (as a part of the whole block, just above).
w.txt <- paste0(deparse(w.itm), collapse = "\n")
w.exp <- parse(text = paste0("list", "(", w.txt, ")"),
keep.source = FALSE)
# Evaluate the expression within the with-block sub-environment.
# Errors here are fatal. Warnings are visible.
w.val <- eval(w.exp, w.env)
# Any successful result must be a list. When that list comprises a
# single named member, we interpret it as an intended SQRL/RODBC
# parameter value.
if ((length(w.val) == 1L)
&& !is.null(names(w.val)))
{
w.par <- names(w.val)
if ((w.par %in% SqrlParams("locked-while-open"))
|| (w.par %in% SqrlParams("no-temp-allowed")))
{
stop("Parameter does not accept temporary values.")
}
# Allow temporary parameter values to be read from file.
if (!(w.par %in% SqrlParams("path-valued")))
{
w.val[[1L]] <- SqrlDefile(w.par, w.val[[1L]])
}
# Attempt to set the temporary parameter value.
SqrlParam(datasource, "pstack", w.val)
# If in verbose mode, print the temporary value.
if (verbose)
{
w.val <- deparse(SqrlParam(datasource, w.par))
cat("Using:", w.par, "=", w.val, "\n")
}
}
}
# In verbose mode, add vertical whitespace after showing the values.
if (verbose)
{
cat("\n")
}
}
# When the section ends with a stop tag, skip the rest of the script.
if ((i <= num.delims)
&& (pat[i] == "tag.stop"))
{
i <- num.delims + 1L
k <- nchar.script + 1L
break
}
# Reposition the start-of-phrase index immediately after this section.
k <- if (i <= num.delims) {pos[i] + len[i]} else {nchar.script + 1L}
# Advance to the next script delimiter.
i <- i + 1L
}
# Process a close tag, encountered within SQL.
if ((i <= num.delims)
&& (pat[i] == "tag.close"))
{
# Prohibit changing the connection status in library mode.
if (libmode)
{
stop("Text outside of a procedure definition.")
}
# Perform the closure action, unless within an untrue conditional block.
if (cond.current)
{
# Stop if there's any unsubmitted SQL before the close directive.
if (any(grepl("[[:graph:]]", unlist(statement)))
|| any(grepl("[[:graph:]]", substring(script, k, pos[i] - 1L))))
{
stop("Unsubmitted SQL preceding a <close> tag.")
}
# Close the channel to the source.
SqrlClose(datasource)
# If verbose, notify of the closure.
if (interactive()
&& SqrlParam(datasource, "verbose"))
{
cat("\nConnection channel closed.\n")
}
}
# Reposition the start-of-phrase index immediately after this tag.
k <- if (i <= num.delims) {pos[i] + len[i]} else {nchar.script + 1L}
# Advance to the next script delimiter.
i <- i + 1L
}
# Take no special action at any other delimiter: end-of-line, end-of-intra-
# tag-expression, intra-SQL R comment marker, SQL end-comment-block marker,
# end-of-procedure-definition, or end-of-intra-SQL-embedded-R. In all cases
# we assume this is legitimate SQL and proceed to the next delimiter. This
# assumption is highly probable for the first two, and highly unlikely for
# the last three. When the assumption is wrong, the ODBC driver will return
# an error. However, if we were to throw a potentially more helpful error
# here, we might be blocking a legitimate query without even trying it.
if ((i <= num.delims)
&& (pat[i] %in% c("end.of.line", "end.expression", "comment.r",
"comment.end", "tag.endproc", "tag.endr")))
{
i <- i + 1L
}
}
# Reaching this point means we are in a (possibly empty) SQL block, and there
# are no delimiters (patterns) between the start-of-phrase index, k, and the
# end of the script. It may even be that k is beyond the end of the script.
# Unless within the block of an untrue condition, append all (any) remaining
# (SQL) script to the current (SQL) statement.
if (cond.current)
{
statement <- append(statement, substring(script, k))
}
# Prohibit query-submission in library mode.
if (libmode
&& (any(grepl("[[:graph:]]", unlist(statement)))))
{
stop("Text outside of a procedure definition.")
}
# Submit the statement and pull the result. The statement might be blank or
# empty, in which case the result will be NULL.
dat <- withVisible(SqrlSubScript(datasource, statement))
# If there was a result (if there was a query), replace the overall result.
if (!is.null(dat$value))
{
result <- dat
}
# If the last result was invisible, return it invisibly.
if (!result$visible)
{
return(invisible(result$value))
}
# Otherwise, (visibly) return whatever the last result was.
return(result$value)
}
SqrlPath <- function(path)
{
# Determines whether or not the argument is a path to a readable file.
# Args:
# path : A possible file path, perhaps given as a list of components.
# Returns:
# The normalised file path, when ... appears to specify an existing file,
# or NULL, when ... does not appear to specify an existing file.
# SQRL Calls:
# SqrlTry().
# SQRL Callers:
# SqrlConfig(), SqrlDefile(), SqrlDelegate(), SqrlHelp(), SqrlSource().
# User:
# Has no direct access, but is able to supply arguments(s) indirectly, via
# SqrlDelegate(). Unexpected input is silently caught.
# Paste all arguments together.
path <- SqrlTry(paste0(unlist(path), collapse = ""), warn = FALSE)
# If pasting failed, the arguments must not specify a file (return NULL).
if (path$error)
{
return(NULL)
}
# If the path isn't a single string, it cannot specify a file (return NULL).
path <- path$value
if ((length(path) != 1L)
|| (nchar(path) < 1L))
{
return(NULL)
}
# If path actually does point to a readable file, return the (normalised)
# path. Note that files '.' and '..' exist as directories, and that file '"'
# exists but is not read accessible (the '4' tests for read access).
if (file.exists(path)
&& (file.access(path, 4L) == 0L)
&& !(file.info(path)$isdir))
{
return(normalizePath(path))
}
# The arguments do not appear to specify a file path. Return NULL.
return(NULL)
}
SqrlPing <- function(datasource,
set = FALSE)
{
# Sets and submits 'ping' queries for testing source connection channels.
# Args:
# datasource : The name of a known data source.
# set : Whether to set a ping query, or to ping the source with one.
# Returns:
# In set mode, the resulting ping query, as a character string. In ping
# mode, TRUE if the source responded (is connected to), FALSE otherwise.
# SQRL Calls:
# SqrlIndicator(), SqrlParam(), SqrlPing() (self), SqrlTry().
# RODBC Calls:
# odbcQuery(), sqlQuery().
# SQRL Callers:
# SqrlIsOpen(), SqrlOpen(), SqrlPing() (self).
# User:
# Has no direct access, and is unable to supply the arguments. No argument
# validity checking is required. The user can define the ping query itself.
# Restriction:
# This function assumes the existence of an RODBC channel handle for the
# data source. That is, the value of the 'channel' parameter must be an
# RODBC channel handle, rather than NULL. In set mode, the channel should be
# open, in ping mode it need not be (the connection could have been dropped
# from the other end). This function should only be called immediately after
# the existence of such a handle has been established (as SqrlisOpen() and
# SqrlOpen() both do).
# In set mode, attempt to find a 'ping' query that works with the data source.
if (set)
{
# Here, we define some 'pings', being very simple SQL statements. These are
# used to ping the data source; confirming we're still connected when we get
# the expected result back (or telling us we've lost the connection when we
# don't). These, alas, are vendor dependent, so we have to guess, trial, and
# see what works. Some vendor-independent method would be vastly preferable.
# Ping for MySQL, PostgreSQL, SQL Server, SQLite, Teradata.
p1 <- "select 1"
# Ping for Oracle, MySQL, DB2.
p2 <- "select 1 from dual"
# Ping for Oracle, DB2.
p3 <- "begin null; end;"
# Arrange the pings into best-guess-first order, according to the driver.
pings <- c(p1, p2, p3)
driver <- tolower(SqrlParam(datasource, "driver"))
if (grepl("oracle", driver, fixed = TRUE)
|| grepl("db2", driver, fixed = TRUE))
{
pings <- pings[c(3L, 2L, 1L)]
}
# Try each ping, in (driver-dependent) order of decreasing preference, until
# we find a ping that works (is valid SQL for the data source). These could
# also fail if the connection has been unexpectedly closed.
for (ping in pings)
{
SqrlParam(datasource, "ping", ping)
if (SqrlPing(datasource))
{
return(SqrlParam(datasource, "ping"))
}
}
# Did not find a ping that works. Set and return the empty string. This
# causes the pinging system to submit a junk query and scan the response for
# error terms that suggest a lost connection (not completely reliable).
return(SqrlParam(datasource, "ping", ""))
}
# In normal operation (not set mode), submit this query and see what happens.
ping <- SqrlParam(datasource, "ping")
# When we have a ping query, submit it to the driver and look for an error.
if (!is.null(ping)
&& nzchar(ping))
{
# If RODBC::odbcQuery() is available, that's our preferred method. According
# to the RODBC manual, it returns 1L on success, and -1L on failure, but is
# 'likely to be confined to the 'RODBC' namespace in the near future'.
if ("odbcQuery" %in% getNamespaceExports("RODBC"))
{
# Append ping-in-progress marker to the window-title connection indicator.
SqrlIndicator(datasource, "ping")
# Submit the ping query, and retrieve the status code (which takes either
# of two values: 1L for success, or -1L for failure).
s <- SqrlTry(RODBC::odbcQuery(
channel = SqrlParam(datasource, "channel"),
query = ping,
rows_at_time = SqrlParam(datasource, "rows_at_time")),
warn = FALSE)
# Remove ping-in-progress marker from the window-title indicator.
SqrlIndicator(datasource, "done")
# An error suggests the connection is closed; return FALSE.
# No error implies the connection is open; return TRUE.
return(!(s$error || (s$value == -1L)))
}
# Otherwise, use RODBC::sqlQuery(), with errors = FALSE, and as.is = TRUE.
# The as.is setting makes the result indifferent to most of the other
# parameter values. With errors = FALSE, the function returns integer -1 on
# failure, and something else otherwise (a character vector or data frame).
SqrlIndicator(datasource, "ping")
s <- SqrlTry(RODBC::sqlQuery(
channel = SqrlParam(datasource, "channel"),
query = ping,
errors = FALSE,
as.is = TRUE,
max = SqrlParam(datasource, "max"),
buffsize = SqrlParam(datasource, "buffsize"),
nullstring = SqrlParam(datasource, "nullstring"),
na.strings = SqrlParam(datasource, "na.strings"),
believeNRows = SqrlParam(datasource, "believeNRows"),
dec = SqrlParam(datasource, "dec"),
stringsAsFactors = FALSE,
rows_at_time = SqrlParam(datasource, "rows_at_time")),
warn = FALSE)
SqrlIndicator(datasource, "done")
return(!(s$error || identical(s$value, -1L)))
}
# In the absence of a ping query, submit a junk statement in an attempt to
# cause the driver to generate an error message that indicates whether or not
# that query was received by the source. This will not be completely reliable.
SqrlIndicator(datasource, "ping")
s <- SqrlTry(RODBC::sqlQuery(
channel = SqrlParam(datasource, "channel"),
query = "junk",
errors = TRUE,
as.is = TRUE,
max = SqrlParam(datasource, "max"),
buffsize = SqrlParam(datasource, "buffsize"),
nullstring = SqrlParam(datasource, "nullstring"),
na.strings = SqrlParam(datasource, "na.strings"),
believeNRows = SqrlParam(datasource, "believeNRows"),
dec = SqrlParam(datasource, "dec"),
stringsAsFactors = FALSE,
rows_at_time = SqrlParam(datasource, "rows_at_time")),
warn = FALSE)
SqrlIndicator(datasource, "done")
# The error message should be a character vector. If we got something else,
# take the connection to be closed (it probably is, but might not be).
if (s$error
|| !identical(class(s$value), class(character()))
|| (length(s$value) == 0L))
{
return(FALSE)
}
# If the error message appears to indicate a socket error or closed
# connection, assume that's the case (although we might be mistaken).
for (word in c("sock", "libc", "connection", "reset", "open", "closed"))
{
if (any(grepl(word, s$value, fixed = TRUE)))
{
return(FALSE)
}
}
# Otherwise, the error message appears to arise from the junk query arriving
# at the source, in which case we take the connection to be open.
return(TRUE)
}
SqrlPL <- function(state = NULL,
phrase = "")
{
# Detects procedural (PL) script and tracks parser progress through the same.
# Args:
# state : A list of named procedural-language (PL) marker counts.
# phrase : A SQL fragment to scan for PL markers.
# Returns:
# An updated state list.
# SQRL Calls:
# None.
# SQRL Callers:
# SqrlParse().
# User:
# Has no direct access. The user is able to supply phrase via their SQL
# script, but only by way of SqrlParse(), which will ensure that phrase is a
# single string that does not contain any SQL comment or quoted literal. The
# user is unable to supply the state argument, although its value will
# reflect the content of their supplied SQL script. No argument validity
# checking is required.
# Thus function is fallible. Procedural language extensions appear in Oracle,
# DB2, Transact, Teradata, MySQL, Postgres, and many others. The nestable
# 'begin ... end;' syntax is common, but the different DMBSes have their own
# optional phrases beforehand. What's a keyword in one, may be a valid column
# or variable name in another. In the event that PL parsing fails, the scdo
# parameter can be set to FALSE (to submit only upon a <do> or <result> tag).
# On NULL input, initialise and return a new state list.
if (is.null(state))
{
return(list(block = FALSE, begins = 0L, ends = 0L))
}
# Because gregexpr() only finds disjoint matches, 'end;end', for instance,
# would count as only one end below (they share the semicolon). By doubling
# all word-break characters, 'end;end' becomes 'end;;end' and gregexpr()
# finds both ends. Fortunately, gsub() does not re-double characters.
phrase <- gsub("([^[:alnum:]@#$_])", "\\1\\1", phrase)
# Count instances of 'begin'. This keyword is mandatory within most PL blocks.
state$begins <- state$begins + sum(gregexpr(
"(^|[^[:alnum:]@#$_])begin([^[:alnum:]@#$_]|$)",
phrase, ignore.case = TRUE)[[1L]] > 0L)
# Count instances of 'end'. This keyword is mandatory within most PL blocks,
# and must be followed by a semicolon (to distinguish it from 'end loop' and
# 'end if'. This will fail if there's a comment in between the end and the ;.
state$ends <- state$ends + sum(gregexpr("(^|[^[:alnum:]@#$_])end\\s*;",
phrase, ignore.case = TRUE)[[1L]] > 0L)
# If we already believe we're inside a PL block, return the updated state.
if (state$block)
{
return(state)
}
# If we've got any begins, then we now think we're in a PL block.
# Return the updated state.
if (state$begins > 0L)
{
state$block <- TRUE
return(state)
}
# Search for optional PL key phrases that appear before a (mandatory) begin.
# Detection of any of these causes us to believe we're inside a PL block.
state$block <- grepl(paste0(
"(^|[^[:alnum:]@#$_])(declare|((create|replace)\\s+",
"(function|package|procedure|trigger|type)))([^[:alnum:]@#$_]|$)"),
phrase, ignore.case = TRUE)
# Return the updated state list.
return(state)
}
SqrlProc <- function(datasource,
proc)
{
# Retrieves a stored procedures by its name.
# Args:
# datasource : The name of data source, as known to SQRL.
# proc : A possible stored-procedure name, perhaps as components.
# Returns:
# The definition of the named procedure, as a character string. When no
# procedure matches the supplied name, NULL is returned instead.
# SQRL Calls:
# SqrlParam(), SqrlTry().
# SQRL Callers:
# SqrlDelegate().
# User:
# Has no direct access. Is able to supply (only) the proc argument, via
# SqrlDelegate(). Exceptions from unexpected input are silently caught.
# Collapse proc, which could be supplied as components, to a single string.
proc <- SqrlTry(paste0(unlist(proc), collapse = ""), warn = FALSE)
# If pasting failed, proc can't name a procedure (retun NULL).
if (proc$error)
{
return(NULL)
}
proc <- proc$value
# If proc isn't a single string, it cannot name a procedure (return NULL).
if ((length(proc) != 1L)
|| (nchar(proc) < 1L))
{
return(NULL)
}
# Work backward through the temporary stack (provided it exists), and return
# the first procedure definition with a matching name.
lib <- SqrlParam(datasource, "libstack")
for (i in rev(seq_along(lib)))
{
if (proc %in% names(lib[[i]]))
{
return(lib[[i]][proc])
}
}
# The name wasn't found on the stack; so now search the main library. Once
# again, if a matching name appears, then return the corresponding definition.
lib <- SqrlParam(datasource, "library")
if (proc %in% names(lib))
{
return(lib[proc])
}
# The name does not refer to any stored procedure. Return NULL.
return(NULL)
}
SqrlShell <- function(datasource = "",
envir = parent.frame(),
args.list)
{
# Relays commands from public interface functions to the private interpreter.
# Args:
# datasource : The name of a known data source.
# envir : An R environment, from which variables are inherited.
# args.list : A list of arguments, to be interpreted and actioned.
# Returns:
# The result of the command (frequently a data frame, string or list).
# SQRL Calls:
# SqrlCache(), SqrlClose(), SqrlDelegate(), SqrlParam(), SqrlTry().
# SQRL Callers:
# SqrlAll() (and data source interfaces).
# User:
# User has no direct access, but is able to supply (only) the args.list
# argument from sqrlAll() and/or any data source interface functions). Since
# args.list is unrestricted (it could be SQL), no argument validity checking
# is performed here.
# When autoclose is TRUE, always close any open connection upon exiting this
# function in any manner (including when an error has been thrown somewhere).
on.exit(
if (SqrlCache(datasource, exists = TRUE)
&& SqrlParam(datasource, "autoclose"))
{
SqrlClose(datasource)
})
# Relay the arguments to SqrlDelegate, for interpretation and evaluation,
# while trapping any error that might occur.
x <- SqrlTry(withVisible(SqrlDelegate(datasource, envir, args.list)))
# If an error occurred, throw a concise error message, showing only the top-
# level interface function (or data source name), rather than the originating
# internal function with all its messy arguments.
if (x$error)
{
f <- SqrlParam(datasource, "interface")
if (!is.null(f))
{
k <- parse(text = paste0(f, "(...)"), keep.source = FALSE)
stop(simpleError(x$value, k[[1L]]))
}
s <- parse(text = datasource, keep.source = FALSE)
stop(simpleError(x$value, s[[1L]]))
}
# No error occurred. Return the result visibly or invisibly, as intended.
x <- x$value
if (!x$visible)
{
return(invisible(x$value))
}
return(x$value)
}
SqrlStatement <- function(datasource,
parts)
{
# Constructs a SQL statement from the components supplied.
# Args:
# datasource : The name of a SQRL data source.
# parts : A list of components, constituting a SQL statement.
# Returns:
# The corresponding SQL statement. Differs from paste() in that lists are
# rewritten in comma-separated form and vectors in newline-separated form.
# SQRL Calls:
# SqrlParam().
# SQRL Callers:
# SqrlDelegate(), SqrlParse().
# User:
# Has no direct access. Can supply the only argument, via SqrlDelegate().
# In the event that the argument contains an object that cannot be pasted,
# all calls of this function are wrapped in try().
# As above, this function is only (directly) called from SqrlDelegate() and
# SqrlParse(). Both (only) supply objects wrapped inside of a list.
# Recurse over the list, converting the ultimate (atomic) objects to single
# strings (collapsing vectors with the aCollapse character).
ac <- SqrlParam(datasource, "aCollapse")
elements <- rapply(parts, paste0, how = "unlist", collapse = ac)
# Collapse the resulting character vector to a single string (with the
# lCollapse character), and return that string.
rc <- SqrlParam(datasource, "lCollapse")
return(paste0(elements, collapse = rc))
}
SqrlSource <- function(def)
{
# Defines (or re-defines) a data source and its interface.
# Args:
# def : A source name and definition (string or file), in that order.
# Returns:
# The interface name, invisibly, after creating, or re-defining, the source
# and its interface.
# SQRL Calls:
# SqrlCache(), SqrlConfig(), SqrlDefile(), SqrlInterface(), SqrlIsOpen(),
# SqrlParam(), SqrlParams(), SqrlPath(), SqrlTry().
# SQRL Callers:
# sqrlSource().
# User:
# Has no direct access. Can supply the argument via sqrlSource() (only).
# That function guarantees the existence of at least either two terms or
# one named term. Additional checks (assignability, conflict, etc.) are
# performed here.
# Separate the name from the definition component(s). When there is only one
# term, we use its name. When there is more than one term, we use the first
# term as the name if that term is not itself named. If it is named, we look
# instead for a unique term named 'name', and use that if it exists.
if (length(def) == 1L)
{
name <- trimws(names(def))
names(def) <- NULL
} else if (is.null(names(def))
|| !nzchar(names(def)[1L]))
{
name <- trimws(def[[1L]])
def[[1L]] <- NULL
} else if ("name" %in% names(def))
{
i <- which(names(def) == "name")
if (length(i) > 1L)
{
stop("Multiple 'name' terms.")
}
name <- trimws(def[[i]])
def[[i]] <- NULL
} else
{
stop("Could not identify the intended source name.")
}
# Ensure either all terms are named, or that no term is named. When the terms
# are named, ensure all names are different (unique).
if (!is.null(names(def)))
{
isnamed <- nzchar(names(def))
if (!any(isnamed))
{
names(def) <- NULL
} else if (!all(isnamed))
{
stop("Mixture of named and unnamed arguments.")
} else if (length(unique(names(def))) != length(names(def)))
{
stop("Duplicated argument names.")
}
}
# Accept source = NULL as an alias for remove = source.
if ((length(def) == 1L)
&& is.null(def[[1L]]))
{
def <- list(name)
name <- "remove"
}
# If the name is 'remove', treat the definition as a list of names of sources
# to be removed (deregistered from SQRL). Do that, then return invisible NULL.
# Non-existent sources are quietly skipped (no error is thrown).
if (name == "remove")
{
datasources <- unique(as.character(unlist(def)))
datasources <- datasources[datasources %in% SqrlCache("*")]
for (datasource in datasources)
{
SqrlCache(datasource, delete = TRUE)
}
return(invisible(NULL))
}
# Abort if the source name is unassignable.
if (name != make.names(name))
{
stop("Unassignable data-source name.")
}
# Prohibit redefinition of open sources. Always remove a pre-existing source,
# so that SqrlSource() begins from (defines onto) a clean slate.
if (SqrlCache(name, exists = TRUE))
{
if (SqrlIsOpen(name))
{
stop("Cannot redefine an open source.")
}
SqrlCache(name, delete = TRUE)
}
# When none of the terms are named, establish the implied name (and value),
# according to a sequential hierarchy.
if (is.null(names(def)))
{
# If the terms specify the path of a readable file, interpret them as a
# request to define and configure a source from that file.
def <- as.character(unlist(def))
path <- SqrlPath(def)
if (!is.null(path))
{
def <- list(config = path)
# Otherwise, if there is only one term and it names an existing source,
# interpret it as a request to make a copy of that source.
} else if ((length(def) == 1L)
&& SqrlCache(def, exists = TRUE))
{
def <- list(copy = def)
# Otherwise, if there are multiple terms, or if any term (string) contains
# an equals sign, interpret them as components of a connection string.
} else if ((length(def) > 1L)
|| any(grepl("=", def)))
{
def <- sub(";$", "", def)
def <- list(connection = paste0(def, collapse = ";"))
# Otherwise, there is only one term (string), it does not contain an equals
# sign, and does not name an existing source; interpret it as a DSN.
} else
{
def <- list(dsn = def)
}
}
# Abort if an original source (to be copied) has been specified, but that
# source does not exist within the SQRL cache.
if (("copy" %in% names(def))
&& !(def$copy %in% SqrlCache("*")))
{
stop("Copy source original not found.")
}
# Abort if a configuration file has been specified, but that file cannot be
# read (including file does not exist). We will miss this here when the file
# path has been specified in a list, but SqrlConfig() will pick that up later.
if (("config" %in% names(def))
&& !identical(class(def["config"]), class(list()))
&& is.null(SqrlPath(def["config"])))
{
stop("Cannot read the config file.")
}
# When the defining terms do not include a 'copy', 'config', or 'connection',
# there is no possibility of a single term specifying a connection string. If,
# additionally, we do not have a 'dsn' term, or if one of the terms does not
# correspond to a SQRL/RODBC parameter, then we interpret all of the terms as
# connection-string components, and construct the string from them.
if (!any(c("copy", "config", "connection") %in% names(def))
&& (!("dsn" %in% names(def))
|| !all(names(def) %in% SqrlParams("all"))))
{
def <- paste0(names(def), "=", sub(";$", "", def))
def <- list(connection = paste0(def, collapse = ";"))
}
# Create a fresh cache for the new data source (if it previously existed, it
# will have been deleted).
SqrlCache(name, create = TRUE)
# If we have a 'copy' term, perform the copy operation first (so that any
# other terms will subsequently override copied values).
if ("copy" %in% names(def))
{
# This only returns the set (non-default) parameters. Names are unique.
params <- SqrlParam(def$copy, "*")
# Don't copy parameters we shouldn't (name, interface, etc.).
params <- params[!(params %in% SqrlParams("don't-copy"))]
# If the original source has a library, copy it to the new source.
if ("library" %in% params)
{
SqrlParam(name, "reset", "library")
lib <- SqrlParam(def$copy, "library")
for (proc in names(lib))
{
script <- lib[[proc]]
names(script) <- proc
SqrlParam(name, "library", script, override = TRUE)
}
params <- params[params != "library"]
}
# Copy driver last, in case dsn was copied (and set a value for driver).
# Secrets are copied without loss, because SqrlSource() is informed.
params <- c(params[params != "driver"], params[params == "driver"])
for (param in params)
{
SqrlParam(name, param, SqrlParam(def$copy, param))
}
# If the original driver wasn't set, ensure the copy's driver is also
# undefined (in case dsn was defined and a copy driver has been set).
if (!("driver" %in% params))
{
SqrlParam(name, "reset", "driver")
}
}
# If we have a 'config' term, attempt to configure the source from the config
# file. Values in the file override any vales that may already have been
# copied from another source. The incomplete source is deleted on error. Note
# that def$config might be a file path (potentially in component form), or a
# list of (named) parameter = value pairs. SqrlConfig() will identify which
# (or neither) is the case, and handle appropriately.
if ("config" %in% names(def))
{
result <- SqrlTry(SqrlConfig(name, def$config))
if (result$error)
{
SqrlCache(name, delete = TRUE)
stop(result$value)
}
}
# If we have an 'interface' term, attempt to apply the specified name. This
# overrides any value that may have been set via config file. The incomplete
# source is deleted upon error.
if ("interface" %in% names(def))
{
result <- SqrlTry(
SqrlInterface(name, SqrlDefile("interface", def$interface)))
if (result$error)
{
SqrlCache(name, delete = TRUE)
stop(result$value)
}
}
# Iterate over all other terms (besides 'copy', 'config', and 'interface'),
# treating each as a SQRL/RODBC parameter. The incomplete source is deleted
# upon any error. The uniqueness of names has been asserted, above.
params <- names(def)
params <- params[!(params %in% c("copy", "config", "interface"))]
params <- c(params[params != "driver"], params[params == "driver"])
for (param in params)
{
result <- SqrlTry(SqrlParam(name, param, SqrlDefile(param, def[[param]])))
if (result$error)
{
SqrlCache(name, delete = TRUE)
stop(result$value)
}
}
# If no interface has been defined, attempt to apply the source name. The
# incomplete source will be deleted if this is not possible.
if (SqrlParam(name, "interface", isdefined = FALSE))
{
result <- SqrlTry(SqrlInterface(name, name))
if (result$error)
{
SqrlCache(name, delete = TRUE)
stop(result$value)
}
}
# Return the source's configuration, invisibly.
return(invisible(SqrlConfig(name)))
}
SqrlSources <- function(import = "")
{
# Returns a summary table of defined sources.
# Args:
# import : Specifies the class of DSNs to import (default is do not import).
# Returns:
# A data frame summarising locally defined data sources. There is no
# guarantee that any of these sources are presently available, or even that
# they exist. The data frame may be empty (have zero rows).
# SQRL Calls:
# SqrlAll(), SqrlCache(), SqrlDSNs(), SqrlIsOpen(), SqrlParams(),
# SqrlValue().
# SQRL Callers:
# SqrlDelegate(), sqrlSources().
# User:
# The user has no direct access, but is able to supply the argument via
# sqrlSources(), which vets it as being one of "", "all", "user", or
# "system". Further argument validity checking is not required.
# If the import argument is 'remove', then deregister (delete) all sources.
if (import == "remove")
{
SqrlAll(list("remove"), envir = parent.frame())
return(invisible(NULL))
}
# If the import argument was something else, import the corresponding DSNs.
if (nchar(import) > 0L)
{
SqrlDSNs(import)
}
# Retrieve and return a summary of sources (data frame).
params <- SqrlParams("source-table")
sumlist <- list()
for (param in params)
{
sumlist[[param]] <- list(character(0L))
}
for (datasource in SqrlCache("*"))
{
for (param in params)
{
if (param == "open")
{
value <- c("N", "Y")[SqrlIsOpen(datasource, besure = FALSE) + 1L]
} else
{
value <- SqrlValue(datasource, param)
if (is.null(value))
{
value <- NA
}
}
sumlist[[param]] <- append(sumlist[[param]], value)
}
}
for (param in params)
{
sumlist[[param]] <- unlist(sumlist[[param]])
}
sumframe <- as.data.frame(sumlist, stringsAsFactors = FALSE)
sumframe <- sumframe[order(sumframe[, 1L]), ]
rownames(sumframe) <- NULL
return(sumframe)
}
SqrlSubmit <- function(datasource,
statement,
retry = TRUE)
{
# Submit a SQL statement to a connected data source.
# Args:
# datasource : The name of a known data source.
# statement : A SQL statement (as a single character string).
# retry : When set to FALSE, do not resubmit on failure.
# Returns:
# Result of submitting the statement (typically a data frame).
# SQRL Calls:
# SqrlIndicator(), SqrlIsOpen(), SqrlOpen(), SqrlParam(),
# SqrlSubmit() (self), SqrlTry().
# RODBC Calls:
# odbcGetErrMsg, odbcQuery, sqlGetResults(), sqlQuery().
# SQRL Callers:
# SqrlDelegate(), SqrlSubmit() (self), SqrlSubScript().
# User:
# Has no direct access. Is able to supply (only) the statement argument (a
# string), via SqrlSubScript(). No further checks are required.
# If the statement is empty, return NULL (emulates no-query in any SQL).
# Now that all queries go via the parser, this should never happen (everything
# comes in from SqrlSubscript(), which already performs this operation).
if (!grepl("[[:graph:]]", statement))
{
return(NULL)
}
# Abort, unless an open channel exists, or can be established, to the data
# source. This is not a ping check, so the channel might still be closed.
if (!SqrlIsOpen(datasource))
{
SqrlOpen(datasource)
if (!SqrlIsOpen(datasource))
{
stop("Connection attempt failed.")
}
}
# Our preferred method is to submit the statement via RODBC::odbcQuery(), and
# then fetch the results via RODBC::sqlGetResults(). However, the RODBC manual
# states that odbcQuery() is 'likely to be confined to the "RODBC" namespace
# in the near future'. The same issue applies to RODBC::odbcGetErrMsg(), so
# first we check these functions are available.
rodbc <- getNamespaceExports("RODBC")
if (("odbcQuery" %in% rodbc)
&& (!SqrlParam(datasource, "errors")
|| ("odbcGetErrMsg" %in% rodbc)))
{
# Append query-in-progress marker to the window-title connection indicator.
SqrlIndicator(datasource, "query")
# Submit the query, and retrieve the exit code (+1 = success, -1 = failure).
status <- SqrlTry(RODBC::odbcQuery(
channel = SqrlParam(datasource, "channel"),
query = statement,
rows_at_time = SqrlParam(datasource, "rows_at_time")))
# Remove query-in-progress marker from the window-title indicator.
SqrlIndicator(datasource, "done")
# Two modes of failure exist; RODBC::odbcQuery() could throw an error, or
# else it could cleanly return its failure code (-1L). Should one occur, we
# either try again, throw the error, or return the error message.
if (status$error
|| (status$value == -1L))
{
# If we might need the ODBC error message, we'd better retrieve it now,
# because SqrlIsOpen() pings the source (below), destroying that message.
# If RODBC::odbcGetErrMsg() should fail here, we get the error message
# for that failure, instead of the original RODBC::odbcQuery() message.
if (!status$error
&& SqrlParam(datasource, "errors"))
{
error <- SqrlTry(RODBC::odbcGetErrMsg(SqrlParam(datasource, "channel")))
status$value <- paste0(error$value, collapse = "\n")
}
# If this was a first attempt (retry = TRUE), and second attempts are
# enabled (the retry parameter is also TRUE), and a ping of the source
# reveals the connection to have been dropped, then we infer that was the
# cause of the error, and make one more attempt (only). That will involve
# opening a new channel, which might prompt the user for authentication.
# This mechanism provides a (very) limited ability to recover from network
# drop-outs, but it cannot restore temporary tables.
if (retry
&& SqrlParam(datasource, "retry")
&& !SqrlIsOpen(datasource, besure = TRUE))
{
return(SqrlSubmit(datasource, statement, retry = FALSE))
}
# Otherwise, we do not make another attempt. When RODBC::odbcQuery() threw
# an error, or when the 'errors' parameter is TRUE, we throw the error. In
# the latter case, this has the effect of promoting ODBC failure messages
# to local R exceptions (unlike RODBC, which simply returns the messages
# as character strings).
if (status$error
|| SqrlParam(datasource, "errors"))
{
stop(status$value)
}
# Otherwise (the 'errors' parameter is FALSE), return the error message
# (as a character string, without raising an exception).
return(status$value)
}
# The query has succeeded, but we have not yet retrieved the result of it.
# Append fetch-in-progress marker to the window-title connection indicator.
SqrlIndicator(datasource, "fetch")
# Retrieve the data. If a connection error occurs here, we cannot easily
# recover without re-submitting the query, since pinging the source will
# destroy the waiting rows.
result <- SqrlTry(
RODBC::sqlGetResults(channel = SqrlParam(datasource, "channel"),
as.is = SqrlParam(datasource, "as.is"),
errors = SqrlParam(datasource, "errors"),
max = SqrlParam(datasource, "max"),
buffsize = SqrlParam(datasource, "buffsize"),
nullstring = SqrlParam(datasource, "nullstring"),
na.strings = SqrlParam(datasource, "na.strings"),
believeNRows = SqrlParam(datasource, "believeNRows"),
dec = SqrlParam(datasource, "dec"),
stringsAsFactors = SqrlParam(datasource, "stringsAsFactors")))
# Remove fetch-in-progress marker from the window-title indicator.
SqrlIndicator(datasource, "done")
# If RODBC::sqlGetResults() threw an error, or if it appears to have cleanly
# returned an error message or code, either try again, throw the exception,
# or return the result (potentially an error message or code).
if (result$error
|| identical(class(result$value), class(integer()))
|| (identical(class(result$value), class(character()))
&& (length(result$value) > 1L)))
{
# If the failure appears to have been caused by a lost connection, and
# this is our first attempt, and the retry parameter is TRUE (enabled),
# then make one more. Because SqrlIsOpen() may have destroyed any waiting
# rows, the original query must be resubmitted.
if (retry
&& SqrlParam(datasource, "retry")
&& !SqrlIsOpen(datasource, besure = TRUE))
{
return(SqrlSubmit(datasource, statement, retry = FALSE))
}
# If RODBC::sqlGetResults() threw an error, or if the 'errors' parameter
# is TRUE, throw the error. In the latter case, this promotes the ODBC
# error message to a local R exception, and throws it (RODBC doesn't).
if (result$error
|| SqrlParam(datasource, "errors"))
{
stop(paste(result$value, collapse = "\n"))
}
}
# Return the result. This could be a data frame, a character string, an
# empty character vector, or an integer code (-1 = failure, -2 = no data).
return(result$value)
}
# The block above is our preferred method, used so long as RODBC::odbcQuery()
# remains publicly available. Should that not be the case, the script below
# implements our fallback method, which uses RODBC::sqlQuery() instead.
# Append query-in-progress indicator to the window-title connection indicator.
SqrlIndicator(datasource, "query")
# A valid connection exists. Submit the statement, and retrieve only the first
# row (the least amount of data we can). Uses stringsAsFactors = FALSE, to
# simplify merging with any additional rows (discussed below).
result <- SqrlTry(RODBC::sqlQuery(channel = SqrlParam(datasource, "channel"),
query = statement,
errors = SqrlParam(datasource, "errors"),
as.is = SqrlParam(datasource, "as.is"),
max = 1L,
buffsize = SqrlParam(datasource, "buffsize"),
nullstring = SqrlParam(datasource, "nullstring"),
na.strings = SqrlParam(datasource, "na.strings"),
believeNRows = SqrlParam(datasource, "believeNRows"),
dec = SqrlParam(datasource, "dec"),
stringsAsFactors = FALSE,
rows_at_time = SqrlParam(datasource, "rows_at_time")))
# Remove query-in-progress indicator from the window title.
SqrlIndicator(datasource, "done")
# On success, RODBC::sqlQuery() returns a data frame or character string (both
# possibly empty). On an ODBC error, it returns either a character vector, or
# an integer (either -1, failure, or -2, no data). Refer to the RODBC manual.
# In the character vector error case, the length of the vector is usually at
# least two (the ODBC driver error message, plus the RODBC error message), but
# in some cases the driver can flag an error without generating a message to
# go with it, in which case the result is a single character string, being the
# RODBC message (only). All RODBC error messages begin with '[RODBC] ERROR:'.
if (result$error
|| identical(class(result$value), class(integer()))
|| (identical(class(result$value), class(character()))
&& any(grepl("^\\[RODBC\\] ERROR:", result$value))))
{
# If the failure appears to have been caused by a lost connection, and this
# is our first attempt, then make one more (unless the retry parameter has
# been set to FALSE).
if (retry
&& SqrlParam(datasource, "retry")
&& !SqrlIsOpen(datasource, besure = TRUE))
{
return(SqrlSubmit(datasource, statement, retry = FALSE))
}
# If RODBC::sqlQuery() threw an error, or when the 'errors' parameter is
# TRUE, throw the error. In the latter case, this promotes the ODBC error
# message or code to an R exception (RODBC doesn't).
if (result$error
|| SqrlParam(datasource, "errors"))
{
stop(paste(result$value, collapse = "\n"))
}
}
# No error occurred. Remove the error flag, retain only the (non-error) value.
result <- result$value
# When the result is not a data frame, there won't be any more rows to fetch.
# This could be a character string or integer error code.
if (!identical(class(result), class(data.frame())))
{
return(result)
}
# The result is a data frame of, at most, one row. If it has zero rows, then
# there can be no more to fetch, so return it now. For consistency with RODBC,
# strings are not converted to factors in this special case.
if (nrow(result) == 0L)
{
return(result)
}
# The result is a data frame of precisely one row. There could be others left
# to fetch, but if only one row is sought, we do not want them. In that case,
# return the data frame (after converting strings to factors, if instructed).
if (SqrlParam(datasource, "max") == 1L)
{
if (SqrlParam(datasource, "stringsAsFactors"))
{
for (i in seq_along(result))
{
if (identical(class(result[, i]), class(character())))
{
result[, i] <- as.factor(result[, i])
}
}
}
return(result)
}
# Otherwise, we need to fetch any remaining rows (up to the specified limit).
# Append fetch-in-progress marker to the window-title connection indicator.
SqrlIndicator(datasource, "fetch")
# Retrieve all remaining rows (up to any specified maximum limit).
restof <- SqrlTry(
RODBC::sqlGetResults(channel = SqrlParam(datasource, "channel"),
as.is = SqrlParam(datasource, "as.is"),
errors = SqrlParam(datasource, "errors"),
max = max(SqrlParam(datasource, "max") - 1L, 0L),
buffsize = SqrlParam(datasource, "buffsize"),
nullstring = SqrlParam(datasource, "nullstring"),
na.strings = SqrlParam(datasource, "na.strings"),
believeNRows = SqrlParam(datasource, "believeNRows"),
dec = SqrlParam(datasource, "dec"),
stringsAsFactors = FALSE))
# Remove the fetch-in-progress marker from the window title.
SqrlIndicator(datasource, "done")
# With the initial call of RODBC::sqlQuery() having returned a non-empty data
# frame (above), RODBC::sqlGetResults() should also have returned a data frame
# (although, possibly one with zero rows). Anything else is an error.
if (restof$error
|| !identical(class(restof$value), class(data.frame())))
{
# If the failure appears to have been caused by a lost connection, and this
# is our first attempt, then make one more (unless the retry parameter has
# been set to FALSE).
if (retry
&& SqrlParam(datasource, "retry")
&& !SqrlIsOpen(datasource, besure = TRUE))
{
return(SqrlSubmit(datasource, statement, retry = FALSE))
}
# If RODBC::sqlGetResults() threw an error, or when the 'errors' parameter
# is TRUE, throw the error. The latter case promotes ODBC error messages to
# local R exceptions (RODBC doesn't).
if (restof$error
|| SqrlParam(datasource, "errors"))
{
stop(paste(restof$value, collapse = "\n"))
}
# Otherwise (when 'errors' is FALSE), return the unexpected result.
return(restof$value)
}
# Append the subsequent rows (from RODBC::sqlGetResults()) to the initial row
# (from RODBC::sqlQuery()). It is this operation that requires pulling with
# stringsAsFactors = FALSE (above), because the two frames need not contain
# the same factor-level definitions.
result <- rbind(result, restof$value)
# Convert strings to factors, if so instructed.
if (SqrlParam(datasource, "stringsAsFactors"))
{
for (i in seq_along(result))
{
if (identical(class(result[, i]), class(character())))
{
result[, i] <- as.factor(result[, i])
}
}
}
# Return the (non-empty) data frame.
return(result)
}
SqrlSubScript <- function(datasource = "",
statement = "",
phrase = "",
intermediate = "null",
envir = NULL)
{
# Submits a SQL statement to a data source, and retrieves the result.
# Args:
# datasource : The name of data source, as known to SQRL.
# statement : A list of strings, forming a (partial) SQL statement.
# phrase : A single string, completing the SQL statement.
# intermediate : The name (string) of a variable to assign the result to.
# envir : An environment, within which the assignment is made.
# Returns:
# The result of submitting the statement (or NULL when the statement is
# blank). When the environment and intermediate are both non-null, the
# result (or NULL) is assigned to the intermediate within the environment.
# SQRL Calls:
# SqrlParam(), SqrlSubmit().
# utils Calls:
# head() (only if utils is attached).
# SQRL Callers:
# SqrlParse().
# User:
# Has no direct access, but is able to supply (only) the statement, phrase,
# and intermediate arguments via a SQRL script. These arguments will have
# already been parsed and worked into the correct format, by SqrlParse() and
# SqrlStatement(), so no argument validity checks should be required here.
# If the phrase is non-empty, append it to the statement.
if (nchar(phrase) > 0L)
{
# Remove trailing whitespace (including vertical) from the phrase.
# The phrase cannot (will never) contain quoted string literals.
phrase <- sub("[[:space:]]*$", "", phrase)
# Remove trailing whitespace from each internal line of the phrase.
phrase <- gsub("[[:blank:]]+\n", "\n", phrase)
# Remove vertical whitespace from within the phrase.
phrase <- gsub("\n+", "\n", phrase)
# Remove any whitespace preceding a terminal semi-colon.
phrase <- sub("[[:space:]]*;$", ";", phrase)
# Append the phrase to the statement (unless the phrase is empty).
if (nchar(phrase) > 0L)
{
statement <- append(statement, phrase)
}
}
# If the statement is non-empty, submit it and retrieve the result.
if (length(statement) > 0L)
{
# Collapse the statement to a single string. Submit it if non-blank.
statement <- trimws(paste(statement, collapse = ""))
if (grepl("[[:graph:]]", statement))
{
# Boolean; whether or not to show verbose output. The value of the verbose
# parameter cannot change while this function is executing.
verbose <- interactive() && SqrlParam(datasource, "verbose")
# If verbose, output the statement (prior to submission).
if (verbose)
{
cat("\n\n\n")
cat(statement)
cat("\n")
}
# Submit the statement to the source, retrieve the result.
result <- SqrlSubmit(datasource, statement)
# If verbose, output (some of) the result. Coming from SqrlSubmit(), this
# should be a data frame, a short character vector, an integer, or NULL.
# Methods for head() and print() are defined on all of these.
if (verbose)
{
printed <- FALSE
if ("package:utils" %in% search())
{
top <- utils::head(result)
print(top)
if (!identical(top, result))
{
cat("(output truncated)\n")
}
} else
{
cat(paste0("(object of class '",
paste0(class(result), collapse = " "), "')\n"))
}
cat("\n")
}
# Assign the result to the intermediate variable (unless null).
if (!is.null(envir)
&& (tolower(intermediate) != "null"))
{
assign(intermediate, result, envir)
}
# If the result was 'No Data' (generated by RODBC in response to receiving
# SQL_NO_DATA from the driver, after executing, say, drop table), or -2L
# (under the same conditions, but when the errors parameter is FALSE), or
# a zero-length character vector (sometimes produced by similar
# operations), then return it invisibly.
if (identical(result, -2L)
|| identical(result, "No Data")
|| identical(result, character(0L)))
{
return(invisible(result))
}
# Otherwise, return the result visibly.
return(result)
}
}
# There was actually no query (and, therefore, no result). If the result was
# to have been assigned to some name, assign it the value NULL.
if (!is.null(envir)
&& (tolower(intermediate) != "null"))
{
assign(intermediate, NULL, envir)
}
# Return NULL, signifying an undefined result (because there was no query).
# SqrlSubmit() does the same thing, if it receives a blank statement (which it
# shouldn't). RODBC::sqlQuery() (to which SqrlSubmit() is a wrapper), is
# incapable of returning NULL (or NA). It doesn't actually matter whether or
# not this is visible, since NULL is a special value signifying to SqrlParse()
# that the current overall result should not be replaced by this one.
return(invisible(NULL))
}
SqrlTry <- function(expr,
warn = TRUE)
{
# Evaluation with silent error catching and optional warning suppression.
# Args:
# expr : An arbitrary R expression, to be evaluated.
# warn : When set to FALSE, warning messages are suppressed.
# Returns:
# A vector of two named elements; 'error' and 'value'. When evaluation
# produces an error, 'error' will be TRUE and 'value' will be the error
# message. Otherwise (when the expression evaluated normally), 'error' will
# be FALSE and 'value' will be the result of that evaluation.
# SQRL Calls:
# None.
# SQRL Callers:
# SqrlClose(), SqrlDefile(), SqrlDelegate(), SqrlParse(), SqrlHelp(),
# SqrlIsOpen(), SqrlOff(), SqrlOpen(), SqrlPath(), SqrlPing(), SqrlProc(),
# SqrlShell(), SqrlSource(), SqrlSubmit(), sqrlInterface(), sqrlSource(),
# .onUnload().
# User:
# Has no direct access, but can supply the expression indirectly. Here,
# that expression is inherently wrapped in tryCatch(), so no other checks
# are required.
# Error-handling function.
efun <- function(e)
{
list(error = TRUE, value = conditionMessage(e))
}
# When warnings are not to be suppressed, attempt to evaluate the expression
# while trapping errors but throwing any warning messages.
if (warn)
{
return(tryCatch(list(error = FALSE, value = expr), error = efun))
}
# Otherwise, warnings are to be suppressed. Attempt to evaluate the expression
# while trapping errors and also suppressing any warning messages.
return(suppressWarnings(
tryCatch(list(error = FALSE, value = expr), error = efun)))
}
SqrlValue <- function(datasource = "",
parameter = "",
set)
{
# Output-safe (password obliterated) wrapper to SqrlParam().
# Args:
# datasource : The name of a data source, as known to SQRL.
# parameter : The name of a SQRL or RODBC control parameter.
# set : A value to assign to that parameter (optional).
# Returns:
# The edited parameter value (with secrets kept secret).
# SQRL Calls:
# SqrlParam(), SqrlParams(), SqrlValue() (self).
# SQRL Callers:
# SqrlConfig(), SqrlDelegate(), SqrlSources(), SqrlValue() (self).
# User:
# Has no direct access, but is able to supply (only) parameter and set via
# SqrlDelegate() and/or SqrlConfig(). The former vets parameter while the
# latter does not (although it will restrict parameter to being a string,
# and is write-only). Neither vets set. Both parameters are simply passed to
# SqrlParam(), and that function performs additional checking as required.
# All functions returning values to the user (outside of the SQRL namespace)
# should be sourcing their values from this, and not from SqrlParam().
# This is the text with which secret information (pwd) is replaced.
# Six asterisks have been chosen for consistency with RODBC.
oblit <- "******"
# A request for the (read-only) value of 'source' returns either the 'dsn'
# parameter, or the 'connection' parameter, whichever defines the source,
# with any placeholders substituted and any secrets obliterated.
if (identical(parameter, "source"))
{
connection <- as.character(SqrlValue(datasource, "connection"))
if (nchar(connection) > 0L)
{
for (spar in SqrlParams("substitutable"))
{
connection <- gsub(paste0("<", spar, ">"), SqrlValue(datasource, spar),
connection)
}
return(connection)
}
dsn <- as.character(SqrlValue(datasource, "dsn"))
# The conditional pasting below is as per RODBC::odbcConnect().
dsn <- paste0("DSN=", dsn)
if (SqrlParam(datasource, "uid", isdefined = TRUE)
&& (nchar(SqrlValue(datasource, "uid")) > 0L))
{
dsn <- paste0(dsn, ";UID=", SqrlValue(datasource, "uid"))
}
if (SqrlParam(datasource, "pwd", isdefined = TRUE)
&& (nchar(SqrlValue(datasource, "pwd")) > 0L))
{
dsn <- paste0(dsn, ";PWD=", SqrlValue(datasource, "pwd"))
}
return(dsn)
}
# Retrieve the parameter value, after setting it if so instructed.
if (!missing(set))
{
if (nchar(datasource) < 1L)
{
value <- set
} else
{
value <- SqrlParam(datasource, parameter, set)
}
} else
{
value <- SqrlParam(datasource, parameter)
}
# If the parameter is 'reset', then the value is a list of (uniquely) named
# defaults. While there can be no secrets contained within those defaults,
# some of them might be of named-value type, for which we return only the
# names, rather than the named-values (for brevity, not security).
if (parameter == "reset")
{
for (param in SqrlParams("named-values"))
{
if (param %in% names(value))
{
value[param] <- list(names(value[[param]]))
}
}
return(value)
}
# Return only the names of any library entries, rather than their complete
# definitions. This is for brevity, not for security.
if (parameter %in% SqrlParams("named-values"))
{
return(names(value))
}
# If the parameter is semi-secret (connection), it may contain secret (pwd)
# values as substrings. In this case, locate and obliterate any secrets.
if (parameter %in% SqrlParams("semi-secret"))
{
for (spar in SqrlParams("secret"))
{
pattern <- paste0("\\b", spar, "\\s*=")
if (grepl(pattern, value, ignore.case = TRUE))
{
# Construct regular expression patterns for each of the non-secret
# values (blank, <pwd>, and so on). These are unique.
ignorables <- SqrlParams("substitutable")
ignorables <- ignorables[ignorables %in% SqrlParams("secret")]
if (length(ignorables) > 0L)
{
ignorables <- paste0("\\s*<", ignorables, ">\\s*$")
}
ignorables <- paste0(pattern, c("\\s*$", ignorables))
# Positions (first-character indices) and lengths of the (potential)
# secret-containing sub-strings of the parameter-value string.
ssubs <- gregexpr(paste0(pattern, "\\s*[^;]*"), value,
ignore.case = TRUE)[[1L]]
slens <- c(0L, attr(ssubs, "match.length"))
ssubs <- c(0L, ssubs)
# Overwrite all non-ignorable (true) secrets with the replacement text.
eds <- character(0L)
for (i in seq(2L, length(ssubs)))
{
# Character positions (indices) within the value string; Start Of
# Secret substring, End Of Secret substring, Start Of Previous
# (non-secret) substring, End of Previous (non-secret) substring.
sos <- ssubs[i]
eos <- ssubs[i] + slens[i] - 1L
sop <- ssubs[i - 1L] + slens[i - 1L]
eop <- ssubs[i] - 1L
# Isolate the potentially secret containing substring.
ssub <- substring(value, sos, eos)
# If the parameter value is apparently non-sensitive (ignorable),
# then retain it unmodified (do not obliterate the value).
ignore <- FALSE
for (ignorable in ignorables)
{
if (grepl(ignorable, ssub, ignore.case = TRUE))
{
ignore <- TRUE
break
}
}
if (ignore)
{
eds <- c(eds, substring(value, sop, eos))
# Otherwise, the sub-string contains potentially secret information.
# Obliterate (replace) that information with the masking sequence.
} else
{
pat <- paste0("(", spar, "\\s*=\\s*)[^;]+")
eds <- c(eds, substring(value, sop, eop),
sub(pat, paste0("\\1", oblit), ssub, ignore.case = TRUE))
}
}
# Append any final (trailing) non-secret sub-string.
eds <- c(eds, substring(value,
ssubs[length(ssubs)] + slens[length(ssubs)]))
value <- paste0(eds, collapse = "")
}
}
return(value)
}
# If the parameter is secret, obliterate it entirely (unless it is empty).
if (parameter %in% SqrlParams("secret"))
{
if (!nzchar(value))
{
return(value)
}
return(oblit)
}
# Otherwise (the parameter is non-secret), return the unmodified value.
return(value)
}
########################################################### PUBLIC FUNCTIONS ###
sqrlAll <- function(...)
{
# Sends the same command to each of the defined SQRL sources.
# Args:
# ... : A sequence of strings, as per (to be supplied to) SqrlDelegate().
# Returns:
# A (possibly invisible) list of the results of the command on each source.
# SQRL Calls:
# SqrlAll(), SqrlParams().
# User:
# Exported function. User has direct access. However, the argument(s) are
# unrestricted, and no checking is required (beyond that in SqrlDelegate()).
# Return visibly when the command is a value request on either a single named
# parameter or connection openness status.
arglist <- list(...)
if ((length(arglist) == 1L)
&& is.null(names(arglist))
&& identical(class(arglist[[1L]]), class(character()))
&& (nchar(arglist[[1L]]) > 0L)
&& ((arglist[[1L]] %in% c(SqrlParams("all"), "source"))
|| grepl("^is\\s*open$", arglist[[1L]])))
{
return(SqrlAll(arglist, envir = parent.frame()))
}
# Apply the commands, return the results invisibly.
return(invisible(SqrlAll(arglist, envir = parent.frame())))
}
sqrlInterface <- function(...)
{
# Constructs a user-interface to a specified data source.
# Args:
# ... : A source name and, optionally, a new interface name, in that order.
# Returns:
# The name of the interface function to the specified source. When only a
# source name is supplied in the arguments, the function acts as a getter
# and returns the current interface name (or NULL when there is none). When
# both source and interface names are supplied, the new interface name is
# set before being returned. When the interface name is given as 'remove',
# no new interface is created, but any existing interface is deleted.
# SQRL Calls:
# SqrlCache(), SqrlDefile(), SqrlInterface(), SqrlParam(), SqrlTry().
# User:
# Exported function. User has direct access. The datasource name is checked
# for validity, but it is left to SqrlInterface() to establish the validity
# and usability of the interface name.
# Either one or two arguments are expected.
arglist <- list(...)
if ((length(arglist) < 1L)
|| (length(arglist) > 2L))
{
k <- parse(text = "sqrlInterface(...)", keep.source = FALSE)
m <- "A source name and an interface name are expected."
stop(simpleError(m, k[[1L]]))
}
# Identify the data-source name and also the interface name (if specified).
getname <- FALSE
if (length(arglist) == 1L)
{
if (!is.null(names(arglist)))
{
datasource <- names(arglist)
interface <- SqrlDefile("interface", arglist[[datasource]])
} else
{
datasource <- arglist[[1L]]
getname <- TRUE
}
} else
{
datasource <- arglist[[1L]]
interface <- SqrlDefile("interface", arglist[[2L]], evaluate = TRUE)
}
# Abort on non-existence of the specified data source.
if (!identical(class(datasource), class(character()))
|| (length(datasource) != 1L)
|| (nchar(datasource) < 1L)
|| SqrlCache(datasource, exists = FALSE))
{
k <- parse(text = "sqrlInterface(...)", keep.source = FALSE)
m <- "Unrecognised data source."
stop(simpleError(m, k[[1L]]))
}
# In the absence of a specified interface name, get and return the name of the
# current interface to the data source (returnsS NULL if none exists).
if (getname)
{
return(SqrlParam(datasource, "interface"))
}
# Relay the arguments to SqrlInterface() (returns the new name).
f <- SqrlTry(withVisible(SqrlInterface(datasource, interface)))
# In the event of an error, throw the message.
if (f$error)
{
k <- parse(text = "sqrlInterface(...)", keep.source = FALSE)
stop(simpleError(f$value, k[[1L]]))
}
# Return the new interface name, either visibly or invisibly, as appropriate.
f <- f$value
if (!f$visible)
{
return(invisible(f$value))
}
return(f$value)
}
sqrlOff <- function()
{
# Close SQRL channels, deactivate SQRL.
# Args:
# None.
# Returns:
# Invisible NULL, after closing channels and detaching SQRL.
# SQRL Calls:
# SqrlOff().
# User:
# Exported function. User has direct access, but there are no arguments.
# Relay the command-option to SqrlOff() (returns invisible NULL).
return(SqrlOff())
}
sqrlSource <- function(...)
{
# Defines (or re-defines) a data source and its interface.
# Args:
# ... : A source name and definition (string or file), in that order.
# Returns:
# The interface name, invisibly, after creating, or re-defining, the source
# and its interface.
# SQRL Calls:
# SqrlSource(), SqrlTry().
# User:
# Exported function. User has direct access. Here, we ensure the existence
# of name and definition terms (in the form of multiple arguments, or at
# least one named argument). Additional checks are left to SqrlSource().
# Unpack any list arguments (to their first-level elements).
def <- list(...)
i <- length(def)
while (i > 0L)
{
if (identical(class(def[[i]]), class(list())))
{
j <- seq_along(def)
if ((i == 1L)
&& !is.null(names(def))
&& nzchar(names(def)[1L]))
{
def <- c(names(def)[1L], def[[1L]], def[j[j > 1L]])
} else
{
def <- c(def[j[j < i]], def[[i]], def[j[j > i]])
}
}
i <- i - 1L
}
# Abort unless we have at least a pair of terms (name, definition) or a single
# named term (name = definition).
if ((length(def) < 2L)
&& is.null(names(def)))
{
k <- parse(text = "sqrlSource(...)", keep.source = FALSE)
m <- "A name and definition are expected."
stop(simpleError(m, k[[1L]]))
}
# Pass the arguments to SqrlSource() (returns the interface name, invisibly).
s <- SqrlTry(SqrlSource(def))
# In the event of an error, throw the message.
if (s$error)
{
k <- parse(text = "sqrlSource(...)", keep.source = FALSE)
stop(simpleError(s$value, k[[1L]]))
}
# Invisibly return the new interface name.
return(invisible(s$value))
}
sqrlSources <- function(...)
{
# Returns a summary table of defined data sources.
# Args:
# ... : Argument to RODBC::odbcDataSources(), or empty (default).
# Returns:
# A data frame summarising defined data sources. There is no guarantee that
# any of these are presently available, or even that they exist.
# SQRL Calls:
# SqrlSources().
# User:
# Exported function. User has direct access. Argument checking is required.
# Ensure the argument is either omitted or takes one of the three allowed
# values (strings). Each of the strings 'all', 'user', and 'system' cause
# RODBC::odbcDataSources() to (re)import the corresponding set of local DSNs.
# Omitting the argument simply returns the existing SQRL data source
# definitions, without (re)importing DSNs.
import <- list(...)
if (length(import) == 0L)
{
import <- ""
} else if ((length(import) == 1L)
&& (identical(import[[1L]], "all")
|| identical(import[[1L]], "user")
|| identical(import[[1L]], "system")
|| identical(import[[1L]], "remove")))
{
import <- import[[1L]]
} else
{
k <- parse(text = "sqrlSources(...)", keep.source = FALSE)
m <- "Argument should be 'all', 'user', 'system', or 'remove'."
stop(simpleError(m, k[[1L]]))
}
# Pass to SqrlSources(), return the summary.
return(SqrlSources(import))
}
###################################################### PRIVATE LOAD / UNLOAD ###
.onLoad <- function(libname = "",
pkgname = "")
{
# Create data source interfaces within a public environment, on SQRL load.
# Args:
# libname : The name of the package's directory, within the R library.
# pkgname : The name of the package.
# Returns:
# Invisible NULL.
# SQRL Calls:
# SqrlDSNs(), SqrlHelp(), SQRL:Face.
# Attach a public environment, SQRL:Face, for holding data source interfaces
# where the user can see them (on the R search path). The user will be able to
# assign and modify objects within this environment (we would prefer that they
# didn't, but must allow for the possibility). It doesn't seem possible to
# attach a SQRL environment (such as srqlHaus), only a copy of one (with the
# name attribute added to it).
if (!("SQRL:Face" %in% search()))
{
a <- paste0(letters[c(1, 20, 20, 1, 3, 8)], collapse = "")
eval(call(a, new.env(parent = emptyenv()), name = "SQRL:Face"))
}
# Look for data source names (DSNs). Create an interface for each.
SqrlDSNs("all")
# Initiate an empty temp-file vector within the help environment.
SqrlHelp(clean = TRUE)
# Return invisible NULL.
return(invisible(NULL))
}
.onUnload <- function(libpath = "")
{
# Detaches the SQRL:Face environment whenever the SQRL package is unloaded.
# Args:
# libpath : The complete path to the package.
# Returns:
# Invisible NULL.
# SQRL Calls:
# SqrlHelp(), SqrlTry(), SQRL:Face.
# Remove any SQRL temp files from the R-session temp directory.
SqrlTry(SqrlHelp(clean = TRUE), warn = FALSE)
# Attempt to detach the public SQRL:Face environment, if not already done.
if ("SQRL:Face" %in% search())
{
SqrlTry(detach("SQRL:Face"), warn = FALSE)
}
# Return invisible NULL.
return(invisible(NULL))
}
######################################################################## EOF ###
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.