[rkward-cvs] SF.net SVN: rkward:[3129] branches
tfry at users.sourceforge.net
tfry at users.sourceforge.net
Mon Oct 18 11:13:59 UTC 2010
Revision: 3129
http://rkward.svn.sourceforge.net/rkward/?rev=3129&view=rev
Author: tfry
Date: 2010-10-18 11:13:59 +0000 (Mon, 18 Oct 2010)
Log Message:
-----------
Creating a separate branch for restructuring the event loop, and - in the process - other aspects of the backend.
This branch will not compile at all times, and when it does compile, it may still be totally broken.
Modified Paths:
--------------
branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rcommand.h
branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rembedinternal.cpp
branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rembedinternal.h
branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rthread.cpp
branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rthread.h
Added Paths:
-----------
branches/2010_10_18_backend_restructuring_branch/
branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rpackages/rkwardtests/R/rktest.replaceRunAgainLink.R
branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rpackages/rkwardtests/R/rkwardtests-internal.R
Removed Paths:
-------------
branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rpackages/rkwardtests/R/rktest.replaceRunAgainLink.R
branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rpackages/rkwardtests/R/rkwardtests-internal.R
Property changes on: branches/2010_10_18_backend_restructuring_branch
___________________________________________________________________
Added: svn:mergeinfo
+ /branches/release_branch_0.5.4:3098-3102
Modified: branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rcommand.h
===================================================================
--- trunk/rkward/rkward/rbackend/rcommand.h 2010-10-14 19:52:33 UTC (rev 3125)
+++ branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rcommand.h 2010-10-18 11:13:59 UTC (rev 3129)
@@ -201,6 +201,9 @@
ROutputList &getOutput () { return output_list; };
/** modify the command string. DO NOT CALL THIS after the command has been submitted! */
void setCommand (const QString &command) { _command = command; };
+
+/** public for internal reasons, only. Don't modify outside the rbackend classes. */
+ int status;
private:
friend class RThread;
friend class RInterface;
@@ -214,7 +217,6 @@
QString _command;
int _type;
int _flags;
- int status;
QString _rk_equiv;
int _id;
static int next_id;
Modified: branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rembedinternal.cpp
===================================================================
--- trunk/rkward/rkward/rbackend/rembedinternal.cpp 2010-10-14 19:52:33 UTC (rev 3125)
+++ branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rembedinternal.cpp 2010-10-18 11:13:59 UTC (rev 3129)
@@ -180,8 +180,7 @@
REmbedInternal::this_pointer->handleStandardCallback (&args);
// default implementation seems to return 1 on success, 0 on failure, contrary to some documentation. see unix/std-sys.c
if (args.params["cancelled"].toBool ()) {
-#warning TODO: this should be handled in rthread.cpp, instead
- REmbedInternal::this_pointer->currentCommandWasCancelled ();
+ if (REmbedInternal::this_pointer->current_command) REmbedInternal::this_pointer->current_command->status |= RCommand::Canceled;
RK_doIntr();
return 0; // we should not ever get here, but still...
}
@@ -208,7 +207,7 @@
/** For R callbacks that we want to disable, entirely */
void RDoNothing () {
- RK_TRACE (RBACKEND);
+ //RK_TRACE (RBACKEND);
}
void RCleanUp (SA_TYPE saveact, int status, int RunLast) {
@@ -1049,7 +1048,17 @@
if (!print_result) {
SEXP parsed = parseCommand (command_qstring, error);
if (*error == NoError) runCommandInternalBase (parsed, error);
- } else { // run a user command
+ } else {
+}
+
+void REmbedInternal::runCommand (RCommand *command) {
+ RK_ASSERT (command);
+
+ RKWardRError error = NoError;
+
+ // running user commands is quite different from all other commands
+ if (command->type () & RCommand::User) {
+ // run a user command
/* Using R_ReplDLLdo1 () is a pain, but it seems to be the only entry point for evaluating a command as if it had been entered on a plain R console (with auto-printing if not invisible, etc.). Esp. since R_Visible is no longer exported in R 2.5.0, as it seems as of today (2007-01-17).
Problems to deal with:
@@ -1074,7 +1083,7 @@
R_ReplDLLinit (); // resets the parse buffer (things might be left over from a previous incomplete parse)
bool prev_iteration_was_incomplete = false;
- QByteArray localc = current_locale_codec->fromUnicode (command_qstring); // needed so the string below does not go out of scope
+ QByteArray localc = current_locale_codec->fromUnicode (command->command ()); // needed so the string below does not go out of scope
current_buffer = localc.data ();
repldll_buffer_transfer_finished = false;
@@ -1102,93 +1111,58 @@
}
}
repldlldo1_wants_code = false; // make sure we don't get confused in RReadConsole
+ } else { // not a user command
+ SEXP parsed = parseCommand (command, &error);
+ if (error == NoError) {
+ SEXP exp;
+ PROTECT (exp = runCommandInternalBase (parsed, &error));
+ if (error == NoError) {
+ if (command->type () & RCommand::GetStringVector) {
+ command->datatype = RData::StringVector;
+ command->data = SEXPToStringList (exp, &(command->length));
+ } else if (command->type () & RCommand::GetRealVector) {
+ command->datatype = RData::StringVector;
+ command->data = SEXPToRealArray (exp, &(command->length));
+ } else if (command->type () & RCommand::GetIntVector) {
+ command->datatype = RData::StringVector;
+ command->data = SEXPToIntArray (exp, &(command->length));
+ } else if (command->type () & RCommand::GetStructuredData) {
+ RData *data SEXPToRData (exp);
+ if (data) command->setData (data);
+ }
+ }
+ UNPROTECT (1); // exp
+ }
}
-}
-QString *REmbedInternal::getCommandAsStringVector (const QString &command, uint *count, RKWardRError *error) {
- RK_TRACE (RBACKEND);
-
- SEXP exp;
- QString *list = 0;
-
- *error = NoError;
- SEXP parsed = parseCommand (command, error);
- if (*error == NoError) PROTECT (exp = runCommandInternalBase (parsed, error));
-
- if (*error == NoError) {
- list = SEXPToStringList (exp, count);
+ // common error/status handling
+ #ifdef RKWARD_DEBUG
+ int dl = DL_WARNING; // failed application commands are an issue worth reporting, failed user commands are not
+ if (command->type () & RCommand::User) dl = DL_DEBUG;
+ #endif
+ if (error != NoError) {
+ command->status |= RCommand::WasTried | RCommand::Failed;
+ if (error == Incomplete) {
+ command->status |= RCommand::ErrorIncomplete;
+ RK_DO (qDebug ("Command failed (incomplete)"), RBACKEND, dl);
+ } else if (error == SyntaxError) {
+ command->status |= RCommand::ErrorSyntax;
+ RK_DO (qDebug ("Command failed (syntax)"), RBACKEND, dl);
+ } else if (command->status & RCommand::Canceled) {
+ RK_DO (qDebug ("Command failed (interrupted)"), RBACKEND, dl);
+ } else {
+ command->status |= RCommand::ErrorOther;
+ #ifdef RKWARD_DEBUG
+ dl = DL_WARNING; // always interested in strange errors
+ #endif
+ RK_DO (qDebug ("Command failed (other)"), RBACKEND, dl);
+ }
+ RK_DO (qDebug ("failed command was: '%s'", command->command ().toLatin1 ().data ()), RBACKEND, dl);
+ } else {
+ command->status |= RCommand::WasTried;
}
-
- UNPROTECT (1); // exp
-
- if (*error != NoError) {
- *count = 0;
- return 0;
- }
- return list;
-}
-double *REmbedInternal::getCommandAsRealVector (const QString &command, uint *count, RKWardRError *error) {
- RK_TRACE (RBACKEND);
-
- SEXP exp;
- double *reals = 0;
-
- *error = NoError;
- SEXP parsed = parseCommand (command, error);
- if (*error == NoError) PROTECT (exp = runCommandInternalBase (parsed, error));
-
- if (*error == NoError) {
- reals = SEXPToRealArray (exp, count);
+ if (error) {
+ RK_DO (qDebug ("- error message was: '%s'", command->error ().toLatin1 ().data ()), RBACKEND, dl);
}
-
- UNPROTECT (1); // exp
-
- if (*error != NoError) {
- *count = 0;
- return 0;
- }
- return reals;
}
-
-int *REmbedInternal::getCommandAsIntVector (const QString &command, uint *count, RKWardRError *error) {
- RK_TRACE (RBACKEND);
-
- SEXP exp;
- int *integers = 0;
-
- *error = NoError;
- SEXP parsed = parseCommand (command, error);
- if (*error == NoError) PROTECT (exp = runCommandInternalBase (parsed, error));
-
- if (*error == NoError) {
- integers = SEXPToIntArray (exp, count);
- }
-
- UNPROTECT (1); // exp
-
- if (*error != NoError) {
- *count = 0;
- return 0;
- }
- return integers;
-}
-
-RData *REmbedInternal::getCommandAsRData (const QString &command, RKWardRError *error) {
- RK_TRACE (RBACKEND);
-
- SEXP exp;
- RData *data = 0;
-
- *error = NoError;
- SEXP parsed = parseCommand (command, error);
- if (*error == NoError) PROTECT (exp = runCommandInternalBase (parsed, error));
-
- if (*error == NoError) {
- data = SEXPToRData (exp);
- }
-
- UNPROTECT (1); // exp
-
- return data;
-}
Modified: branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rembedinternal.h
===================================================================
--- trunk/rkward/rkward/rbackend/rembedinternal.h 2010-10-14 19:52:33 UTC (rev 3125)
+++ branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rembedinternal.h 2010-10-18 11:13:59 UTC (rev 3129)
@@ -51,6 +51,7 @@
class QStringList;
class RData;
+class RCommand;
class QTextCodec;
/** This function converts a list of strings to a QStringList (locale aware), and returns the pointer. Needed to keep R and Qt includes separate. The strings can be deleted afterwards. Implementation is in rthread.cpp */
QString *stringsToStringList (char **strings, int count);
@@ -100,36 +101,6 @@
will only be printed if called for expressedly with print ("...") or similar.
@param suppress_incomplete make sure never to run an incomplete command */
void runCommandInternal (const QString &command, RKWardRError *error, bool print_result=false);
-/** basically a wrapper to runCommandInternal (). Tries to convert the result of the command to an array of char* after running the command. Since
-this will not ever be done for user commands, the R_Visible flag will never be set.
- at param command command to be run
- at param count length of list returned
- at param error this will be set to a value in RKWardError depending on success/failure of the command
- at returns an array of QString or 0 on failure
- at see RCommand::GetStringVector */
- QString *getCommandAsStringVector (const QString &command, unsigned int *count, RKWardRError *error);
-/** basically a wrapper to runCommandInternal (). Tries to convert the result of the command to an array of double after running the command. Since
-this will not ever be done for user commands, the R_Visible flag will never be set.
- at param command command to be run
- at param count length of array returned
- at param error this will be set to a value in RKWardError depending on success/failure of the command
- at returns an array of double or 0 on failure
- at see RCommand::GetRealVector */
- double *getCommandAsRealVector (const QString &command, unsigned int *count, RKWardRError *error);
-/** basically a wrapper to runCommandInternal (). Tries to convert the result of the command to an array of int after running the command. Since
-this will not ever be done for user commands, the R_Visible flag will never be set.
- at param command command to be run
- at param count length of array returned
- at param error this will be set to a value in RKWardError depending on success/failure of the command
- at returns an array of int or 0 on failure
- at see RCommand::GetIntVector */
- int *getCommandAsIntVector (const QString &command, unsigned int *count, RKWardRError *error);
-/** basically a wrapper to runCommandInternal (). Tries to convert the result of the command to an RData structure after running the command. Since this will not ever be done for user commands, the R_Visible flag will never be set.
- at param command command to be run
- at param error this will be set to a value in RKWardError depending on success/failure of the command
- at returns an array of int or 0 on failure
- at see RCommand::GetStructuredData */
- RData *getCommandAsRData (const QString &command, RKWardRError *error);
public:
/** call this periodically to make R's x11 windows process their events */
static void processX11Events ();
@@ -157,7 +128,11 @@
@see RCallbackArgs @see RCallbackType */
virtual void handleStandardCallback (RCallbackArgs *args) = 0;
- virtual void currentCommandWasCancelled () = 0;
+/** The command currently being executed. */
+ RCommand *current_command;
+
+ void runCommand (RCommand *command);
+
/** only one instance of this class may be around. This pointer keeps the reference to it, for interfacing to from C to C++ */
static REmbedInternal *this_pointer;
static char *na_char_internal;
Deleted: branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rpackages/rkwardtests/R/rktest.replaceRunAgainLink.R
===================================================================
--- trunk/rkward/rkward/rbackend/rpackages/rkwardtests/R/rktest.replaceRunAgainLink.R 2010-10-14 19:52:33 UTC (rev 3125)
+++ branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rpackages/rkwardtests/R/rktest.replaceRunAgainLink.R 2010-10-18 11:13:59 UTC (rev 3129)
@@ -1,46 +0,0 @@
-#' Replace "Run again" link in RKWard with code
-#'
-#' You can use this to temporarily replace .rk.rerun.plugin.link (see example below).
-#' This way, after running a plugin, you are shown the call needed to run this
-#' plugin with those settings, instead of the link.
-#'
-#' This code can be used in a plugin test suite.
-#'
-#' @title Replace "Run again" link in RKWard
-#' @usage rktest.replaceRunAgainLink(restore=FALSE)
-#' @aliases .rk.rerun.plugin.link.replacement
-#' @param restore Logical: If TRUE, restore the original behaviour.
-#' @return Replaces the "Run again" link in RKWard with the code that would have been called, or vice versa.
-#' @docType function
-#' @author Thomas Friedrichsmeier \email{thomas.friedrichsmeier@@ruhr-uni-bochum.de}, Meik Michalke \email{meik.michalke@@uni-duesseldorf.de}
-#' @keywords utilities
-#' @seealso \code{\link[rkwardtests:RKTestSuite]{RKTestSuite-class}}, \code{\link[rkwardtests:rktest.makeplugintests]{rktest.makeplugintests}}
-#' @export
-#' @rdname rktest.replaceRunAgainLink
-#' @examples
-#' rktest.replaceRunAgainLink()
-#' }
-
-rktest.replaceRunAgainLink <- function(restore=FALSE){
- if(!restore){
- # check if there's already a backup
- if(!exists(".rktest.replaceRunAgainLink.restore", where=globalenv())){
- replace <- get(".rk.rerun.plugin.link", pos=globalenv())
- assign(".rktest.replaceRunAgainLink.restore", replace, envir=globalenv())
- assign(".rk.rerun.plugin.link", .rk.rerun.plugin.link.replacement, envir=globalenv())
- }
- else {
- stop(simpleWarning("Found a backup to restore -- have you already replaced the link?"))
- }
- }
- else {
- if(exists(".rktest.replaceRunAgainLink.restore", where=globalenv())){
- restore <- get(".rktest.replaceRunAgainLink.restore", pos=globalenv())
- assign(".rk.rerun.plugin.link", restore, envir=globalenv())
- rm(".rktest.replaceRunAgainLink.restore", pos=globalenv())
- }
- else {
- stop(simpleWarning("No backup to restore found!"))
- }
- }
-}
Copied: branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rpackages/rkwardtests/R/rktest.replaceRunAgainLink.R (from rev 3126, trunk/rkward/rkward/rbackend/rpackages/rkwardtests/R/rktest.replaceRunAgainLink.R)
===================================================================
--- branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rpackages/rkwardtests/R/rktest.replaceRunAgainLink.R (rev 0)
+++ branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rpackages/rkwardtests/R/rktest.replaceRunAgainLink.R 2010-10-18 11:13:59 UTC (rev 3129)
@@ -0,0 +1,30 @@
+#' Replace "Run again" link in RKWard with code
+#'
+#' You can use this to temporarily replace .rk.rerun.plugin.link (see example below).
+#' This way, after running a plugin, you are shown the call needed to run this
+#' plugin with those settings, instead of the link.
+#'
+#' This code can be used in a plugin test suite.
+#'
+#' @title Replace "Run again" link in RKWard
+#' @usage rktest.replaceRunAgainLink(restore=FALSE)
+#' @aliases .rk.rerun.plugin.link.replacement
+#' @param restore Logical: If TRUE, restore the original behaviour.
+#' @return Replaces the "Run again" link in RKWard with the code that would have been called, or vice versa.
+#' @docType function
+#' @author Thomas Friedrichsmeier \email{thomas.friedrichsmeier@@ruhr-uni-bochum.de}, Meik Michalke \email{meik.michalke@@uni-duesseldorf.de}
+#' @keywords utilities
+#' @seealso \code{\link[rkwardtests:RKTestSuite]{RKTestSuite-class}}, \code{\link[rkwardtests:rktest.makeplugintests]{rktest.makeplugintests}}
+#' @export
+#' @rdname rktest.replaceRunAgainLink
+#' @examples
+#' rktest.replaceRunAgainLink()
+#' }
+
+rktest.replaceRunAgainLink <- function(restore=FALSE){
+ if(!restore){
+ rktest.replace (".rk.rerun.plugin.link", .rk.rerun.plugin.link.replacement, backup.name=".rk.rerun.plugin.link.manual.replace")
+ } else {
+ rktest.restore (".rk.rerun.plugin.link", backup.name=".rk.rerun.plugin.link.manual.replace")
+ }
+}
Deleted: branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rpackages/rkwardtests/R/rkwardtests-internal.R
===================================================================
--- trunk/rkward/rkward/rbackend/rpackages/rkwardtests/R/rkwardtests-internal.R 2010-10-14 19:52:33 UTC (rev 3125)
+++ branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rpackages/rkwardtests/R/rkwardtests-internal.R 2010-10-18 11:13:59 UTC (rev 3129)
@@ -1,300 +0,0 @@
-# these functions are all used internally
-
-.rk.rerun.plugin.link.replacement <- function (plugin, settings, label) {
- .rk.cat.output ("<h3>Rerun code:</h3>")
- .rk.cat.output ("<pre>")
- .rk.cat.output ("rk.call.plugin (\"")
- .rk.cat.output (plugin)
- .rk.cat.output ("\", ")
- .rk.cat.output (gsub ("^\"", "", gsub ("=", "=\"", gsub ("\n", "\", ", settings))))
- .rk.cat.output ("\", submit.mode=\"submit\")</pre>")
-}
-
-rktest.appendTestResults <- function (objecta, objectb) {
- stopifnot (inherits (objecta, "RKTestResult") && validObject (objecta))
- stopifnot (inherits (objectb, "RKTestResult") && validObject (objectb))
-
- index <- length (objecta at id)
- for (i in 1:length (objectb at id)) {
- objecta at id[index+i] = objectb at id[i]
- objecta at code_match[index+i] = objectb at code_match[i]
- objecta at output_match[index+i] = objectb at output_match[i]
- objecta at message_match[index+i] = objectb at message_match[i]
- objecta at error[index+i] = objectb at error[i]
- objecta at passed[index+i] = objectb at passed[i]
- }
-
- objecta
-}
-
-rktest.file <- function (id, extension) {
- # get or create a temporary directory
- temp.suite.dir <- rktest.createTempSuiteDir(suite at id)
- file.path(temp.suite.dir, paste (id, extension, sep=""))
-}
-
-# returns true, if file corresponds to standard.
-rktest.compare.against.standard <- function (file, fuzzy=FALSE) {
- standard_file <- file.path(getwd(), gsub ("^(.*\\/)([^\\/]*)$", "RKTestStandard\\.\\2", file))
- if (file.exists (file)) {
- # purge empty files
- info <- file.info (file)
- if (info$size[1] == 0) file.remove (file)
- }
- if (!file.exists (file)) {
- # if neither exists, that means both files are empty
- if (!file.exists (standard_file)) return ("match (empty)")
- }
-
- output.diff <- suppressWarnings (system(paste("diff", shQuote(file), shQuote(standard_file), "--strip-trailing-cr", "--new-file"), intern=TRUE))
- if (!length (output.diff)) return ("match")
- if ((length (output.diff) == 1) && (!nzchar (output.diff))) return ("match")
-
- # below: there are *some* differences
- if (fuzzy) {
- size <- if (file.exists (file)) file.info (file)$size[1] else 0
- s_size <- if (file.exists (standard_file)) file.info (standard_file)$size[1] else 0
-
- # crude test: files should at least have a similar size
- if ((size < (s_size + 20)) && (size > (s_size - 20))) return ("fuzzy match")
- }
-
- print (paste ("Differences between", file, "and", standard_file, ":"))
- print (output.diff)
-
- return ("MISMATCH")
-}
-
-rktest.runRKTest.internal <- function (test, output_file, code_file, message_file) {
- # save / restore old output file
- old_output <- rk.get.output.html.file ()
- rk.set.output.html.file (output_file)
- on.exit (rk.set.output.html.file (old_output), add=TRUE)
-
- message_file_handle <- file (message_file, open="w+")
- sink(message_file_handle, type="message")
- on.exit ({
- sink (NULL, type="message")
- close (message_file_handle)
- }, add=TRUE)
-
- rk.record.commands (code_file)
- on.exit (rk.record.commands (NULL), add=TRUE)
-
- old.symbols <- ls (envir=globalenv (), all.names=TRUE)
- on.exit ({
- # clean up any new objects created by the test
- new.symbols <- ls (envir=globalenv (), all.names=TRUE)
- new.symbols <- new.symbols[!(new.symbols %in% old.symbols)]
- rm (list=new.symbols, envir=globalenv ())
- rk.sync.global ()
- }, add=TRUE)
-
- failed <- TRUE
- try ({
- test at call ()
- failed <- FALSE
- })
-
- return (failed)
-}
-
-rktest.runRKTest <- function (test) {
- result <- new ("RKTestResult") # FALSE by default
-
- if (!inherits (test, "RKTest")) return (result)
- result at id <- test at id
- if (!validObject (test)) return (result)
-
- missing_libs <- character(0)
- for (lib in test at libraries) {
- if (!suppressWarnings (base::require (lib, character.only=TRUE, quietly=TRUE))) {
- missing_libs <- c (missing_libs, lib)
- }
- }
- if (length (missing_libs) > 0) {
- result at output_match <- result at message_match <- result at code_match <- NA_character_
- result at error <- "missing lib(s)"
- result at passed <- NA
- cat ("\nSkipping test \"", test at id, "\" due to missing libraries: \"", paste (missing_libs, collapse="\", \""), "\"\n", sep="")
- return (result)
- }
-
- output_file <- rktest.file (test at id, ".rkout")
- code_file <- rktest.file (test at id, ".rkcommands.R")
- message_file <- rktest.file (test at id, ".messages.txt")
-
- # the essence of the test:
- res.error <- rktest.runRKTest.internal (test, output_file, code_file, message_file)
- passed <- (res.error == test at expect_error)
- if (res.error) {
- if (test at expect_error) result at error <- "expected error"
- else result at error <- "ERROR"
- } else {
- if (test at expect_error) result at error <- "MISSING ERROR"
- else result at error <- "no"
- }
-
- result at output_match = rktest.compare.against.standard (output_file, test at fuzzy_output)
- if (result at output_match == "MISMATCH") passed <- FALSE
- result at message_match = rktest.compare.against.standard (message_file)
- if (result at message_match == "MISMATCH") passed <- FALSE
- result at code_match = rktest.compare.against.standard (code_file)
- if (result at code_match == "MISMATCH") passed <- FALSE
-
- result at passed <- passed
-
- result
-}
-
-rktest.cleanRKTestSuite <- function (suite, basedir=getwd ()) {
- # kept for backwards compatibility ;-)
- # basedir is superfluous, though
- rktest.removeTempSuiteDir(suite at id)
-}
-
-## Initialize test environment
-rktest.initializeEnvironment <- function () {
- # Almost all tests depend on R2HTML, indirectly, so we should really assume it (or have the user install it) at the start
- stopifnot (require (R2HTML))
-
- # create a temporary dump of the current state of things we'll alter
- # will be read by rktest.resetEnvironment()
- assign(".rktest.tmp.dump",
- list(.rk.rerun.plugin.link=.rk.rerun.plugin.link,
- rk.set.output.html.file=rk.set.output.html.file),
- envir=globalenv())
- # By default .rk.rerun.plugin.link() and .rk.make.hr() are silenced during the test runs
- .rk.rerun.plugin.link <<- .rk.make.hr <<- function (...) { list (...) }
-
- # This should make the output of rk.graph.on() fixed
- rk.get.tempfile.name <<- function (prefix="image", extension=".jpg") paste (prefix, extension, sep="")
- options (rk.graphics.type="PNG", rk.graphics.width=480, rk.graphics.height=480)
-
- # HACK: Override date, so we don't get a difference for each call of rk.header ()
- # TODO: implement a clean solution inside rk.header()
- assign ("date", function () {
- return ("DATE")
- }, envir=globalenv())
-
- # numerical precision is often a problem. To work around this in many places, reduce default printed precision to 5 digits
- options (digits=5)
-
- # Make sure i18n does not get in the way
- invisible (Sys.setenv (LANGUAGE="C"))
- if (.Platform$OS.type == "unix") invisible (Sys.setlocale ("LC_MESSAGES", "C"))
- options (useFancyQuotes=FALSE)
-
- # This version of rk.set.output.html.file does not notify the frontend of the change. Without this, you'll get lots of output windows.
- rk.set.output.html.file <<- function (x) {
- stopifnot(is.character(x))
- assign(".rk.output.html.file", x, as.environment("package:rkward"))
- }
-}
-
-# counterpart to rktest.initializeEnvironment. Restores the most important settings
-rktest.resetEnvironment <- function () {
- # return to previously dumped state
- assign(".rk.rerun.plugin.link",
- .rktest.tmp.dump[[".rk.rerun.plugin.link"]],
- envir=globalenv())
- assign("rk.set.output.html.file",
- .rktest.tmp.dump[["rk.set.output.html.file"]],
- envir=globalenv())
- rm(".rktest.tmp.dump", envir=globalenv())
-}
-
-## handling of temporary directories
-# get the path to the recent temporary directory, if exists
-rktest.getTempDir <- function(){
- if(exists(".rktest.temp.dir", where=globalenv())){
- temp.dir <- get(".rktest.temp.dir", pos=globalenv())
- if(file_test("-d", temp.dir)) {
- return(temp.dir)
- }
- else {
- return(FALSE)
- }
- }
- else {
- return(FALSE)
- }
-}
-
-# create a temporary directory for the test results
-# the path to it will be stored in an object in globalenv() and returned
-rktest.createTempDir <- function(){
- temp.dir <- rktest.getTempDir()
- # if a temp.dir already exists, we will use it!
- if(is.character(temp.dir)){
- return(temp.dir)
- } else{}
- new.temp.dir <- tempfile("rktests.")
-
- if(!dir.create(new.temp.dir, recursive=TRUE)) {
- stop(simpleError("Couldn't create temporary directory!"))
- }
- else {
- assign(".rktest.temp.dir", new.temp.dir, envir=globalenv())
- return(new.temp.dir)
- }
-}
-
-# remove the temporary directory that is defined in globalenv()
-rktest.removeTempDir <- function(){
- temp.dir <- rktest.getTempDir()
- if(is.character(temp.dir)){
- unlink(temp.dir, recursive=TRUE)
- # should the function stop here if unlink() failed?
- rm(".rktest.temp.dir", envir=globalenv())
- return(TRUE)
- }
- else {
- return(FALSE)
- }
-}
-
-# create a suite directory inside the temp dir
-# for the actual test files
-rktest.createTempSuiteDir <- function(suite.id){
- # create or get the temp base dir to use
- temp.dir <- rktest.createTempDir()
- temp.suite.dir <- file.path(temp.dir, suite.id)
- # check if this dir already exists, then just return its path
- if(file_test("-d", temp.suite.dir)){
- return(temp.suite.dir)
- }
- # if not, try to create it and again return its path
- else {
- if(!dir.create(temp.suite.dir, recursive=TRUE)) {
- stop(simpleError("Couldn't create temporary suite directory!"))
- }
- else {
- return(temp.suite.dir)
- }
- }
-}
-
-# remove just the suite temp dir
-rktest.removeTempSuiteDir <- function(suite.id){
- temp.dir <- rktest.getTempDir()
- if(is.character(temp.dir)){
- temp.suite.dir <- file.path(temp.dir, suite.id)
- # check if this dir exists
- if(file_test("-d", temp.suite.dir)){
- unlink(temp.suite.dir, recursive=TRUE)
- # if nothing is left in the base tempdir now, remove it as well
- if(length(list.files(temp.dir)) == 0) {
- rktest.removeTempDir()
- } else {}
- return(TRUE)
- }
- # if not, return FALSE
- else {
- return(FALSE)
- }
- }
- else {
- return(FALSE)
- }
-}
Copied: branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rpackages/rkwardtests/R/rkwardtests-internal.R (from rev 3126, trunk/rkward/rkward/rbackend/rpackages/rkwardtests/R/rkwardtests-internal.R)
===================================================================
--- branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rpackages/rkwardtests/R/rkwardtests-internal.R (rev 0)
+++ branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rpackages/rkwardtests/R/rkwardtests-internal.R 2010-10-18 11:13:59 UTC (rev 3129)
@@ -0,0 +1,312 @@
+# these functions are all used internally
+
+.rk.rerun.plugin.link.replacement <- function (plugin, settings, label) {
+ .rk.cat.output ("<h3>Rerun code:</h3>")
+ .rk.cat.output ("<pre>")
+ .rk.cat.output ("rk.call.plugin (\"")
+ .rk.cat.output (plugin)
+ .rk.cat.output ("\", ")
+ .rk.cat.output (gsub ("^\"", "", gsub ("=", "=\"", gsub ("\n", "\", ", settings))))
+ .rk.cat.output ("\", submit.mode=\"submit\")</pre>")
+}
+
+rktest.appendTestResults <- function (objecta, objectb) {
+ stopifnot (inherits (objecta, "RKTestResult") && validObject (objecta))
+ stopifnot (inherits (objectb, "RKTestResult") && validObject (objectb))
+
+ index <- length (objecta at id)
+ for (i in 1:length (objectb at id)) {
+ objecta at id[index+i] = objectb at id[i]
+ objecta at code_match[index+i] = objectb at code_match[i]
+ objecta at output_match[index+i] = objectb at output_match[i]
+ objecta at message_match[index+i] = objectb at message_match[i]
+ objecta at error[index+i] = objectb at error[i]
+ objecta at passed[index+i] = objectb at passed[i]
+ }
+
+ objecta
+}
+
+rktest.file <- function (id, extension) {
+ # get or create a temporary directory
+ temp.suite.dir <- rktest.createTempSuiteDir(suite at id)
+ file.path(temp.suite.dir, paste (id, extension, sep=""))
+}
+
+# returns true, if file corresponds to standard.
+rktest.compare.against.standard <- function (file, fuzzy=FALSE) {
+ standard_file <- file.path(getwd(), gsub ("^(.*\\/)([^\\/]*)$", "RKTestStandard\\.\\2", file))
+ if (file.exists (file)) {
+ # purge empty files
+ info <- file.info (file)
+ if (info$size[1] == 0) file.remove (file)
+ }
+ if (!file.exists (file)) {
+ # if neither exists, that means both files are empty
+ if (!file.exists (standard_file)) return ("match (empty)")
+ }
+
+ output.diff <- suppressWarnings (system(paste("diff", shQuote(file), shQuote(standard_file), "--strip-trailing-cr", "--new-file"), intern=TRUE))
+ if (!length (output.diff)) return ("match")
+ if ((length (output.diff) == 1) && (!nzchar (output.diff))) return ("match")
+
+ # below: there are *some* differences
+ if (fuzzy) {
+ size <- if (file.exists (file)) file.info (file)$size[1] else 0
+ s_size <- if (file.exists (standard_file)) file.info (standard_file)$size[1] else 0
+
+ # crude test: files should at least have a similar size
+ if ((size < (s_size + 20)) && (size > (s_size - 20))) return ("fuzzy match")
+ }
+
+ print (paste ("Differences between", file, "and", standard_file, ":"))
+ print (output.diff)
+
+ return ("MISMATCH")
+}
+
+rktest.runRKTest.internal <- function (test, output_file, code_file, message_file) {
+ # save / restore old output file
+ old_output <- rk.get.output.html.file ()
+ rk.set.output.html.file (output_file)
+ on.exit (rk.set.output.html.file (old_output), add=TRUE)
+
+ message_file_handle <- file (message_file, open="w+")
+ sink(message_file_handle, type="message")
+ on.exit ({
+ sink (NULL, type="message")
+ close (message_file_handle)
+ }, add=TRUE)
+
+ rk.record.commands (code_file)
+ on.exit (rk.record.commands (NULL), add=TRUE)
+
+ old.symbols <- ls (envir=globalenv (), all.names=TRUE)
+ on.exit ({
+ # clean up any new objects created by the test
+ new.symbols <- ls (envir=globalenv (), all.names=TRUE)
+ new.symbols <- new.symbols[!(new.symbols %in% old.symbols)]
+ rm (list=new.symbols, envir=globalenv ())
+ rk.sync.global ()
+ }, add=TRUE)
+
+ failed <- TRUE
+ try ({
+ test at call ()
+ failed <- FALSE
+ })
+
+ return (failed)
+}
+
+rktest.runRKTest <- function (test) {
+ result <- new ("RKTestResult") # FALSE by default
+
+ if (!inherits (test, "RKTest")) return (result)
+ result at id <- test at id
+ if (!validObject (test)) return (result)
+
+ missing_libs <- character(0)
+ for (lib in test at libraries) {
+ if (!suppressWarnings (base::require (lib, character.only=TRUE, quietly=TRUE))) {
+ missing_libs <- c (missing_libs, lib)
+ }
+ }
+ if (length (missing_libs) > 0) {
+ result at output_match <- result at message_match <- result at code_match <- NA_character_
+ result at error <- "missing lib(s)"
+ result at passed <- NA
+ cat ("\nSkipping test \"", test at id, "\" due to missing libraries: \"", paste (missing_libs, collapse="\", \""), "\"\n", sep="")
+ return (result)
+ }
+
+ output_file <- rktest.file (test at id, ".rkout")
+ code_file <- rktest.file (test at id, ".rkcommands.R")
+ message_file <- rktest.file (test at id, ".messages.txt")
+
+ # the essence of the test:
+ res.error <- rktest.runRKTest.internal (test, output_file, code_file, message_file)
+ passed <- (res.error == test at expect_error)
+ if (res.error) {
+ if (test at expect_error) result at error <- "expected error"
+ else result at error <- "ERROR"
+ } else {
+ if (test at expect_error) result at error <- "MISSING ERROR"
+ else result at error <- "no"
+ }
+
+ result at output_match = rktest.compare.against.standard (output_file, test at fuzzy_output)
+ if (result at output_match == "MISMATCH") passed <- FALSE
+ result at message_match = rktest.compare.against.standard (message_file)
+ if (result at message_match == "MISMATCH") passed <- FALSE
+ result at code_match = rktest.compare.against.standard (code_file)
+ if (result at code_match == "MISMATCH") passed <- FALSE
+
+ result at passed <- passed
+
+ result
+}
+
+rktest.cleanRKTestSuite <- function (suite, basedir=getwd ()) {
+ # kept for backwards compatibility ;-)
+ # basedir is superfluous, though
+ rktest.removeTempSuiteDir(suite at id)
+}
+
+## Convenience functions for replacing / restoring functions for the test runs
+.rktest.backups <- new.env()
+rktest.replace <- function (name, replacement, envir=as.environment ("package:rkward"), backup.name=name) {
+ if (exists (backup.name, envir=.rktest.backups, inherits=FALSE)) {
+ message ("Is looks like ", name, " has already been replaced. Not replacing it again.")
+ } else {
+ assign (backup.name, get (name, envir), envir=.rktest.backups)
+ assign (name, replacement, envir)
+ }
+}
+
+rktest.restore <- function (name, envir=as.environment ("package:rkward"), backup.name=name) {
+ if (exists (backup.name, envir=.rktest.backups, inherits=FALSE)) {
+ assign (name, get (backup.name, envir=.rktest.backups), envir=envir)
+ } else {
+ message ("No backup available for ", name, ". Already restored?")
+ }
+ rm (list=backup.name, envir=.rktest.backups)
+}
+
+## Initialize test environment
+rktest.initializeEnvironment <- function () {
+ # Almost all tests depend on R2HTML, indirectly, so we should really assume it (or have the user install it) at the start
+ stopifnot (require (R2HTML))
+
+ # By default .rk.rerun.plugin.link() and .rk.make.hr() are silenced during the test runs
+ rktest.replace (".rk.rerun.plugin.link", function (...) list (...))
+ rktest.replace (".rk.make.hr", function (...) list (...))
+
+ # This should make the output of rk.graph.on() fixed
+ rktest.replace ("rk.get.tempfile.name", function (prefix="image", extension=".jpg") paste (prefix, extension, sep=""))
+ options (rk.graphics.type="PNG", rk.graphics.width=480, rk.graphics.height=480)
+
+ # HACK: Override date, so we don't get a difference for each call of rk.header ()
+ # TODO: implement a clean solution inside rk.header()
+ # Note: date is in baseenv() and we cannot easily replace it there, so placing an override in globalenv(), instead
+ assign ("date", function () return ("DATE"), envir=globalenv())
+
+ # numerical precision is often a problem. To work around this in many places, reduce default printed precision to 5 digits
+ options (digits=5)
+
+ # Make sure i18n does not get in the way
+ invisible (Sys.setenv (LANGUAGE="C"))
+ if (.Platform$OS.type == "unix") invisible (Sys.setlocale ("LC_MESSAGES", "C"))
+ options (useFancyQuotes=FALSE)
+
+ # This version of rk.set.output.html.file does not notify the frontend of the change. Without this, you'll get lots of output windows.
+ rktest.replace ("rk.set.output.html.file", function (x) {
+ stopifnot(is.character(x))
+ assign(".rk.output.html.file", x, as.environment("package:rkward"))
+ })
+}
+
+# counterpart to rktest.initializeEnvironment. Restores the most important settings
+rktest.resetEnvironment <- function () {
+ # return to previously dumped state
+ rktest.restore (".rk.rerun.plugin.link")
+ rktest.restore (".rk.make.hr")
+ rktest.restore ("rk.get.tempfile.name")
+ rktest.restore ("rk.set.output.html.file")
+ rm (date, envir=globalenv())
+}
+
+## handling of temporary directories
+# get the path to the recent temporary directory, if exists
+rktest.getTempDir <- function(){
+ if(exists(".rktest.temp.dir", where=globalenv())){
+ temp.dir <- get(".rktest.temp.dir", pos=globalenv())
+ if(file_test("-d", temp.dir)) {
+ return(temp.dir)
+ }
+ else {
+ return(FALSE)
+ }
+ }
+ else {
+ return(FALSE)
+ }
+}
+
+# create a temporary directory for the test results
+# the path to it will be stored in an object in globalenv() and returned
+rktest.createTempDir <- function(){
+ temp.dir <- rktest.getTempDir()
+ # if a temp.dir already exists, we will use it!
+ if(is.character(temp.dir)){
+ return(temp.dir)
+ } else{}
+ new.temp.dir <- tempfile("rktests.")
+
+ if(!dir.create(new.temp.dir, recursive=TRUE)) {
+ stop(simpleError("Couldn't create temporary directory!"))
+ }
+ else {
+ assign(".rktest.temp.dir", new.temp.dir, envir=globalenv())
+ return(new.temp.dir)
+ }
+}
+
+# remove the temporary directory that is defined in globalenv()
+rktest.removeTempDir <- function(){
+ temp.dir <- rktest.getTempDir()
+ if(is.character(temp.dir)){
+ unlink(temp.dir, recursive=TRUE)
+ # should the function stop here if unlink() failed?
+ rm(".rktest.temp.dir", envir=globalenv())
+ return(TRUE)
+ }
+ else {
+ return(FALSE)
+ }
+}
+
+# create a suite directory inside the temp dir
+# for the actual test files
+rktest.createTempSuiteDir <- function(suite.id){
+ # create or get the temp base dir to use
+ temp.dir <- rktest.createTempDir()
+ temp.suite.dir <- file.path(temp.dir, suite.id)
+ # check if this dir already exists, then just return its path
+ if(file_test("-d", temp.suite.dir)){
+ return(temp.suite.dir)
+ }
+ # if not, try to create it and again return its path
+ else {
+ if(!dir.create(temp.suite.dir, recursive=TRUE)) {
+ stop(simpleError("Couldn't create temporary suite directory!"))
+ }
+ else {
+ return(temp.suite.dir)
+ }
+ }
+}
+
+# remove just the suite temp dir
+rktest.removeTempSuiteDir <- function(suite.id){
+ temp.dir <- rktest.getTempDir()
+ if(is.character(temp.dir)){
+ temp.suite.dir <- file.path(temp.dir, suite.id)
+ # check if this dir exists
+ if(file_test("-d", temp.suite.dir)){
+ unlink(temp.suite.dir, recursive=TRUE)
+ # if nothing is left in the base tempdir now, remove it as well
+ if(length(list.files(temp.dir)) == 0) {
+ rktest.removeTempDir()
+ } else {}
+ return(TRUE)
+ }
+ # if not, return FALSE
+ else {
+ return(FALSE)
+ }
+ }
+ else {
+ return(FALSE)
+ }
+}
Modified: branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rthread.cpp
===================================================================
--- trunk/rkward/rkward/rbackend/rthread.cpp 2010-10-14 19:52:33 UTC (rev 3125)
+++ branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rthread.cpp 2010-10-18 11:13:59 UTC (rev 3129)
@@ -175,50 +175,10 @@
RCommandStackModel::getModel ()->itemChange (command);
MUTEX_UNLOCK;
- if (ctype & RCommand::GetStringVector) {
- command->datatype = RData::StringVector;
- command->data = getCommandAsStringVector (ccommand, &(command->length), &error);
- } else if (ctype & RCommand::GetRealVector) {
- command->datatype = RData::RealVector;
- command->data = getCommandAsRealVector (ccommand, &(command->length), &error);
- } else if (ctype & RCommand::GetIntVector) {
- command->datatype = RData::IntVector;
- command->data = getCommandAsIntVector (ccommand, &(command->length), &error);
- } else if (ctype & RCommand::GetStructuredData) {
- RData *data = getCommandAsRData (ccommand, &error);
- if (data) command->setData (data);
- } else {
- runCommandInternal (ccommand, &error, ctype & RCommand::User);
- }
+ runCommand (command);
if (!locked || killed) processX11Events ();
MUTEX_LOCK;
- #ifdef RKWARD_DEBUG
- int dl = DL_WARNING; // failed application commands are an issue worth reporting, failed user commands are not
- if (command->type () | RCommand::User) dl = DL_DEBUG;
- #endif
- if (error != NoError) {
- command->status |= RCommand::WasTried | RCommand::Failed;
- if (error == Incomplete) {
- command->status |= RCommand::ErrorIncomplete;
- RK_DO (qDebug ("Command failed (incomplete)"), RBACKEND, dl);
- } else if (error == SyntaxError) {
- command->status |= RCommand::ErrorSyntax;
- RK_DO (qDebug ("Command failed (syntax)"), RBACKEND, dl);
- } else if (command->status & RCommand::Canceled) {
- RK_DO (qDebug ("Command failed (interrupted)"), RBACKEND, dl);
- } else {
- command->status |= RCommand::ErrorOther;
- #ifdef RKWARD_DEBUG
- dl = DL_WARNING; // always interested in strange errors
- #endif
- RK_DO (qDebug ("Command failed (other)"), RBACKEND, dl);
- }
- RK_DO (qDebug ("failed command was: '%s'", command->command ().toLatin1 ().data ()), RBACKEND, dl);
- } else {
- command->status |= RCommand::WasTried;
- }
-
flushOutput ();
if (command->type () & RCommand::DirectToOutput) {
QString outp = command->fullOutput();
@@ -236,10 +196,6 @@
}
}
- if (error) {
- RK_DO (qDebug ("- error message was: '%s'", command->error ().toLatin1 ().data ()), RBACKEND, dl);
- // runCommandInternal (".rk.init.handlers ()\n", &dummy);
- }
RK_DO (qDebug ("done running command"), RBACKEND, DL_DEBUG);
all_current_commands.pop_back();
} else {
@@ -352,17 +308,6 @@
out_buf_len = 0;
}
-/*
-void RThread::handleCondition (char **call, int call_length) {
- RK_TRACE (RBACKEND);
-
- RK_ASSERT (call_length >= 2);
- if (!call_length) return;
-
- //RThreadInternal::next_output_is_error = true;
- qDebug ("condition '%s', message '%s'", call[0], call[1]);
-} */
-
void RThread::handleError (QString *call, int call_length) {
RK_TRACE (RBACKEND);
@@ -470,13 +415,6 @@
RK_DO (qDebug ("standard callback done"), RBACKEND, DL_DEBUG);
}
-void RThread::currentCommandWasCancelled () {
- RK_TRACE (RBACKEND);
-
- RK_ASSERT (current_command);
- current_command->status |= RCommand::Canceled;
-}
-
int RThread::initialize () {
RK_TRACE (RBACKEND);
Modified: branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rthread.h
===================================================================
--- trunk/rkward/rkward/rbackend/rthread.h 2010-10-14 19:52:33 UTC (rev 3125)
+++ branches/2010_10_18_backend_restructuring_branch/rkward/rbackend/rthread.h 2010-10-18 11:13:59 UTC (rev 3129)
@@ -166,12 +166,6 @@
@see REmbedInternal::handleStandardCallback () */
void handleStandardCallback (RCallbackArgs *args);
- void currentCommandWasCancelled ();
-
-/** The command currently being executed. This is used from RInterface::cancelCommand to find out, whether the command to be cancelled is already/still running.
-TODO: check logic. RCommandStack holds current_command, too. But this may only be non-zero, when the command is actually inside the backend? */
- RCommand *current_command;
-
/** convenience struct for event passing */
struct ROutputContainer {
/** the actual output fragment */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
More information about the rkward-tracker
mailing list