diff --git a/VERSION.cmake b/VERSION.cmake index 8a71a415..b2c0d6cb 100644 --- a/VERSION.cmake +++ b/VERSION.cmake @@ -1,3 +1,3 @@ # DO NOT CHANGE THIS FILE MANUALLY! # It will be overwritten by scripts/set_dist_version.sh -SET(RKVERSION_NUMBER 0.7.1z+0.7.2+devel2) +SET(RKVERSION_NUMBER 0.7.1z+0.7.2+devel3) diff --git a/rkward/rbackend/rkrbackend.cpp b/rkward/rbackend/rkrbackend.cpp index 11da3242..d9b2420c 100644 --- a/rkward/rbackend/rkrbackend.cpp +++ b/rkward/rbackend/rkrbackend.cpp @@ -1,1769 +1,1759 @@ /*************************************************************************** rkrbackend - description ------------------- begin : Sun Jul 25 2004 copyright : (C) 2004 - 2019 by Thomas Friedrichsmeier email : thomas.friedrichsmeier@kdemail.net ***************************************************************************/ /*************************************************************************** * * * This program is free software; you can redistribute it and/or modify * * it under the terms of the GNU General Public License as published by * * the Free Software Foundation; either version 2 of the License, or * * (at your option) any later version. * * * ***************************************************************************/ #include "rkrbackend.h" #ifdef Q_OS_WIN # include # include # undef ERROR // clashes with R # define Win32 // needed for R includes #else # include # include # include #endif // statics RKRBackend *RKRBackend::this_pointer = 0; RKRBackend::RKReplStatus RKRBackend::repl_status = { QByteArray (), 0, true, 0, 0, RKRBackend::RKReplStatus::NoUserCommand, 0, RKRBackend::RKReplStatus::NotInBrowserContext, false }; void* RKRBackend::default_global_context = 0; #include #include #include #include #include #include "../core/robject.h" #include "../version.h" #include "../debug.h" #include "rkrsupport.h" #include "rkstructuregetter.h" #include "rksignalsupport.h" #include "rkreventloop.h" #include "../misc/rkcommonfunctions.h" #include #include #include #include #define R_INTERFACE_PTRS 1 // for R_CStackStart/Limit #define CSTACK_DEFNS 1 // keep R from defining tons of aliases #define R_NO_REMAP 1 // What the...? "Conflicting definitions" between stdint.h and Rinterface.h despite the #if in Rinterface.h #define uintptr_t uintptr_t // needed to detect CHARSXP encoding #define IS_UTF8(x) (Rf_getCharCE(x) == CE_UTF8) #define IS_LATIN1(x) (Rf_getCharCE(x) == CE_LATIN1) #include #include #include #include #include #include #include #include #ifdef Q_OS_WIN # include # include # include structRstart RK_R_Params; extern "C" { // why oh why isn't Rinterface.h available on Windows? LibExtern void* R_GlobalContext; LibExtern uintptr_t R_CStackLimit; LibExtern void R_SaveGlobalEnvToFile(char*); } #else # include #endif #ifndef Q_OS_WIN # include // needed for pthread_kill # include // seems to be needed at least on FreeBSD # include // for non-blocking pipes # include #endif ///// i18n #if (defined ENABLE_NLS) // ENABLE_NLS is from Rconfig.h # include # define RK_MSG_DOMAIN "rkward" // define i18n to be compatible with the easiest usage in KDE # define i18n(msgid) QString::fromUtf8(dgettext(RK_MSG_DOMAIN, msgid)) void RK_setupGettext (const char* locale_dir) { bindtextdomain (RK_MSG_DOMAIN, locale_dir); bind_textdomain_codeset (RK_MSG_DOMAIN, "UTF-8"); } #else # define i18n(msgid) QString(msgid) void RK_setupGettext (const char*) {}; #endif ///// interrupting R void RK_scheduleIntr () { RK_DEBUG (RBACKEND, DL_DEBUG, "interrupt scheduled"); RKRBackend::repl_status.interrupted = true; #ifdef Q_OS_WIN UserBreak = 1; #else RKSignalSupport::callOldSigIntHandler (); #endif } void RK_doIntr () { RK_scheduleIntr (); R_CheckUserInterrupt (); } void RKRBackend::scheduleInterrupt () { if (RKRBackendProtocolBackend::inRThread ()) { RK_scheduleIntr (); } else { #ifdef Q_OS_WIN RK_scheduleIntr (); // Thread-safe on windows?! #else pthread_kill ((pthread_t) RKRBackendProtocolBackend::instance ()->r_thread_id, SIGUSR1); // NOTE: SIGUSR1 relays to SIGINT #endif } } void RKRBackend::interruptCommand (int command_id) { RK_TRACE (RBACKEND); QMutexLocker lock (&all_current_commands_mutex); if (all_current_commands.isEmpty ()) return; if ((command_id == -1) || (all_current_commands.last ()->id == command_id)) { if (!too_late_to_interrupt) { RK_DEBUG (RBACKEND, DL_DEBUG, "scheduling interrupt for command id %d", command_id); scheduleInterrupt (); } } else { // if the command to cancel is *not* the topmost command, then do not interrupt, yet. foreach (RCommandProxy *candidate, all_current_commands) { if (candidate->id == command_id) { if (!current_commands_to_cancel.contains (candidate)) { RK_DEBUG (RBACKEND, DL_DEBUG, "scheduling delayed interrupt for command id %d", command_id); current_commands_to_cancel.append (candidate); } } } } } void clearPendingInterrupt_Worker (void *) { R_CheckUserInterrupt (); } void RKRBackend::clearPendingInterrupt () { RK_TRACE (RBACKEND); bool passed = R_ToplevelExec (clearPendingInterrupt_Worker, 0); if (!passed) RK_DEBUG (RBACKEND, DL_DEBUG, "pending interrupt cleared"); } // some functions we need that are not declared #if R_VERSION < R_Version(2,13,0) LibExtern void Rf_PrintWarnings (void); #endif extern "C" void run_Rmainloop (void); #ifndef Q_OS_WIN # include #endif #include "rdata.h" extern SEXP RKWard_RData_Tag; // ############## R Standard callback overrides BEGIN #################### Rboolean RKToplevelStatementFinishedCallback (SEXP expr, SEXP value, Rboolean succeeded, Rboolean visible, void *) { RK_TRACE (RBACKEND); Q_UNUSED (expr); Q_UNUSED (value); Q_UNUSED (visible); if ((RKRBackend::repl_status.eval_depth == 0) && (!RKRBackend::repl_status.browser_context)) { // Yes, toplevel-handlers _do_ get called in a browser context! RK_ASSERT (RKRBackend::repl_status.user_command_status = RKRBackend::RKReplStatus::UserCommandRunning); if (succeeded) { RKRBackend::repl_status.user_command_successful_up_to = RKRBackend::repl_status.user_command_parsed_up_to; if (RKRBackend::repl_status.user_command_completely_transmitted) { RKRBackend::repl_status.user_command_status = RKRBackend::RKReplStatus::NoUserCommand; RKRBackend::this_pointer->commandFinished (); } else RKRBackend::repl_status.user_command_status = RKRBackend::RKReplStatus::UserCommandTransmitted; } else { // well, this point of code is never reached with R up to 2.12.0. Instead failed user commands are handled in doError(). RKRBackend::repl_status.user_command_status = RKRBackend::RKReplStatus::UserCommandFailed; } } return (Rboolean) true; } void RKInsertToplevelStatementFinishedCallback (void *) { RK_TRACE (RBACKEND); if (RKRBackend::this_pointer->r_running) { int pos; Rf_addTaskCallback (&RKToplevelStatementFinishedCallback, 0, &RKInsertToplevelStatementFinishedCallback, "_rkward_main_callback", &pos); } } void RKTransmitNextUserCommandChunk (unsigned char* buf, int buflen) { RK_TRACE (RBACKEND); RK_ASSERT (RKRBackend::repl_status.user_command_transmitted_up_to <= RKRBackend::repl_status.user_command_buffer.length ()); // NOTE: QByteArray::length () does not count the trailing '\0' const char* current_buffer = RKRBackend::repl_status.user_command_buffer.data (); current_buffer += RKRBackend::repl_status.user_command_transmitted_up_to; // Skip what we have already transmitted bool reached_eof = false; int pos = 0; const int max_pos = buflen - 2; // one for the termination bool reached_newline = false; while (true) { buf[pos] = *current_buffer; if (*current_buffer == '\n') { reached_newline = true; break; } else if (*current_buffer == ';') break; else if (*current_buffer == '\0') { reached_eof = true; break; } if (pos >= max_pos) break; ++current_buffer; ++pos; } RKRBackend::repl_status.user_command_transmitted_up_to += (pos + 1); if (reached_eof) { buf[pos] = '\n'; RKRBackend::repl_status.user_command_completely_transmitted = true; } buf[++pos] = '\0'; if (reached_newline || reached_eof) { // Making this request synchronous is a bit painful. However, without this, it's extremely difficult to get correct interleaving of output and command lines RBackendRequest req (true, RBackendRequest::CommandLineIn); req.params["commandid"] = RKRBackend::this_pointer->current_command->id; RKRBackend::this_pointer->handleRequest (&req); } } // forward declaration needed on Windows void RCleanUp (SA_TYPE saveact, int status, int RunLast); int RReadConsole (const char* prompt, unsigned char* buf, int buflen, int hist) { RK_TRACE (RBACKEND); RK_ASSERT (buf && buflen); RK_ASSERT (RKRBackend::repl_status.eval_depth >= 0); if (RKRBackend::repl_status.browser_context) { // previously we were in a browser context. Check, whether we've left that. if (RKRBackend::default_global_context == R_GlobalContext) { RKRBackend::repl_status.browser_context = RKRBackend::RKReplStatus::NotInBrowserContext; RKRBackend::this_pointer->handlePlainGenericRequest (QStringList ("endBrowserContext"), false); } } if ((!RKRBackend::repl_status.browser_context) && (RKRBackend::repl_status.eval_depth == 0)) { while (1) { if (RKRBackend::repl_status.user_command_status == RKRBackend::RKReplStatus::NoUserCommand) { RCommandProxy *command = RKRBackend::this_pointer->fetchNextCommand (); if (!command) { #ifdef Q_OS_WIN // Can't easily override R_CleanUp on Windows, so we're calling it manually, here, then force exit if (RKRBackend::this_pointer->killed == RKRBackend::ExitNow) RCleanUp (SA_NOSAVE, 0, 0); else RCleanUp (SA_SUICIDE, 1, 0); exit (0); #endif return 0; // jumps out of the event loop! } if (!(command->type & RCommand::User)) { RKRBackend::this_pointer->runCommand (command); RKRBackend::this_pointer->commandFinished (); } else { // so, we are about to transmit a new user command, which is quite a complex endeavor... /* Some words about running user commands: - User commands can only be run at the top level of execution, not in any sub-stacks. But then, they should never get there, in the first place. - Handling user commands is totally different from all other commands, and relies on R's "REPL" (read-evaluate-print-loop). This is a whole bunch of dedicated code, but there is no other way to achieve handling of commands as if they had been entered on a plain R console (including auto-printing, and toplevel handlers). Most importantly, since important symbols are not exported, such as R_Visible. Vice versa, it is not possible to treat all commands like user commands, esp. in substacks. Problems to deal with: - R_ReadConsole serves a lot of different functions, including reading in code, but also handling user input for readline() or browser(). This makes it necessary to carefully track the current status using "repl_status". You will find repl_status to be modified at a couple of different functions. - One difficulty lies in finding out, just when a command has finished (successfully or with an error). RKToplevelStatementFinishCallback(), and doError() handle the respective cases. NOTE; in R 2.12.0 and above, Rf_countContexts() might help to find out when we are back to square 1! */ RKRBackend::repl_status.user_command_transmitted_up_to = 0; RKRBackend::repl_status.user_command_completely_transmitted = false; RKRBackend::repl_status.user_command_parsed_up_to = 0; RKRBackend::repl_status.user_command_successful_up_to = 0; RKRBackend::repl_status.user_command_buffer = RKRBackend::fromUtf8 (command->command); RKTransmitNextUserCommandChunk (buf, buflen); RKRBackend::repl_status.user_command_status = RKRBackend::RKReplStatus::UserCommandTransmitted; return 1; } } else if (RKRBackend::repl_status.user_command_status == RKRBackend::RKReplStatus::UserCommandTransmitted) { if (RKRBackend::repl_status.user_command_completely_transmitted) { // fully transmitted, but R is still asking for more? This looks like an incomplete statement. // HOWEVER: It may also have been an empty statement such as " ", so let's check whether the prompt looks like a "continue" prompt bool incomplete = false; if (RKRBackend::toUtf8 (prompt) == RKRSupport::SEXPToString (Rf_GetOption (Rf_install ("continue"), R_BaseEnv))) { incomplete = true; } if (incomplete) RKRBackend::this_pointer->current_command->status |= RCommand::Failed | RCommand::ErrorIncomplete; RKRBackend::repl_status.user_command_status = RKRBackend::RKReplStatus::ReplIterationKilled; if (RKRBackend::repl_status.user_command_parsed_up_to <= 0) RKRBackend::this_pointer->startOutputCapture (); // HACK: No capture active, but commandFinished() will try to end one Rf_error (""); // to discard the buffer } else { RKTransmitNextUserCommandChunk (buf, buflen); return 1; } } else if (RKRBackend::repl_status.user_command_status == RKRBackend::RKReplStatus::UserCommandSyntaxError) { RKRBackend::this_pointer->current_command->status |= RCommand::Failed | RCommand::ErrorSyntax; RKRBackend::repl_status.user_command_status = RKRBackend::RKReplStatus::NoUserCommand; if (RKRBackend::repl_status.user_command_parsed_up_to <= 0) RKRBackend::this_pointer->startOutputCapture (); // HACK: No capture active, but commandFinished() will try to end one RKRBackend::this_pointer->commandFinished (); } else if (RKRBackend::repl_status.user_command_status == RKRBackend::RKReplStatus::UserCommandRunning) { // This can mean three different things: // 1) User called readline () // 2) User called browser () // 3) R jumped us back to toplevel behind our backs. // Let's find out, which one it is. if (hist && (RKRBackend::default_global_context != R_GlobalContext)) { break; // this looks like a call to browser(). Will be handled below. } int n_frames = 0; RCommandProxy *dummy = RKRBackend::this_pointer->runDirectCommand ("sys.nframe()", RCommand::GetIntVector); if ((dummy->getDataType () == RData::IntVector) && (dummy->getDataLength () == 1)) { n_frames = dummy->intVector ().at (0); } // What the ??? Why does this simple version always return 0? //int n_frames = RKRSupport::SEXPToInt (RKRSupport::callSimpleFun0 (Rf_install ("sys.nframe"), R_GlobalEnv)); if (n_frames < 1) { // No active frames? This can't be a call to readline(), then, so probably R jumped us back to toplevel, behind our backs. // For safety, let's reset and start over. RKRBackend::this_pointer->current_command->status |= RCommand::Failed | RCommand::ErrorOther; RKRBackend::repl_status.user_command_status = RKRBackend::RKReplStatus::ReplIterationKilled; Rf_error(""); // to discard the buffer } else { // A call to readline(). Will be handled below break; } } else if (RKRBackend::repl_status.user_command_status == RKRBackend::RKReplStatus::UserCommandFailed) { RKRBackend::this_pointer->current_command->status |= RCommand::Failed | RCommand::ErrorOther; RKRBackend::repl_status.user_command_status = RKRBackend::RKReplStatus::NoUserCommand; RKRBackend::this_pointer->commandFinished (); } else { RK_ASSERT (RKRBackend::repl_status.user_command_status == RKRBackend::RKReplStatus::ReplIterationKilled); RKRBackend::repl_status.user_command_status = RKRBackend::RKReplStatus::NoUserCommand; RKRBackend::this_pointer->commandFinished (); } } } // here, we handle readline() calls and such, i.e. not the regular prompt for code // browser() also takes us here. QVariantMap params; RBackendRequest::RCallbackType request_type = RBackendRequest::ReadLine; params["prompt"] = QVariant (prompt); params["cancelled"] = QVariant (false); // add info for browser requests if (hist && (RKRBackend::default_global_context != R_GlobalContext)) { if (RKRBackend::repl_status.browser_context == RKRBackend::RKReplStatus::InBrowserContextPreventRecursion) { qstrncpy ((char *) buf, "n\n", buflen); // skip this, by feeding the browser() a continue return 1; } else { RKRBackend::repl_status.browser_context = RKRBackend::RKReplStatus::InBrowserContextPreventRecursion; RCommandProxy *dummy = RKRBackend::this_pointer->runDirectCommand (".rk.callstack.info()", RCommand::GetStructuredData); request_type = RBackendRequest::Debugger; if ((dummy->getDataType () == RData::StructureVector) && (dummy->getDataLength () >= 4)) { RData::RDataStorage dummy_data = dummy->structureVector (); params["calls"] = QVariant (dummy_data.at (0)->stringVector ()); params["funs"] = QVariant (dummy_data.at (1)->stringVector ()); params["envs"] = QVariant (dummy_data.at (2)->stringVector ()); params["locals"] = QVariant (dummy_data.at (3)->stringVector ()); params["relsrclines"] = QVariant (dummy_data.at (4)->stringVector ()); // hacky: passing a QList is not supported by QVariant } else { RK_ASSERT (false); } RKRBackend::repl_status.browser_context = RKRBackend::RKReplStatus::InBrowserContext; } RK_ASSERT (RKRBackend::repl_status.browser_context == RKRBackend::RKReplStatus::InBrowserContext); } RBackendRequest request (true, request_type); request.params = params; RKRBackend::this_pointer->handleRequest (&request); if (request.params["cancelled"].toBool ()) { if (RKRBackend::this_pointer->current_command) RKRBackend::this_pointer->current_command->status |= RCommand::Canceled; Rf_error ("cancelled"); RK_ASSERT (false); // should not reach this point. } QByteArray localres = RKRBackend::fromUtf8 (request.params["result"].toString ()); // need to append a newline, here. TODO: theoretically, RReadConsole comes back for more, if \0 was encountered before \n. qstrncpy ((char *) buf, localres.left (buflen - 2).append ('\n').data (), buflen); return 1; } #ifdef Q_OS_WIN int RReadConsoleWin (const char* prompt, char* buf, int buflen, int hist) { return RReadConsole (prompt, (unsigned char*) buf, buflen, hist); } #endif bool RKRBackend::fetchStdoutStderr (bool forcibly) { #ifndef Q_OS_WIN if (!forcibly) { if (!stdout_stderr_mutex.tryLock ()) return false; } else { stdout_stderr_mutex.lock (); } if (stdout_stderr_fd < 0) { stdout_stderr_mutex.unlock (); return false; } // it seems, setting this only once is not always enough. fcntl (stdout_stderr_fd, F_SETFL, fcntl (stdout_stderr_fd, F_GETFL, 0) | O_NONBLOCK); char buffer[1024]; while (true) { int bytes = read (stdout_stderr_fd, buffer, 1023); if (bytes <= 0) break; buffer[bytes] = '\0'; // NOTE: we must not risk blocking inside handleOutput, while the stdout_stderr_mutex is locked! handleOutput (RKRBackend::toUtf8 (buffer), bytes, ROutput::Warning, false); } stdout_stderr_mutex.unlock (); #endif return true; } #ifdef Q_OS_WIN bool win_do_detect_winutf8markers = false; QByteArray winutf8start, winutf8stop; #endif void RWriteConsoleEx (const char *buf, int buflen, int type) { RK_TRACE (RBACKEND); RK_DEBUG (RBACKEND, DL_DEBUG, "raw output type %d, size %d: %s", type, buflen, buf); #ifdef Q_OS_WIN // Since R 3.5.0, R on Windows (in CharacterMode == RGui) will print "UTF8 markers" around utf8-encoded sub-sections of the output. // Of course, the actual markers used are not accessible in public API... // So here we try to detect the markers (if any) from print("X", print.gap=1, quote=FALSE), i.e. an expected output of the form // [1] _s_X_e_ // Where _s_ and _e_ are the start and stop markers, respectively. if (win_do_detect_winutf8markers) { QByteArray str(buf, buflen); if (!str.contains('X')) return; // May happen. We better don't rely on how exactly the output is chunked // The value may or may not be printed in the same chunk as the row number, and the following value // so split into whatever values have arrived in this chunk, then pick the one with the 'X' QList candidates = str.split(' '); for (int i = 0; i < candidates.size(); ++i) { if (candidates[i].contains('X')) str = candidates[i]; } winutf8start = str.split('X').value(0); winutf8stop = str.split('X').value(1); return; } #endif // output while nothing else is running (including handlers?) -> This may be a syntax error. if ((RKRBackend::repl_status.eval_depth == 0) && (!RKRBackend::repl_status.browser_context) && (!RKRBackend::this_pointer->isKilled ())) { if (RKRBackend::repl_status.user_command_status == RKRBackend::RKReplStatus::UserCommandTransmitted) { // status UserCommandTransmitted might have been set from RKToplevelStatementFinishedHandler, too, in which case all is fine // (we're probably inside another task handler at this point, then) if (RKRBackend::repl_status.user_command_parsed_up_to < RKRBackend::repl_status.user_command_transmitted_up_to) { RKRBackend::repl_status.user_command_status = RKRBackend::RKReplStatus::UserCommandSyntaxError; } } else if (RKRBackend::repl_status.user_command_status == RKRBackend::RKReplStatus::ReplIterationKilled) { // purge superfluous newlines and empty output return; } else { RK_ASSERT (RKRBackend::repl_status.user_command_status != RKRBackend::RKReplStatus::NoUserCommand); } } if (RKRBackend::this_pointer->killed == RKRBackend::AlreadyDead) return; // this check is mostly for fork()ed clients if (RKRBackend::repl_status.browser_context == RKRBackend::RKReplStatus::InBrowserContextPreventRecursion) return; RKRBackend::this_pointer->fetchStdoutStderr (true); #ifdef Q_OS_WIN // See note, above. Here we handle the UTF8 markers in the output QByteArray str(buf, buflen); QString utf8; if (winutf8start.isEmpty()) { utf8 = RKRBackend::toUtf8 (buf); } else { int pos = 0; while (pos < buflen) { int start = str.indexOf(winutf8start, pos); if (start < 0) { utf8.append (RKRBackend::toUtf8 (str.mid(pos))); break; } utf8.append (RKRBackend::toUtf8 (str.left(start))); start += winutf8start.length(); if (start >= buflen) break; int end = str.indexOf(winutf8stop, start); if (end >= 0) { utf8.append(QString::fromUtf8(str.mid(start, end - start))); pos = end + winutf8stop.length(); } else { utf8.append(QString::fromUtf8(str.mid(start))); break; } } } #else QString utf8 = RKRBackend::toUtf8 (buf); #endif RKRBackend::this_pointer->handleOutput (utf8, buflen, type == 0 ? ROutput::Output : ROutput::Warning); } /** For R callbacks that we want to disable, entirely */ void RDoNothing () { //RK_TRACE (RBACKEND); } void RCleanUp (SA_TYPE saveact, int status, int RunLast) { RK_TRACE (RBACKEND); Q_UNUSED (RunLast); // R_dot_Last is called while "running" the QuitCommand if (RKRBackend::this_pointer->killed == RKRBackend::AlreadyDead) return; // Nothing to clean up if (!RKRBackend::this_pointer->r_running) return; // prevent recursion (if an error occurs, here, we get jumped to the console repl, again!) R_CheckUserInterrupt (); // if there are any user interrupts pendinging, we want them handled *NOW* RKRBackend::this_pointer->r_running = false; // we could be in a signal handler, and the stack base may have changed. uintptr_t old_lim = R_CStackLimit; R_CStackLimit = (uintptr_t)-1; if ((status != 0) && (RKRBackend::this_pointer->killed != RKRBackend::ExitNow)) RKRBackend::this_pointer->killed = RKRBackend::EmergencySaveThenExit; if (RKRBackend::this_pointer->killed == RKRBackend::EmergencySaveThenExit) { if (R_DirtyImage) { QString filename; QDir dir (RKRBackendProtocolBackend::dataDir ()); int i=0; while (true) { filename = "rkward_recover" + QString::number (i) + ".RData"; if (!dir.exists (filename)) break; i++; } filename = dir.absoluteFilePath (filename); R_SaveGlobalEnvToFile (filename.toLocal8Bit ().data ()); qDebug ("Created emergency save file in %s", qPrintable (filename)); } else { qDebug ("Image not dirty while crashing. No emergency save created."); } } if (saveact != SA_SUICIDE) { if (!RKRBackend::this_pointer->isKilled ()) { RBackendRequest request (true, RBackendRequest::BackendExit); request.params["message"] = QVariant (i18n ("The R engine has shut down with status: %1").arg (status)); // krazy:exclude=i18ncheckarg RKRBackend::this_pointer->handleRequest (&request); } R_RunExitFinalizers (); Rf_KillAllDevices (); R_CleanTempDir (); } RKRBackend::this_pointer->killed = RKRBackend::AlreadyDead; // just in case R_CStackLimit = old_lim; // well, it should not matter any longer, but... } void RSuicide (const char* message) { RK_TRACE (RBACKEND); if (!RKRBackend::this_pointer->isKilled ()) { RBackendRequest request (true, RBackendRequest::BackendExit); request.params["message"] = QVariant (i18n ("The R engine has encountered a fatal error:\n%1").arg (message)); // krazy:exclude=i18ncheckarg RKRBackend::this_pointer->handleRequest (&request); RKRBackend::this_pointer->killed = RKRBackend::EmergencySaveThenExit; RCleanUp (SA_SUICIDE, 1, 0); } else { RK_ASSERT (false); } } void RKRBackend::tryToDoEmergencySave () { RK_TRACE (RBACKEND); if (RKRBackendProtocolBackend::inRThread ()) { // If we are in the correct thread, things are easy: RKRBackend::this_pointer->killed = RKRBackend::EmergencySaveThenExit; RCleanUp (SA_SUICIDE, 1, 0); RK_doIntr (); // to jump out of the loop, if needed } else { // If we are in the wrong thread, things are a lot more tricky. We need to cause the R thread to exit, and wait for it to finish saving. // Fortunately, if we are in the wrong thread, that probably means, the R thread did *not* crash, and will thus still be functional this_pointer->killed = EmergencySaveThenExit; RK_scheduleIntr (); for (int i = 0; i < 100; ++i) { // give it up to ten seconds to interrupt and exit the loop if (!this_pointer->r_running) break; RKRBackendProtocolBackend::msleep (100); } if (!this_pointer->r_running) { for (int i = 0; i < 600; ++i) { // give it up to sixty seconds to finish saving if (this_pointer->killed == AlreadyDead) return; // finished RKRBackendProtocolBackend::msleep (100); } } RK_ASSERT (false); // Too bad, but we seem to be stuck. No chance but to return (and crash) } } QStringList charPArrayToQStringList (const char** chars, int count) { QStringList ret; for (int i = 0; i < count; ++i) { // do we need to do locale conversion, here? ret.append (chars[i]); } return ret; } int RChooseFile (int isnew, char *buf, int len) { RK_TRACE (RBACKEND); RBackendRequest request (true, RBackendRequest::ChooseFile); request.params["new"] = QVariant ((bool) isnew); RKRBackend::this_pointer->handleRequest (&request); QByteArray localres = RKRBackend::fromUtf8 (request.params["result"].toString ()); qstrncpy ((char *) buf, localres.data (), len); // return length of filename (strlen (buf)) return (qMin (len - 1, localres.size ())); } /* There are about one million possible entry points to editing / showing files. We try to cover them all, using the following bunch of functions (REditFilesHelper() and doShowEditFiles() are helpers, only) */ void REditFilesHelper (QStringList files, QStringList titles, QString wtitle, RBackendRequest::RCallbackType edit, bool delete_files, bool prompt) { RK_TRACE (RBACKEND); RK_ASSERT ((edit == RBackendRequest::ShowFiles) || (edit == RBackendRequest::EditFiles)); RBackendRequest request (edit != RBackendRequest::ShowFiles, edit); // editing is synchronous, showing is asynchronous if (edit == RBackendRequest::ShowFiles) { request.params["delete"] = QVariant (delete_files); } // see ?file.show() for what appears to be the intended meaning of these first three parameters // (which seem to be inconsistently named even in R itself...) request.params["files"] = QVariant (files); request.params["titles"] = QVariant (titles); request.params["wtitle"] = QVariant (wtitle); request.params["prompt"] = QVariant (prompt); RKRBackend::this_pointer->handleRequest (&request); } int REditFiles (int nfile, const char **file, const char **title, const char *wtitle) { RK_TRACE (RBACKEND); REditFilesHelper (charPArrayToQStringList (file, nfile), charPArrayToQStringList (title, nfile), wtitle, RBackendRequest::EditFiles, false, true); // default implementation seems to return 1 if nfile <= 0, else 1. No idea, what for. see unix/std-sys.c return (nfile <= 0); } SEXP doShowEditFiles (SEXP files, SEXP titles, SEXP wtitle, SEXP del, SEXP prompt, RBackendRequest::RCallbackType edit) { RK_TRACE (RBACKEND); QStringList file_strings = RKRSupport::SEXPToStringList (files); QStringList title_strings = RKRSupport::SEXPToStringList (titles); QString wtitle_string = RKRSupport::SEXPToString (wtitle); bool del_files = RKRSupport::SEXPToInt (del, 0) != 0; bool do_prompt = RKRSupport::SEXPToInt (prompt, 0) != 0; RK_ASSERT (file_strings.size () == title_strings.size ()); RK_ASSERT (file_strings.size () >= 1); REditFilesHelper (file_strings, title_strings, wtitle_string, edit, del_files, do_prompt); return (R_NilValue); } SEXP doEditFiles (SEXP files, SEXP titles, SEXP wtitle, SEXP prompt) { return (doShowEditFiles (files, titles, wtitle, R_NilValue, prompt, RBackendRequest::EditFiles)); } int REditFile (const char *buf) { RK_TRACE (RBACKEND); const char *editor = "none"; const char *title = ""; // does not exist in standard R 2.1.0, so no idea what to return. return REditFiles (1, const_cast (&buf), &title, editor); } SEXP doShowFiles (SEXP files, SEXP titles, SEXP wtitle, SEXP delete_files, SEXP prompt) { return (doShowEditFiles (files, titles, wtitle, delete_files, prompt, RBackendRequest::ShowFiles)); } int RShowFiles (int nfile, const char **file, const char **headers, const char *wtitle, Rboolean del, const char */* pager */) { RK_TRACE (RBACKEND); REditFilesHelper (charPArrayToQStringList (file, nfile), charPArrayToQStringList (headers, nfile), QString (wtitle), RBackendRequest::ShowFiles, (bool) del, true); // default implementation seems to returns 1 on success, 0 on failure. see unix/std-sys.c return 1; } /* FROM R_ext/RStartup.h: "Return value here is expected to be 1 for Yes, -1 for No and 0 for Cancel: symbolic constants in graphapp.h" */ int doDialogHelper (QString caption, QString message, QString button_yes, QString button_no, QString button_cancel, QString default_button, bool wait) { RK_TRACE (RBACKEND); RBackendRequest request (wait, RBackendRequest::ShowMessage); request.params["caption"] = QVariant (caption); request.params["message"] = QVariant (message); request.params["button_yes"] = QVariant (button_yes); request.params["button_no"] = QVariant (button_no); request.params["button_cancel"] = QVariant (button_cancel); request.params["default"] = QVariant (default_button); RKRBackend::this_pointer->handleRequest (&request); if (wait) { QString ret = request.params["result"].toString (); if (ret == "yes") return 1; if (ret == "no") return -1; } return 0; } SEXP doDialog (SEXP caption, SEXP message, SEXP button_yes, SEXP button_no, SEXP button_cancel, SEXP default_button, SEXP wait) { RK_TRACE (RBACKEND); int result = doDialogHelper (RKRSupport::SEXPToString (caption), RKRSupport::SEXPToString (message), RKRSupport::SEXPToString (button_yes), RKRSupport::SEXPToString (button_no), RKRSupport::SEXPToString (button_cancel), RKRSupport::SEXPToString (default_button), RKRSupport::SEXPToInt (wait)); SEXP ret = Rf_allocVector(INTSXP, 1); INTEGER (ret)[0] = result; return ret; } void RShowMessage (const char* message) { RK_TRACE (RBACKEND); doDialogHelper (i18n ("Message from the R backend"), message, "ok", QString (), QString (), "ok", true); } // TODO: currently used on windows, only! int RAskYesNoCancel (const char* message) { RK_TRACE (RBACKEND); if (RKRBackend::this_pointer->killed) return -1; // HACK: At this point R asks whether to save the workspace. We have already handled that. So return -1 for "no" return doDialogHelper (i18n ("Question from the R backend"), message, "yes", "no", "cancel", "yes", true); } void RBusy (int busy) { RK_TRACE (RBACKEND); // R_ReplIteration calls R_Busy (1) after reading in code (if needed), successfully parsing it, and right before evaluating it. if (busy) { if (RKRBackend::repl_status.user_command_status == RKRBackend::RKReplStatus::UserCommandTransmitted) { if (RKRBackend::this_pointer->current_command->type & RCommand::CCOutput) { // flush any previous output capture and start a new one if (RKRBackend::repl_status.user_command_successful_up_to > 0) RKRBackend::this_pointer->printAndClearCapturedMessages (false); RKRBackend::this_pointer->startOutputCapture (); } if (RKRBackend::this_pointer->current_command->type & RCommand::CCCommand) { QByteArray chunk = RKRBackend::repl_status.user_command_buffer.mid (RKRBackend::repl_status.user_command_parsed_up_to, RKRBackend::repl_status.user_command_transmitted_up_to - RKRBackend::repl_status.user_command_parsed_up_to); RKRBackend::this_pointer->printCommand (RKRBackend::toUtf8 (chunk)); } RKRBackend::repl_status.user_command_parsed_up_to = RKRBackend::repl_status.user_command_transmitted_up_to; RKRBackend::repl_status.user_command_status = RKRBackend::RKReplStatus::UserCommandRunning; } } } // ############## R Standard callback overrides END #################### SEXP doUpdateLocale (); // NOTE: stdout_stderr_mutex is recursive to support fork()s, better RKRBackend::RKRBackend () : stdout_stderr_mutex (QMutex::Recursive) { RK_TRACE (RBACKEND); RK_ASSERT (this_pointer == 0); this_pointer = this; current_locale_encoder = 0; // marks locale as not yet initialized doUpdateLocale (); r_running = false; current_command = 0; pending_priority_command = 0; stdout_stderr_fd = -1; } #ifdef Q_OS_WIN void RKRBackend::setupCallbacks () { RK_TRACE (RBACKEND); R_setStartTime(); R_DefParams(&RK_R_Params); // IMPORTANT: see also the #ifndef QS_WS_WIN-portion! RK_R_Params.rhome = get_R_HOME (); RK_R_Params.home = getRUser (); RK_R_Params.CharacterMode = RGui; RK_R_Params.ShowMessage = RShowMessage; RK_R_Params.ReadConsole = RReadConsoleWin; RK_R_Params.WriteConsoleEx = RWriteConsoleEx; RK_R_Params.WriteConsole = 0; RK_R_Params.CallBack = RKREventLoop::winRKEventHandlerWrapper; RK_R_Params.YesNoCancel = RAskYesNoCancel; RK_R_Params.Busy = RBusy; // TODO: callback mechanism(s) for ChosseFile, ShowFiles, EditFiles // TODO: also for RSuicide (Less important, obviously, since this should not be triggered, in normal operation). // NOTE: For RCleanUp see RReadConsole RCleanup? RK_R_Params.R_Quiet = (Rboolean) 0; RK_R_Params.R_Interactive = (Rboolean) 1; } void RKRBackend::connectCallbacks () { RK_TRACE (RBACKEND); R_SetParams(&RK_R_Params); } #else void RKRBackend::setupCallbacks () { RK_TRACE (RBACKEND); } /* SEXP dummyselectlist (SEXP, SEXP, SEXP, SEXP) { qDebug ("got it"); return R_NilValue; }*/ void RKRBackend::connectCallbacks () { RK_TRACE (RBACKEND); // IMPORTANT: see also the #ifdef QS_WS_WIN-portion! // connect R standard callback to our own functions. Important: Don't do so, before our own versions are ready to be used! R_Outputfile = NULL; R_Consolefile = NULL; ptr_R_Suicide = RSuicide; ptr_R_ShowMessage = RShowMessage; // rarely used in R on unix ptr_R_ReadConsole = RReadConsole; ptr_R_WriteConsoleEx = RWriteConsoleEx; ptr_R_WriteConsole = 0; ptr_R_ResetConsole = RDoNothing; ptr_R_FlushConsole = RDoNothing; ptr_R_ClearerrConsole = RDoNothing; ptr_R_Busy = RBusy; ptr_R_CleanUp = RCleanUp; // unfortunately, it seems, we can't safely cancel quitting anymore, here! ptr_R_ShowFiles = RShowFiles; ptr_R_ChooseFile = RChooseFile; // TODO: R devels disabled this for some reason. We set it anyway... ptr_R_EditFile = REditFile; // ptr_R_EditFiles = REditFiles; // undefined reference /* ptr_do_selectlist = dummyselectlist; ptr_do_dataviewer = dummyselectlist;*/ // these two, we won't override // ptr_R_loadhistory = ... // we keep our own history // ptr_R_savehistory = ... // we keep our own history } #endif RKRBackend::~RKRBackend () { RK_TRACE (RBACKEND); } #ifdef _MSC_VER extern "C" int R_interrupts_pending; #else LibExtern int R_interrupts_pending; #endif SEXP doError (SEXP call) { RK_TRACE (RBACKEND); if ((RKRBackend::repl_status.eval_depth == 0) && (!RKRBackend::repl_status.browser_context) && (!RKRBackend::this_pointer->isKilled ()) && (RKRBackend::repl_status.user_command_status != RKRBackend::RKReplStatus::ReplIterationKilled) && (RKRBackend::repl_status.user_command_status != RKRBackend::RKReplStatus::NoUserCommand)) { RKRBackend::repl_status.user_command_status = RKRBackend::RKReplStatus::UserCommandFailed; } if (RKRBackend::repl_status.interrupted) { // it is unlikely, but possible, that an interrupt signal was received, but the current command failed for some other reason, before processing was actually interrupted. In this case, R_interrupts_pending if not yet cleared. // NOTE: if R_interrupts_pending stops being exported one day, we might be able to use R_CheckUserInterrupt() inside an R_ToplevelExec() to find out, whether an interrupt was still pending. if (!R_interrupts_pending) { RKRBackend::repl_status.interrupted = false; if (RKRBackend::repl_status.user_command_status != RKRBackend::RKReplStatus::ReplIterationKilled) { // was interrupted only to step out of the repl iteration QMutexLocker lock (&(RKRBackend::this_pointer->all_current_commands_mutex)); foreach (RCommandProxy *command, RKRBackend::this_pointer->all_current_commands) command->status |= RCommand::Canceled; RK_DEBUG (RBACKEND, DL_DEBUG, "interrupted"); } } } else if (RKRBackend::repl_status.user_command_status != RKRBackend::RKReplStatus::ReplIterationKilled) { QString string = RKRSupport::SEXPToString (call); RKRBackend::this_pointer->handleOutput (string, string.length (), ROutput::Error); RK_DEBUG (RBACKEND, DL_DEBUG, "error '%s'", qPrintable (string)); } return R_NilValue; } -SEXP doWs (SEXP name) { - if ((!RKRBackend::this_pointer->current_command) || (RKRBackend::this_pointer->current_command->type & RCommand::ObjectListUpdate) || (!(RKRBackend::this_pointer->current_command->type & RCommand::Sync))) { // ignore Sync commands that are not flagged as ObjectListUpdate - QString sym = RKRSupport::SEXPToString(name); - if (!RKRBackend::this_pointer->changed_symbol_names.contains (sym)) RKRBackend::this_pointer->changed_symbol_names.append (sym); // schedule symbol update for later - } - return R_NilValue; -} - SEXP doSubstackCall (SEXP call) { RK_TRACE (RBACKEND); R_CheckUserInterrupt (); QStringList list = RKRSupport::SEXPToStringList (call); /* // this is a useful place to sneak in test code for profiling if (list.value (0) == "testit") { for (int i = 10000; i >= 1; --i) { setWarnOption (i); } return R_NilValue; } */ RKRBackend::this_pointer->handleHistoricalSubstackRequest (list); return R_NilValue; } SEXP doPlainGenericRequest (SEXP call, SEXP synchronous) { RK_TRACE (RBACKEND); R_CheckUserInterrupt (); QStringList ret = RKRBackend::this_pointer->handlePlainGenericRequest (RKRSupport::SEXPToStringList (call), RKRSupport::SEXPToInt (synchronous)); return RKRSupport::StringListToSEXP (ret); } void R_CheckStackWrapper (void *) { R_CheckStack (); } SEXP doUpdateLocale () { RK_TRACE (RBACKEND); RK_DEBUG (RBACKEND, DL_WARNING, "Changing locale"); if (RKRBackend::this_pointer->current_locale_encoder) { delete (RKRBackend::this_pointer->current_locale_encoder); delete (RKRBackend::this_pointer->current_locale_decoder); QTextCodec::setCodecForLocale (0); } RK_ASSERT (QTextCodec::codecForLocale ()); RKRBackend::this_pointer->current_locale_encoder = QTextCodec::codecForLocale ()->makeEncoder (QTextCodec::DefaultConversion); // NOTE: shall pass non-representable characters unmodified, rather than stripping them. RKRBackend::this_pointer->current_locale_decoder = QTextCodec::codecForLocale ()->makeDecoder (QTextCodec::DefaultConversion); RK_DEBUG (RBACKEND, DL_WARNING, "New locale codec is %s", QTextCodec::codecForLocale ()->name ().data ()); return R_NilValue; } // returns the MIME-name of the current locale encoding (from Qt) SEXP doLocaleName () { RK_TRACE (RBACKEND); RK_ASSERT (QTextCodec::codecForLocale()); SEXP res = Rf_allocVector(STRSXP, 1); PROTECT (res); SET_STRING_ELT (res, 0, Rf_mkChar (QTextCodec::codecForLocale()->name ().data ())); UNPROTECT (1); return res; } SEXP doGetStructure (SEXP toplevel, SEXP name, SEXP envlevel, SEXP namespacename) { RK_TRACE (RBACKEND); RKStructureGetter getter (false); RData *ret = getter.getStructure (toplevel, name, envlevel, namespacename); return R_MakeExternalPtr (ret, RKWard_RData_Tag, R_NilValue); } SEXP doGetGlobalEnvStructure (SEXP name, SEXP envlevel, SEXP namespacename) { RK_TRACE (RBACKEND); return doGetStructure (Rf_findVar (Rf_install (CHAR (STRING_ELT (name, 0))), R_GlobalEnv), name, envlevel, namespacename); } /** copy a symbol without touching it (esp. not forcing any promises) */ SEXP doCopyNoEval (SEXP fromname, SEXP fromenv, SEXP toname, SEXP toenv) { RK_TRACE (RBACKEND); if(!Rf_isString (fromname) || Rf_length (fromname) != 1) Rf_error ("fromname is not a single string"); if(!Rf_isString (toname) || Rf_length (toname) != 1) Rf_error ("toname is not a single string"); if(!Rf_isEnvironment (fromenv)) Rf_error ("fromenv is not an environment"); if(!Rf_isEnvironment (toenv)) Rf_error ("toenv is not an environment"); Rf_defineVar (Rf_install (CHAR (STRING_ELT (toname, 0))), Rf_findVar (Rf_install (CHAR (STRING_ELT (fromname, 0))), fromenv), toenv); return (R_NilValue); } SEXP doCaptureOutput (SEXP mode, SEXP capture_messages, SEXP capture_output, SEXP suppress_messages, SEXP suppress_output) { RK_TRACE (RBACKEND); if (RKRSupport::SEXPToInt (mode) == 1) { int cm = 0; if (RKRSupport::SEXPToInt (capture_messages)) cm |= RKROutputBuffer::RecordMessages; if (RKRSupport::SEXPToInt (capture_output)) cm |= RKROutputBuffer::RecordOutput; if (RKRSupport::SEXPToInt (suppress_messages)) cm |= RKROutputBuffer::SuppressMessages; if (RKRSupport::SEXPToInt (suppress_output)) cm |= RKROutputBuffer::SuppressOutput; RKRBackend::this_pointer->pushOutputCapture (cm); return (R_NilValue); } else { return RKRSupport::StringListToSEXP (QStringList (RKRBackend::this_pointer->popOutputCapture (RKRSupport::SEXPToInt (mode) == 2))); } } SEXP RKStartGraphicsDevice (SEXP width, SEXP height, SEXP pointsize, SEXP family, SEXP bg, SEXP title, SEXP antialias); SEXP RKD_AdjustSize (SEXP devnum); -SEXP doWs (SEXP name); void doPendingPriorityCommands (); SEXP checkEnv(SEXP a) { return RKRSupport::StringListToSEXP(RKRShadowEnvironment::environmentFor(a)->diffAndUpdate()); } bool RKRBackend::startR () { RK_TRACE (RBACKEND); setupCallbacks (); RKSignalSupport::saveDefaultSignalHandlers (); too_late_to_interrupt = false; r_running = true; int argc = 3; char* argv[3] = { qstrdup ("--slave"), qstrdup ("--no-save"), qstrdup ("--no-restore") }; Rf_initialize_R (argc, argv); #ifdef Q_OS_WIN R_set_command_line_arguments(argc, argv); FlushConsoleInputBuffer(GetStdHandle(STD_INPUT_HANDLE)); #endif #ifndef Q_OS_WIN // re-direct stdout / stderr to a pipe, so we can read output from system() calls int pfd[2]; int error = pipe (pfd); RK_ASSERT (!error); // mostly to silence compile time warning about unused return value dup2 (pfd[1], STDOUT_FILENO); dup2 (pfd[1], STDERR_FILENO); // forward both to a single channel to avoid interleaving hell, for now. close (pfd[1]); stdout_stderr_fd = pfd[0]; #endif #ifndef Q_OS_WIN // It is important to set this *early*, so R does not bail out, if there is an error in .Rprofile. // On windows, set in connectCallbacks() for technical reasons, and that seems sufficient. R_Interactive = (Rboolean) TRUE; #endif setup_Rmainloop (); #ifndef Q_OS_WIN // safety check: If we are beyond the stack boundaries already, we better disable stack checking // this has to come *after* the first setup_Rmainloop ()! Rboolean stack_ok = R_ToplevelExec (R_CheckStackWrapper, (void *) 0); if (!stack_ok) { RK_DEBUG (RBACKEND, DL_WARNING, "R_CheckStack() failed during initialization. Will disable stack checking and try to re-initialize."); RK_DEBUG (RBACKEND, DL_WARNING, "Whether or not things work after this, *please* submit a bug report."); R_CStackStart = (uintptr_t) -1; R_CStackLimit = (uintptr_t) -1; setup_Rmainloop (); } #endif #ifndef Q_OS_WIN // I am not sure, whether it is necessary to repeat this, here. It is not in R 3.0.0. // But historically, it was placed here (after setup_Rmainloop(), and conceivably there // was a reason to that (might have been reset in setup_Rmainloop() in earlier versions // of R. R_Interactive = (Rboolean) TRUE; #endif setlocale (LC_NUMERIC, "C"); // Under some conditions something appears to mess with the locale. R will not work correctly without LC_NUMERIC=C RBackendRequest req (false, RBackendRequest::SetParamsFromBackend); req.params["na_real"] = NA_REAL; // may not be initialized before setup_Rmainloop! req.params["na_int"] = NA_INTEGER; handleRequest (&req); RKWard_RData_Tag = Rf_install ("RKWard_RData_Tag"); RKSignalSupport::installSignalProxies (); // for the crash signals RKSignalSupport::installSigIntAndUsrHandlers (RK_scheduleIntr); // register our functions R_CallMethodDef callMethods [] = { // NOTE: Intermediate cast to void* to avoid compiler warning - { "ws", (DL_FUNC) (void*) &doWs, 1 }, + { "rk.check.env", (DL_FUNC) (void*) &checkEnv, 1 }, { "rk.do.error", (DL_FUNC) (void*) &doError, 1 }, { "rk.do.command", (DL_FUNC) (void*) &doSubstackCall, 1 }, { "rk.do.generic.request", (DL_FUNC) (void*) &doPlainGenericRequest, 2 }, { "rk.get.structure", (DL_FUNC) (void*) &doGetStructure, 4 }, { "rk.get.structure.global", (DL_FUNC) (void*) &doGetGlobalEnvStructure, 3 }, { "rk.copy.no.eval", (DL_FUNC) (void*) &doCopyNoEval, 4 }, { "rk.edit.files", (DL_FUNC) (void*) &doEditFiles, 4 }, { "rk.show.files", (DL_FUNC) (void*) &doShowFiles, 5 }, { "rk.dialog", (DL_FUNC) (void*) &doDialog, 7 }, { "rk.update.locale", (DL_FUNC) (void*) &doUpdateLocale, 0 }, { "rk.locale.name", (DL_FUNC) (void*) &doLocaleName, 0 }, { "rk.capture.output", (DL_FUNC) (void*) &doCaptureOutput, 5 }, { "rk.graphics.device", (DL_FUNC) (void*) &RKStartGraphicsDevice, 7}, { "rk.graphics.device.resize", (DL_FUNC) (void*) &RKD_AdjustSize, 1}, - { "rk.check.env", (DL_FUNC) (void*) &checkEnv, 1 }, { 0, 0, 0 } }; R_registerRoutines (R_getEmbeddingDllInfo(), NULL, callMethods, NULL, NULL); connectCallbacks(); RKInsertToplevelStatementFinishedCallback (0); RKREventLoop::setRKEventHandler (doPendingPriorityCommands); default_global_context = R_GlobalContext; #ifdef Q_OS_WIN // See the corresponding note in RWriteConsoleEx(). For auto-detecting UTF8 markers in console output. win_do_detect_winutf8markers = true; runDirectCommand("print(c(\"X\",\"Y\"), print.gap=1, quote=FALSE)"); win_do_detect_winutf8markers = false; #endif // What the??? Somehow the first command we run *will* appear to throw a syntax error. Some init step seems to be missing, but where? // Anyway, we just run a dummy to "clear" that trap. runDirectCommand ("\n"); // get info on R runtime version RCommandProxy *dummy = runDirectCommand ("(as.numeric(R.version$major)*1000+as.numeric(R.version$minor)*10)\n", RCommand::GetIntVector); if ((dummy->getDataType () == RData::IntVector) && (dummy->getDataLength () == 1)) { r_version = dummy->intVector ().at (0); } else { RK_ASSERT (false); r_version = 0; } delete dummy; return true; } #ifndef Q_OS_WIN static bool backend_was_forked = false; void prepareFork () { RK_TRACE (RBACKEND); if (!RKRBackendProtocolBackend::inRThread ()) return; // we need to make sure that the transmitter thread does not hold a lock on the mutex! RKRBackend::this_pointer->stdout_stderr_mutex.lock (); } void completeForkMaster () { RK_TRACE (RBACKEND); if (!RKRBackendProtocolBackend::inRThread ()) return; RKRBackend::this_pointer->stdout_stderr_mutex.unlock (); if (backend_was_forked) return; backend_was_forked = true; // Block SIGCHLD in the main thread from now on. I don't fully understand, why, but otherwise, these signals // interrupt the select() call in the fork()ing code of library(parallel) sigset_t new_set; sigemptyset (&new_set); sigaddset (&new_set, SIGCHLD); pthread_sigmask (SIG_BLOCK, &new_set, NULL); // This was used to show a warning message. Unfortunately, however, forks also occur on every popen (i.e. in system(..., intern=TRUE). // RKRBackend::this_pointer->handlePlainGenericRequest (QStringList ("forkNotification"), false); RK_DEBUG (RBACKEND, DL_WARNING, "Backend process forked (for the first time, this session)"); // NOTE: perhaps we can heuristically differentiate from popen by checking sys.calls() for something with "fork" in it. // esp., in case we discover adverse side-effects of blocking SIGCHLD, we should attempt this } void completeForkChild () { RKRBackendProtocolBackend::instance ()->r_thread_id = QThread::currentThreadId(); RKRBackend::this_pointer->killed = RKRBackend::AlreadyDead; // Not quite accurate, but disables all communication with the frontend } #endif void RKRBackend::enterEventLoop () { RK_TRACE (RBACKEND); #ifndef Q_OS_WIN pthread_atfork (prepareFork, completeForkMaster, completeForkChild); #endif run_Rmainloop (); // NOTE: Do NOT run Rf_endEmbeddedR(). It does more that we want. We rely on RCleanup, instead. } struct SafeParseWrap { SEXP cv; SEXP pr; ParseStatus status; }; void safeParseVector (void *data) { SafeParseWrap *wrap = static_cast (data); wrap->pr = 0; // TODO: Maybe we can use R_ParseGeneral instead. Then we could find the exact character, where parsing fails. Nope: not exported API wrap->pr = R_ParseVector (wrap->cv, -1, &(wrap->status), R_NilValue); } SEXP parseCommand (const QString &command_qstring, RKRBackend::RKWardRError *error) { RK_TRACE (RBACKEND); SafeParseWrap wrap; wrap.status = PARSE_NULL; QByteArray localc = RKRBackend::fromUtf8 (command_qstring); // needed so the string below does not go out of scope const char *command = localc.data (); PROTECT(wrap.cv=Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(wrap.cv, 0, Rf_mkChar(command)); // Yes, if there is an error in the parse, R does jump back to toplevel! // trying to parse list(""=1) is an example in R 3.1.1 R_ToplevelExec (safeParseVector, &wrap); SEXP pr = wrap.pr; UNPROTECT(1); if ((!pr) || (TYPEOF (pr) == NILSXP)) { // got a null SEXP. This means parse was *not* ok, even if R_ParseVector told us otherwise if (wrap.status == PARSE_OK) { wrap.status = PARSE_ERROR; printf ("weird parse error\n"); } } if (wrap.status != PARSE_OK) { if ((wrap.status == PARSE_INCOMPLETE) || (wrap.status == PARSE_EOF)) { *error = RKRBackend::Incomplete; } else if (wrap.status == PARSE_ERROR) { //extern SEXP parseError (SEXP call, int linenum); //parseError (R_NilValue, 0); *error = RKRBackend::SyntaxError; } else { // PARSE_NULL *error = RKRBackend::OtherError; } pr = R_NilValue; } return pr; } SEXP runCommandInternalBase (SEXP pr, RKRBackend::RKWardRError *error) { RK_TRACE (RBACKEND); SEXP exp; int r_error = 0; exp=R_NilValue; if (TYPEOF(pr)==EXPRSXP && LENGTH(pr)>0) { int bi=0; while (bi= RCommand::GetIntVector) && (datatype <= RCommand::GetStructuredData)); RCommandProxy *c = new RCommandProxy (command, RCommand::App | RCommand::Sync | RCommand::Internal | datatype); runCommand (c); return c; } void setWarnOption (int level) { SEXP s, t; PROTECT (t = s = Rf_allocList (2)); SET_TYPEOF (s, LANGSXP); SETCAR (t, Rf_install ("options")); t = CDR (t); SETCAR (t, Rf_ScalarInteger (level)); SET_TAG (t, Rf_install ("warn")); // The above is rougly equivalent to parseCommand ("options(warn=" + QString::number (level) + ")", &error), but ~100 times faster RKRBackend::RKWardRError error; runCommandInternalBase (s, &error); UNPROTECT (1); } void RKRBackend::runCommand (RCommandProxy *command) { RK_TRACE (RBACKEND); RK_ASSERT (command); RKWardRError error = NoError; int ctype = command->type; // easier typing // running user commands is quite different from all other commands and should have been handled by RReadConsole RK_ASSERT (!(ctype & RCommand::User)); if (ctype & RCommand::CCCommand) printCommand (command->command); if (ctype & RCommand::CCOutput) startOutputCapture (); if (ctype & RCommand::QuitCommand) { R_dot_Last (); // should run while communication with frontend is still possible RBackendRequest req (true, RBackendRequest::BackendExit); req.params["regular"] = QVariant (true); handleRequest (&req); killed = ExitNow; } else if (!(ctype & RCommand::EmptyCommand)) { repl_status.eval_depth++; SEXP parsed = parseCommand (command->command, &error); if (error == NoError) { PROTECT (parsed); SEXP exp; #if R_VERSION >= R_Version(2,13,0) int warn_level = RKRSupport::SEXPToInt (Rf_GetOption1 (Rf_install ("warn")), 0); if (warn_level != 1) setWarnOption (1); #endif PROTECT (exp = runCommandInternalBase (parsed, &error)); #if R_VERSION >= R_Version(2,13,0) if (warn_level != 1) setWarnOption (warn_level); #endif if (error == NoError) { if (ctype & RCommand::GetStringVector) { command->setData (RKRSupport::SEXPToStringList (exp)); } else if (ctype & RCommand::GetRealVector) { command->setData (RKRSupport::SEXPToRealArray (exp)); } else if (ctype & RCommand::GetIntVector) { command->setData (RKRSupport::SEXPToIntArray (exp)); } else if (ctype & RCommand::GetStructuredData) { RData *dummy = RKRSupport::SEXPToRData (exp); command->swallowData (*dummy); delete dummy; } } UNPROTECT (2); // exp, parsed } repl_status.eval_depth--; } // common error/status handling if (error != NoError) { command->status |= RCommand::WasTried | RCommand::Failed; if (error == Incomplete) { command->status |= RCommand::ErrorIncomplete; } else if (error == SyntaxError) { command->status |= RCommand::ErrorSyntax; } else if (!(command->status & RCommand::Canceled)) { command->status |= RCommand::ErrorOther; } } else { command->status |= RCommand::WasTried; } } void RKRBackend::setPriorityCommand (RCommandProxy* command) { RK_TRACE (RBACKEND); QMutexLocker lock (&priority_command_mutex); RK_ASSERT (!(command && pending_priority_command)); // for the time being, we support only one priority command at a time pending_priority_command = command; RKREventLoop::wakeRKEventHandler (); } void doPendingPriorityCommands () { RK_TRACE (RBACKEND); if (RKRBackend::this_pointer->killed) return; RCommandProxy *command = RKRBackend::this_pointer->pending_priority_command; RKRBackend::this_pointer->pending_priority_command = 0; if (command) { RK_DEBUG (RBACKEND, DL_DEBUG, "running priority command %s", qPrintable (command->command)); { QMutexLocker lock (&RKRBackend::this_pointer->all_current_commands_mutex); RKRBackend::this_pointer->all_current_commands.append (command); RKRBackend::this_pointer->current_command = command; } RKRBackend::this_pointer->runCommand (command); // TODO: Oh boy, what a mess. Sending notifications should be split from fetchNextCommand() (which is not appropriate, here) RCommandProxy *previous_command_backup = RKRBackend::this_pointer->previous_command; RKRBackend::this_pointer->commandFinished (false); RKRBackend::this_pointer->previous_command = previous_command_backup; RBackendRequest req (false, RBackendRequest::CommandOut); // NOTE: We do *NOT* want a reply to this one, and in particular, we do *NOT* want to do // (recursive) event processing while handling this. req.command = command; RKRBackend::this_pointer->handleRequest (&req); } } // On Windows, using runDirectCommand (".rk.cat.output ...") is not safe during some places where we call this, e.g. in RBusy. // Not a problem on Linux with R 2.13.0, though void RKRBackend::catToOutputFile (const QString &out) { RK_TRACE (RBACKEND); if (output_file.isEmpty ()) { RK_ASSERT (false); return; } QFile f (output_file); if (!f.open (QIODevice::WriteOnly | QIODevice::Append)) { RK_ASSERT (false); return; } f.write (RKRBackend::fromUtf8 (out)); f.close (); } void RKRBackend::printCommand (const QString &command) { RK_TRACE (RBACKEND); QStringList params ("highlightRCode"); params.append (command); QString highlighted = handlePlainGenericRequest (params, true).value (0); catToOutputFile (highlighted); } void RKRBackend::startOutputCapture () { RK_TRACE (RBACKEND); pushOutputCapture (RecordMessages | RecordOutput); } void RKRBackend::printAndClearCapturedMessages (bool with_header) { RK_TRACE (RBACKEND); QString out = popOutputCapture (true); if (out.isEmpty ()) return; if (with_header) out.prepend ("

Messages, warnings, or errors:

\n"); catToOutputFile (out); } void RKRBackend::run (const QString &locale_dir) { RK_TRACE (RBACKEND); killed = NotKilled; previous_command = 0; initialize (QFile::encodeName (locale_dir)); enterEventLoop (); } void RKRBackend::commandFinished (bool check_object_updates_needed) { RK_TRACE (RBACKEND); RK_DEBUG (RBACKEND, DL_DEBUG, "done running command %s", qPrintable (current_command->command)); { QMutexLocker lock (&all_current_commands_mutex); too_late_to_interrupt = true; } clearPendingInterrupt (); // Mutex must be unlocked for this! if (current_command->type & RCommand::CCOutput) printAndClearCapturedMessages (current_command->type & RCommand::Plugin); current_command->status -= (current_command->status & RCommand::Running); current_command->status |= RCommand::WasTried; if (current_command->type & RCommand::User) { RK_ASSERT (repl_status.eval_depth == 0); // This method may look a bit over-complex, but remember that repl_status.user_command_successful_up_to works on an *encoded* buffer QByteArray remainder_encoded = repl_status.user_command_buffer.mid (repl_status.user_command_successful_up_to); QString remainder = RKRBackend::toUtf8 (remainder_encoded); current_command->has_been_run_up_to = current_command->command.length () - remainder.length (); } if (check_object_updates_needed || (current_command->type & RCommand::ObjectListUpdate)) { checkObjectUpdatesNeeded (current_command->type & (RCommand::User | RCommand::ObjectListUpdate)); } previous_command = current_command; { QMutexLocker lock (&all_current_commands_mutex); all_current_commands.pop_back(); if (!all_current_commands.isEmpty ()) current_command = all_current_commands.last (); too_late_to_interrupt = false; } } RCommandProxy* RKRBackend::handleRequest (RBackendRequest *request, bool mayHandleSubstack) { RK_TRACE (RBACKEND); RK_ASSERT (request); RKRBackendProtocolBackend::instance ()->sendRequest (request); if ((!request->synchronous) && (!isKilled ())) { RK_ASSERT (mayHandleSubstack); // i.e. not called from fetchNextCommand return 0; } int i = 0; while (!request->done) { if (killed) return 0; // NOTE: processX11Events() may, conceivably, lead to new requests, which may also wait for sub-commands! RKREventLoop::processX11Events (); // NOTE: sleeping and waking up again can be surprisingly CPU-intensive (yes: more than the event processing, above. I have profiled it). // However, we really don't want to introduce too much delay, either. // Thus, the logic is this: If there was no reply within 2 seconds, then probably we're waiting for a user event, and can afford some more // latency (not too much, though, as we still need to process events). if (!request->done) RKRBackendProtocolBackend::msleep (++i < 200 ? 10 : 50); } // TODO remove me? while (pending_priority_command) RKREventLoop::processX11Events (); // Probably not needed, but make sure to process priority commands first at all times. RCommandProxy* command = request->takeCommand (); if (!command) return 0; { QMutexLocker lock (&all_current_commands_mutex); all_current_commands.append (command); current_command = command; } if (!mayHandleSubstack) return command; while (command) { runCommand (command); commandFinished (false); command = fetchNextCommand (); }; { QMutexLocker lock (&all_current_commands_mutex); if (current_commands_to_cancel.contains (current_command)) { RK_DEBUG (RBACKEND, DL_DEBUG, "will now interrupt parent command"); current_commands_to_cancel.removeAll (current_command); scheduleInterrupt (); } } return 0; } RCommandProxy* RKRBackend::fetchNextCommand () { RK_TRACE (RBACKEND); RBackendRequest req (!isKilled (), RBackendRequest::CommandOut); // when killed, we do *not* actually wait for the reply, before the request is deleted. req.command = previous_command; previous_command = 0; return (handleRequest (&req, false)); } void RKRBackend::handleHistoricalSubstackRequest (const QStringList &list) { RK_TRACE (RBACKEND); RBackendRequest request (true, RBackendRequest::HistoricalSubstackRequest); request.params["call"] = list; request.command = current_command; handleRequest (&request); } QStringList RKRBackend::handlePlainGenericRequest (const QStringList ¶meters, bool synchronous) { RK_TRACE (RBACKEND); RBackendRequest request (synchronous, RBackendRequest::PlainGenericRequest); if (parameters.value (0) == "getSessionInfo") { QStringList dummy = parameters; dummy.append (RKRBackendProtocolBackend::backendDebugFile ()); // NOTE: R_SVN_REVISON used to be a string, but has changed to numeric constant in R 3.0.0. QString::arg() handles both. dummy.append (QString (R_MAJOR "." R_MINOR " " R_STATUS " (" R_YEAR "-" R_MONTH "-" R_DAY " r%1)").arg (R_SVN_REVISION)); request.params["call"] = dummy; } else if (parameters.value (0) == "set.output.file") { output_file = parameters.value (1); if (parameters.length () > 2) { RK_ASSERT (parameters.value (2) == "SILENT"); return QStringList (); // For automated testing and previews. The frontend should not be notified, here } request.params["call"] = parameters; } else { request.params["call"] = parameters; } handleRequest (&request); return request.params.value ("return").toStringList (); } void RKRBackend::initialize (const char *locale_dir) { RK_TRACE (RBACKEND); // in RInterface::RInterface() we have created a fake RCommand to capture all the output/errors during startup. Fetch it repl_status.eval_depth++; fetchNextCommand (); startR (); bool lib_load_fail = false; bool sink_fail = false; // Try to load rkward package. If that fails, or is the wrong version, try to install // rkward package, then load again. QString libloc = RKRBackendProtocolBackend::dataDir () + "/.rkward_packages/" + QString::number (r_version / 10); QString versioncheck = QString ("stopifnot(.rk.app.version==\"%1\")\n").arg (RKWARD_VERSION); QString command = "local({\n" " libloc <- " + RKRSharedFunctionality::quote (libloc) + "\n" " if (!dir.exists (libloc)) dir.create(libloc, recursive=TRUE)\n" " ok <- FALSE\n" " suppressWarnings (try ({library (\"rkward\", lib.loc=libloc); " + versioncheck + "; ok <- TRUE}))\n" " if (!ok) {\n" " suppressWarnings (try (detach(\"package:rkward\", unload=TRUE)))\n" " install.packages(normalizePath(paste(libloc, \"..\", c (\"rkward.tgz\", \"rkwardtests.tgz\"), sep=\"/\")), lib=libloc, repos=NULL, type=\"source\")\n" " library (\"rkward\", lib.loc=libloc)\n" " }\n" "})\n"; if (!runDirectCommand (command)) lib_load_fail = true; RK_setupGettext (locale_dir); // must happen *after* package loading, since R will re-set it if (!runDirectCommand (versioncheck)) lib_load_fail = true; if (!runDirectCommand (".rk.fix.assignments ()\n")) sink_fail = true; // error/output sink and help browser if (!runDirectCommand ("options (error=quote (.rk.do.error ()))\n")) sink_fail = true; QString error_messages; if (lib_load_fail) { error_messages.append (i18n ("

\t- The 'rkward' R-library either could not be loaded at all, or not in the correct version. This may lead to all sorts of errors, from single missing features to complete failure to function. The most likely cause is that the last installation did not place all files in the correct place. However, in some cases, left-overs from a previous installation that was not cleanly removed may be the cause.

\

You should quit RKWard, now, and fix your installation. For help with that, see http://rkward.kde.org/compiling.

\n")); } if (sink_fail) { error_messages.append (i18n ("

\t-There was a problem setting up the communication with R. Most likely this indicates a broken installation.

\

You should quit RKWard, now, and fix your installation. For help with that, see http://rkward.kde.org/compiling.

\n")); } RBackendRequest req (true, RBackendRequest::Started); req.params["message"] = QVariant (error_messages); // blocks until RKWard is set to go (esp, it has displayed startup error messages, etc.) // in fact, a number of sub-commands are run while handling this request! handleRequest (&req); commandFinished (); // the fake startup command repl_status.eval_depth--; } void RKRBackend::checkObjectUpdatesNeeded (bool check_list) { RK_TRACE (RBACKEND); if (killed) return; /* NOTE: We're keeping separate lists of the items on the search path, and the toplevel symbols in .GlobalEnv here. This info is also present in RObjectList (and it's children). However: a) in a less convenient form, b) in the other thread. To avoid locking, and other complexity, keeping separate lists seems an ok solution. Keep in mind that only the names of only the toplevel objects are kept, here, so the memory overhead should be minimal */ bool search_update_needed = false; bool globalenv_update_needed = false; if (check_list) { // TODO: avoid parsing this over and over again RK_DEBUG (RBACKEND, DL_TRACE, "checkObjectUpdatesNeeded: getting search list"); RCommandProxy *dummy = runDirectCommand ("search ()\n", RCommand::GetStringVector); if (dummy->stringVector () != toplevel_env_names) search_update_needed = true; if (search_update_needed) toplevel_env_names = dummy->stringVector (); delete dummy; // TODO: avoid parsing this over and over again RK_DEBUG (RBACKEND, DL_TRACE, "checkObjectUpdatesNeeded: getting globalenv symbols"); dummy = runDirectCommand ("ls (globalenv (), all.names=TRUE)\n", RCommand::GetStringVector); QStringList new_globalenv_toplevel_names = dummy->stringVector (); if (new_globalenv_toplevel_names.count () != global_env_toplevel_names.count ()) { globalenv_update_needed = true; } else { for (int i = 0; i < new_globalenv_toplevel_names.count (); ++i) { // order is not important in the symbol list if (!global_env_toplevel_names.contains (new_globalenv_toplevel_names[i])) { globalenv_update_needed = true; break; } } } if (globalenv_update_needed) global_env_toplevel_names = new_globalenv_toplevel_names; delete dummy; if (search_update_needed) { // this includes an update of the globalenv, even if not needed QStringList call ("syncenvs"); call.append (QString::number (toplevel_env_names.size ())); call.append (toplevel_env_names); dummy = runDirectCommand ("loadedNamespaces ()\n", RCommand::GetStringVector); call.append (dummy->stringVector ()); delete dummy; handleHistoricalSubstackRequest (call); } if (globalenv_update_needed) { QStringList call = global_env_toplevel_names; call.prepend ("syncglobal"); // should be faster than the reverse handleHistoricalSubstackRequest (call); } } if (search_update_needed || globalenv_update_needed) { RK_DEBUG (RBACKEND, DL_TRACE, "checkObjectUpdatesNeeded: updating watches"); runDirectCommand (".rk.watch.globalenv ()\n"); } if (!changed_symbol_names.isEmpty ()) { QStringList call = changed_symbol_names; call.prepend (QString ("sync")); // should be faster than reverse handleHistoricalSubstackRequest (call); changed_symbol_names.clear (); } } bool RKRBackend::doMSleep (int msecs) { // do not trace! if (isKilled ()) return false; RKRBackendProtocolBackend::msleep (msecs); return true; } diff --git a/rkward/rbackend/rkrsupport.cpp b/rkward/rbackend/rkrsupport.cpp index 97a39335..f4c0129f 100644 --- a/rkward/rbackend/rkrsupport.cpp +++ b/rkward/rbackend/rkrsupport.cpp @@ -1,309 +1,323 @@ /*************************************************************************** rkrsupport - description ------------------- begin : Mon Oct 25 2010 copyright : (C) 2010-2018 by Thomas Friedrichsmeier email : thomas.friedrichsmeier@kdemail.net ***************************************************************************/ /*************************************************************************** * * * This program is free software; you can redistribute it and/or modify * * it under the terms of the GNU General Public License as published by * * the Free Software Foundation; either version 2 of the License, or * * (at your option) any later version. * * * ***************************************************************************/ #include "rkrsupport.h" #include #include // needed to detect CHARSXP encoding #define IS_UTF8(x) (Rf_getCharCE(x) == CE_UTF8) #define IS_LATIN1(x) (Rf_getCharCE(x) == CE_LATIN1) #include #include "rkrbackend.h" #include "../debug.h" // This is sort of idiotic, but placing RKWard_RData_Tag into the RKRSupport-namespace somehow confuses the hell out of G++ (4.4.5) SEXP RKWard_RData_Tag; SEXP RKRSupport::callSimpleFun0 (SEXP fun, SEXP env) { SEXP call = Rf_allocVector (LANGSXP, 1); PROTECT (call); SETCAR (call, fun); SEXP ret = Rf_eval (call, env); UNPROTECT (1); /* call */ return ret; } SEXP RKRSupport::callSimpleFun (SEXP fun, SEXP arg, SEXP env) { SEXP call = Rf_allocVector (LANGSXP, 2); PROTECT (call); SETCAR (call, fun); SETCAR (CDR (call), arg); SEXP ret = Rf_eval (call, env); UNPROTECT (1); /* call */ return ret; } SEXP RKRSupport::callSimpleFun2 (SEXP fun, SEXP arg1, SEXP arg2, SEXP env) { SEXP call = Rf_allocVector (LANGSXP, 3); PROTECT (call); SETCAR (call, fun); SETCAR (CDR (call), arg1); SETCAR (CDDR (call), arg2); SEXP ret = Rf_eval (call, env); UNPROTECT (1); /* call */ return ret; } bool RKRSupport::callSimpleBool (SEXP fun, SEXP arg, SEXP env) { SEXP res = callSimpleFun (fun, arg, env); if ((Rf_length (res) < 1) || (TYPEOF (res) != LGLSXP)) { RK_ASSERT (TYPEOF (res) == LGLSXP); RK_ASSERT (Rf_length (res) >= 1); return false; } return ((bool) LOGICAL (res)[0]); } /** converts SEXP to strings, and returns the first string (or QString(), if SEXP contains no strings) */ QString RKRSupport::SEXPToString (SEXP from_exp) { RK_TRACE (RBACKEND); QStringList list = SEXPToStringList (from_exp); if (!list.isEmpty ()) return list[0]; return QString (); } QStringList RKRSupport::SEXPToStringList (SEXP from_exp) { RK_TRACE (RBACKEND); // bad format? coerce the vector first if (TYPEOF (from_exp) != STRSXP) { SEXP strexp; PROTECT (strexp = Rf_coerceVector (from_exp, STRSXP)); QStringList list = SEXPToStringList (strexp); UNPROTECT (1); return list; } // format already good? Avoid coercion (and associated copying) int count = Rf_length (from_exp); QStringList list; list.reserve (count); for (int i = 0; i < count; ++i) { SEXP dummy = STRING_ELT (from_exp, i); if (TYPEOF (dummy) != CHARSXP) { list.append (QString ("not defined")); // can this ever happen? } else { if (dummy == NA_STRING) { list.append (QString ()); } else { if (IS_UTF8 (dummy)) { list.append (QString::fromUtf8 (CHAR (dummy))); } else if (IS_LATIN1 (dummy)) { list.append (QString::fromLatin1 (CHAR (dummy))); } else { list.append (RKRBackend::toUtf8 (CHAR (dummy))); } } } } return list; } SEXP RKRSupport::StringListToSEXP (const QStringList& list) { RK_TRACE (RBACKEND); SEXP ret = Rf_allocVector (STRSXP, list.size ()); for (int i = 0; i < list.size (); ++i) { #if R_VERSION >= R_Version(2,13,0) SET_STRING_ELT (ret, i, Rf_mkCharCE (list[i].toUtf8 (), CE_UTF8)); #else // TODO Rf_mkCharCE _might_ have been introduced earlier. Check if still an ongoing concern. SET_STRING_ELT (ret, i, Rf_mkChar (RKRBackend::fromUtf8 (list[i]).data ())); #endif } return ret; } RData::IntStorage RKRSupport::SEXPToIntArray (SEXP from_exp) { RK_TRACE (RBACKEND); RData::IntStorage integers; // bad format? coerce the vector first if (TYPEOF (from_exp) != INTSXP) { SEXP intexp; PROTECT (intexp = Rf_coerceVector (from_exp, INTSXP)); integers = SEXPToIntArray (intexp); UNPROTECT (1); return integers; } // format already good? Avoid coercion (and associated copying) unsigned int count = Rf_length (from_exp); integers.reserve (count); for (unsigned int i = 0; i < count; ++i) { integers.append (INTEGER (from_exp)[i]); } return integers; } /** converts SEXP to integers, and returns the first int (def_value, if SEXP contains no ints) */ int RKRSupport::SEXPToInt (SEXP from_exp, int def_value) { RK_TRACE (RBACKEND); RData::IntStorage integers = SEXPToIntArray (from_exp); if (!integers.isEmpty ()) return integers[0]; return def_value; } RData::RealStorage RKRSupport::SEXPToRealArray (SEXP from_exp) { RK_TRACE (RBACKEND); RData::RealStorage reals; // bad format? coerce the vector first if (TYPEOF (from_exp) != REALSXP) { SEXP realexp; PROTECT (realexp = Rf_coerceVector (from_exp, REALSXP)); reals = SEXPToRealArray (realexp); UNPROTECT (1); return reals; } // format already good? Avoid coercion (and associated copying) unsigned int count = Rf_length (from_exp); reals.reserve (count); for (unsigned int i = 0; i < count; ++i) { reals.append (REAL (from_exp)[i]); if (R_IsNaN (reals[i]) || R_IsNA (reals[i])) reals[i] = NA_REAL; // for our purposes, treat all non-numbers as missing } return reals; } RData *RKRSupport::SEXPToRData (SEXP from_exp) { RK_TRACE (RBACKEND); RData *data = new RData; int type = TYPEOF (from_exp); switch (type) { case LGLSXP: case INTSXP: data->setData (SEXPToIntArray (from_exp)); break; case REALSXP: data->setData (SEXPToRealArray (from_exp)); break; case VECSXP: { unsigned int count = Rf_length (from_exp); RData::RDataStorage structure_array; structure_array.reserve (count); for (unsigned int i=0; i < count; ++i) { SEXP subexp = VECTOR_ELT (from_exp, i); //PROTECT (subexp); // should already be protected as part of the parent from_exp structure_array.append (SEXPToRData (subexp)); //UNPROTECT (1); } data->setData (structure_array); } break; /* case NILSXP: data->data = 0; data->datatype = RData::NoData; count = 0; break; */ case EXTPTRSXP: if (R_ExternalPtrTag (from_exp) == RKWard_RData_Tag) { // our very own data delete data; data = (RData*) R_ExternalPtrAddr (from_exp); R_ClearExternalPtr (from_exp); break; } #if (QT_VERSION >= QT_VERSION_CHECK(5,8,0)) Q_FALLTHROUGH(); #endif //case STRSXP: // intentional fallthrough, conversion to stringlist is the default handling default: data->setData (SEXPToStringList (from_exp)); } return data; } +SEXP RKRShadowEnvironment::shadowenvbase = nullptr; QMap RKRShadowEnvironment::environments; RKRShadowEnvironment* RKRShadowEnvironment::environmentFor(SEXP baseenvir) { + // TODO: probably R_GlobalEnv should be special-cased, as this is what we'll check most often (or exclusively?) if (!environments.contains(baseenvir)) { - // TODO: Of course this is still wrong! -Rprintf("new shadow environment for %p\n", baseenvir); - SEXP tr = Rf_allocVector(INTSXP, 1); - INTEGER (tr)[0] = TRUE; - Rf_defineVar(Rf_install("shadow_hide_me"), RKRSupport::callSimpleFun2(Rf_install("new.env"), tr, R_EmptyEnv, R_GlobalEnv), R_GlobalEnv); - SEXP shadowenvir = Rf_findVar(Rf_install("shadow_hide_me"), R_GlobalEnv); + RK_DEBUG(RBACKEND, DL_DEBUG, "creating new shadow environment for %p\n", baseenvir); + if (!shadowenvbase) { + SEXP rkn = Rf_allocVector(STRSXP, 1); + SET_STRING_ELT(rkn, 0, Rf_mkChar("package:rkward")); + SEXP rkwardenv = RKRSupport::callSimpleFun(Rf_install("as.environment"), rkn, R_GlobalEnv); + RK_ASSERT(Rf_isEnvironment(rkwardenv)); + SEXP rkwardvars = Rf_eval(Rf_findVar(Rf_install(".rk.variables"), rkwardenv), R_BaseEnv); // NOTE: Rf_eval to resolve promise + RK_ASSERT(Rf_isEnvironment(rkwardvars)); + shadowenvbase = Rf_findVar(Rf_install(".rk.shadow.envs"), rkwardvars); + RK_ASSERT(Rf_isEnvironment(shadowenvbase)); + } + + char name[sizeof(void*)*2+3]; + sprintf(name, "%p", baseenvir); + SEXP tr = Rf_allocVector(LGLSXP, 1); + LOGICAL(tr)[0] = true; + Rf_defineVar(Rf_install(name), RKRSupport::callSimpleFun2(Rf_install("new.env"), tr, R_EmptyEnv, R_GlobalEnv), shadowenvbase); + SEXP shadowenvir = Rf_findVar(Rf_install(name), shadowenvbase); environments.insert(baseenvir, new RKRShadowEnvironment(baseenvir, shadowenvir)); } return environments[baseenvir]; } QStringList RKRShadowEnvironment::diffAndUpdate() { QStringList diffs; QStringList removed; Rprintf("%p %p\n", baseenvir, shadowenvir); // find the changed symbols, and copy them to the shadow environment SEXP symbols = R_lsInternal(baseenvir, TRUE); PROTECT(symbols); int count = Rf_length(symbols); for (int i = 0; i < count; ++i) { SEXP name = Rf_installChar(STRING_ELT(symbols, i)); PROTECT(name); SEXP main = Rf_findVar(name, baseenvir); SEXP cached = Rf_findVar(name, shadowenvir); if (main != cached) { Rf_defineVar(name, Rf_findVar(name, baseenvir), shadowenvir); diffs.append(RKRSupport::SEXPToString(name)); } UNPROTECT(1); } // find the symbols only in the shadow environment (those that were removed) SEXP symbols2 = R_lsInternal(shadowenvir, TRUE); PROTECT(symbols2); int count2 = Rf_length (symbols2); for (int i = 0; i < count2; ++i) { bool found = false; for (int j = 0; j < count; ++j) { if (STRING_ELT(symbols, j) == STRING_ELT(symbols2, i)) { found = true; break; } } if (!found) { removed.append(RKRSupport::SEXPToString(Rf_installChar(STRING_ELT(symbols2, i)))); } } UNPROTECT(2); - Rprintf("changed %s\n", qPrintable(diffs.join(", "))); - Rprintf("removed %s\n", qPrintable(removed.join(", "))); + RK_DEBUG(RBACKEND, DL_DEBUG, "changed %s\n", qPrintable(diffs.join(", "))); + RK_DEBUG(RBACKEND, DL_DEBUG, "removed %s\n", qPrintable(removed.join(", "))); return diffs + removed; } diff --git a/rkward/rbackend/rkrsupport.h b/rkward/rbackend/rkrsupport.h index c73920ef..0dd827af 100644 --- a/rkward/rbackend/rkrsupport.h +++ b/rkward/rbackend/rkrsupport.h @@ -1,58 +1,59 @@ /*************************************************************************** rkrsupport - description ------------------- begin : Mon Oct 25 2010 copyright : (C) 2010 by Thomas Friedrichsmeier email : thomas.friedrichsmeier@kdemail.net ***************************************************************************/ /*************************************************************************** * * * This program is free software; you can redistribute it and/or modify * * it under the terms of the GNU General Public License as published by * * the Free Software Foundation; either version 2 of the License, or * * (at your option) any later version. * * * ***************************************************************************/ #ifndef RKRSUPPORT_H #define RKRSUPPORT_H #include #include #include "rdata.h" #define R_NO_REMAP 1 #include /** Convenience functions for working with R. */ namespace RKRSupport { SEXP callSimpleFun0 (SEXP fun, SEXP env); SEXP callSimpleFun (SEXP fun, SEXP arg, SEXP env); SEXP callSimpleFun2 (SEXP fun, SEXP arg1, SEXP arg2, SEXP env); bool callSimpleBool (SEXP fun, SEXP arg, SEXP env); QStringList SEXPToStringList (SEXP from_exp); SEXP StringListToSEXP (const QStringList &list); QString SEXPToString (SEXP from_exp); RData::IntStorage SEXPToIntArray (SEXP from_exp); int SEXPToInt (SEXP from_exp, int def_value = INT_MIN); RData::RealStorage SEXPToRealArray (SEXP from_exp); RData* SEXPToRData (SEXP from_exp); }; class RKRShadowEnvironment { public: QStringList diffAndUpdate(); static RKRShadowEnvironment* environmentFor(SEXP baseenvir); private: RKRShadowEnvironment(SEXP baseenvir, SEXP shadowenvir) : baseenvir(baseenvir), shadowenvir(shadowenvir) {}; ~RKRShadowEnvironment(); SEXP baseenvir; SEXP shadowenvir; static QMap environments; + static SEXP shadowenvbase; }; #endif diff --git a/rkward/rbackend/rpackages/rkward/DESCRIPTION b/rkward/rbackend/rpackages/rkward/DESCRIPTION index 674c29c5..c9c37380 100755 --- a/rkward/rbackend/rpackages/rkward/DESCRIPTION +++ b/rkward/rbackend/rpackages/rkward/DESCRIPTION @@ -1,44 +1,44 @@ Package: rkward Type: Package Title: Provides functions related to the RKWard GUI Description: This package contains functions which are useful in combination with the RKWard GUI. Many of these functions only needed for the internal communication between RKWard and R, but some are also useful in user scripts. Author: Thomas Friedrichsmeier and the RKWard Team Maintainer: RKWard-devel mailing list Depends: R (>= 2.9.0),methods URL: https://rkward.kde.org BugReports: https://rkward.kde.org/Bugs License: GPL (>= 2) Encoding: UTF-8 LazyLoad: yes Authors@R: c(person(given="Thomas", family="Friedrichsmeier", email="thomas.friedrichsmeier@ruhr-uni-bochum.de", role=c("aut")), person(given="the RKWard team", email="rkward-devel@kde.org", role=c("cre","ctb"))) Version: 0.7.2 -Date: 2020-04-02 +Date: 2020-05-23 RoxygenNote: 6.1.0 Collate: 'base_overrides.R' 'internal.R' 'internal_debugger.R' 'internal_graphics.R' 'internal_help.R' 'public_graphics.R' 'rk.KDE_GUI-functions.R' 'rk.check.for.pandoc.R' 'rk.demo.R' 'rk.edit-functions.R' 'rk.filename-functions.R' 'rk.label-functions.R' 'rk.plugin-functions.R' 'rk.print-functions.R' 'rk.replace.function.R' 'rk.sessionInfo.R' 'rk.sync-functions.R' 'rk.utility-functions.R' 'rk.workspace-functions.R' 'rkward-package.R' 'ver.R' diff --git a/rkward/rbackend/rpackages/rkward/R/internal.R b/rkward/rbackend/rpackages/rkward/R/internal.R index 1601bc13..3b0e4764 100755 --- a/rkward/rbackend/rpackages/rkward/R/internal.R +++ b/rkward/rbackend/rpackages/rkward/R/internal.R @@ -1,446 +1,379 @@ # check the context in which this package is loaded #' @export .onAttach <- function(...) { .rk.inside.rkward.session(warn = TRUE) } # this function shall test if the rkward package was loaded in a running RKWard session #' @export .rk.inside.rkward.session <- function(warn = FALSE){ inside.rkward <- is.loaded("rk.do.generic.request") if(isTRUE(warn) & !isTRUE(inside.rkward)){ warning("You've loaded the package 'rkward', but RKWard doesn't appear to be running. If this causes trouble, try detach(\"package:rkward\").", call. = FALSE) } return(inside.rkward) } #' @export ".rk.get.meta" <- function (x) { y <- attr (x, ".rk.meta"); c (names (y), as.character (y)) } #' @export ".rk.set.meta" <- function (x, m) { eval (substitute (attr (x, ".rk.meta") <<- m)) } ".rk.set.invalid.field" <- function (x, row, value) { l <- attr (x, ".rk.invalid.fields"); if (is.null (l)) l <- list (); l[[as.character(row)]] <- value; if (length (l) == 0) l <- NULL eval (substitute (attr (x, ".rk.invalid.fields") <<- l)) } # Work around some peculiarities in R's handling of levels #' @export ".rk.set.levels" <- function (var, levels) { if (is.factor (var)) { if (is.null (levels)) levels <- NA # must never set NULL levels on a factor old_l <- levels (var) # using attr (..., "levels) instead of levels (...) in order to bypass checking eval (substitute (attr (var, "levels") <<- levels)) if ((length (var) > 0) && (is.null (old_l) || ((length (old_l) == 1L) && is.na (old_l[1L])))) { # if levels were empty, this means var is all NAs. R will set all to first level, instead, in some cases len <- length (var) eval(substitute(var[1:len] <<- NA)) } } else { eval (substitute (attr (var, "levels") <<- levels)) } } #' @export ".rk.set.invalid.fields" <- function (x, set, values, clear) { l <- attr (x, ".rk.invalid.fields"); if (is.null (l)) l <- list (); if (!missing (set)) { set <- as.character (set) l[set] <- as.character (values) } if (!missing (clear)) { l[as.character (clear)] <- NULL } if (length (l) == 0) l <- NULL eval (substitute (attr (x, ".rk.invalid.fields") <<- l)) } #' @export ".rk.data.frame.insert.row" <- function (x, index=0) { if ((index == 0) || (index > dim (x)[1])) { # insert row at end eval (substitute (x[dim(x)[1]+1,] <<- c (NA))) } else { for (i in dim (x)[1]:index) { eval (substitute (x[i+1,] <<- x[i,])) } eval (substitute (row.names (x) <<- c (1:dim(x)[1]))) eval (substitute (x[index,] <<- c (NA))) } } # TODO: is there a nice way to get rid of a row without removing the meta-data? #' @export ".rk.data.frame.delete.row" <- function (x, index) { attriblist <- list () for (i in 1:dim (x)[2]) { attriblist[[names (x)[i]]] <- attributes (x[[i]]) } newx <- x[-index, , drop=FALSE] row.names (newx) <- c (1:dim(newx)[1]) for (i in 1:dim (newx)[2]) { attributes (newx[[i]]) <- attriblist[[names (newx)[i]]] } eval (substitute (x <<- newx)) } # function below is only needed to ensure a nice ordering of the columns. Simply adding a new column would be much easier than this. #' @export ".rk.data.frame.insert.column" <- function (x, label, index=0) { column <- rep (as.numeric (NA), times=dim (x)[1]) if ((index == 0) || (index > dim (x)[2])) { # insert column at end eval (substitute (x[[label]] <<- column)) } else { for (i in dim (x)[2]:index) { eval (substitute (x[i+1] <<- x[[i]])) eval (substitute (names (x)[i+1] <<- names (x)[i])) } eval (substitute (x[index] <<- column)) eval (substitute (names (x)[index] <<- label)) } } #' @export ".rk.do.error" <- function () { # comment in R sources says, it may not be good to query options during error handling. But what can we do, if R_ShowErrorMessages is not longer exported? if (getOption ("show.error.messages")) { .Call ("rk.do.error", c (geterrmessage ()), PACKAGE="(embedding)"); } } #' @export ".rk.set.reply" <- function (x) .rk.variables$.rk.rkreply <- x #' @export ".rk.do.call" <- function (x, args=NULL) { .rk.set.reply (NULL) .Call ("rk.do.command", c (x, args), PACKAGE="(embedding)"); return (.rk.variables$.rk.rkreply) } #' @export ".rk.do.plain.call" <- function (x, args=NULL, synchronous=TRUE) { .Call ("rk.do.generic.request", c (x, args), isTRUE (synchronous), PACKAGE="(embedding)") } #' @export ".rk.find.package.pluginmaps" <- function (package, all.maps=FALSE) { if(isTRUE(all.maps)){ # look for all pluginmaps in the rkward folder pluginmaps <- sapply(package, function(this.package){ dir(system.file("rkward", package=this.package), pattern="*.pluginmap", full.names=TRUE) }) } else { # check if a main .pluginmap file is provided pluginmaps <- sapply(package, function(this.package){ system.file(file.path("rkward", paste(this.package, ".pluginmap", sep="")), package=this.package) }) } return(pluginmaps) } # Gather status information on installed and available packages. # Return value is used in class RKRPackageInstallationStatus of the frontend #' @export ".rk.get.package.installation.state" <- function () { # fetch all status information available <- .rk.cached.available.packages () inst <- installed.packages (fields="Title") old <- as.data.frame (rk.old.packages (available=available), stringsAsFactors=FALSE) new <- new.packages (instPkgs=inst, available=available) # convert info to a more suitable format available <- as.data.frame (available, stringsAsFactors=FALSE) inst <- as.data.frame (inst, stringsAsFactors=FALSE) oldinst <- match (paste (old$Package, old$LibPath), paste (inst$Package, inst$LibPath)) # convert package names to position with in the installed packages info oldavail <- match (old$Package, available$Package) # convert package names to position with in the available packages info new <- match (new, available$Package) # same for new packages # as a side effect, we update the list of known installed packages in the frontend .rk.do.plain.call ("updateInstalledPackagesList", sort (unique (as.character (inst$Package))), synchronous=FALSE) list ("available" = list (available$Package, available$Title, available$Version, available$Repository, grepl ("rkward", available$Enhances)), "installed" = list (inst$Package, inst$Title, inst$Version, inst$LibPath, grepl ("rkward", inst$Enhances)), "new" = as.integer (new - 1), "old" = list (as.integer (oldinst - 1), as.integer (oldavail - 1)), "repos" = as.character (options("repos")$repos)) } # package information formats may - according to the help - be subject to change. Hence this function to cope with "missing" values # also it concatenates everything to a single vector, so we can easily get the whole structure with a single call #' @export ".rk.get.installed.packages" <- function () { x <- as.data.frame(installed.packages(fields="Title")) # does a package enhance RKWard, i.e. provide plugins? enhance.rk <- ifelse(is.na(x$Enhances), FALSE, grepl("rkward", x$Enhances)) # as a side effect, we update the list of known installed packages in the frontend .rk.do.plain.call ("updateInstalledPackagesList", sort (unique (as.character (x$Package))), synchronous=FALSE) # check for pluginmaps only in packages which enhance RKWard rk.load.pluginmaps (.rk.find.package.pluginmaps(x$Package[enhance.rk]), force.add=FALSE, force.reload=FALSE) return(list(Package=as.character(x$Package), Title=as.character(x$Title), Version=as.character(x$Version), LibPath=as.character(x$LibPath), EnhanceRK=as.logical(enhance.rk))) } # This function works like available.packages (with no arguments), but does simple caching of the result, and of course uses a cache if available. Cache is only used, if it is less than 1 hour old, and options("repos") is unchanged. #' @export ".rk.cached.available.packages" <- function () { x <- NULL if (exists ("available.packages.cache", envir=.rk.variables) && (!is.null (.rk.variables$available.packages.cache))) { if (.rk.variables$available.packages.cache$timestamp > (Sys.time () - 3600)) { if (all (.rk.variables$available.packages.cache$repos$repos == options ("repos")$repos)) { x <- .rk.variables$available.packages.cache$cache } } } if (is.null(x)) { x <- available.packages(fields="Title") .rk.variables$available.packages.cache <- list (cache = x, timestamp = Sys.time (), repos = options ("repos")) } return (x) } #".rk.init.handlers" <- function () { # options (warning.expression = expression ()) # .Internal (.addCondHands (c ("message", "warning", "error"), list (function (m) { .Call ("rk.do.condition", c ("m", conditionMessage (m))) }, function (w) { .Call ("rk.do.condition", c ("w", conditionMessage (w))) }, function (e) { .Call ("rk.do.condition", c ("e", conditionMessage (e))) }), globalenv (), NULL, TRUE)) #} -# these functions can be used to track assignments to R objects. The main interfaces are .rk.watch.symbol (k) and .rk.unwatch.symbol (k). This works by copying the symbol to a local environment, removing it, and replacing it by an active binding to the backup location -".rk.watched.symbols" <- new.env () - -#' @export -".rk.make.watch.f" <- function (k) { - # we need to make sure, the functions we use are *not* looked up as symbols in .GlobalEnv. - # else, for instance, if the user names a symbol "missing", and we try to resolve it in the - # wrapper function below, evaluation would recurse to look up "missing" in the .GlobalEnv - # due to the call to "if (!missing(value))". - missing <- base::missing - .Call <- base::.Call - - # NOTE: - Another _small_ speedup (~10%) _could_ be achieved by pre-compiling the returned function (compiler::cmpfun()). - # - Limiting the .Call()s (by keeping/clearing a flag of whether change has been signalled, before) does not have any measurable effect, but adds complexity - function (value) { - if (missing (value)) { - x - } else { - .Call ("ws", k, PACKAGE="(embedding)"); - x <<- value - } - } -} - -#' @export -".rk.watch.symbol" <- function (k) { - if (bindingIsActive(k, globalenv())) { - # If the symbol already is an active binding, give up for now, as there is not currently a user-accessible way to copy an active binding (not just its value) - message("Note: RKWard cannot watch active binding ", k, " for changes.") - } else { - f <- .rk.make.watch.f (k) - .Call ("rk.copy.no.eval", k, globalenv(), "x", environment (f), PACKAGE="(embedding)"); - rm (list=k, envir=globalenv ()) - .rk.makeActiveBinding.default (k, f, globalenv ()) - } - .rk.watched.symbols[[k]] <- TRUE - - invisible (TRUE) -} - -# not needed by rkward but provided for completeness -#' @export -".rk.unwatch.symbol" <- function (k) { - x <- get(k, envir=globalenv ()) - rm (list=k, envir=globalenv ()) - assign (k, x, envir=globalenv ()) - rm (k, envir=.rk.watched.symbols); - - invisible (TRUE) -} - -#' @export -".rk.watch.globalenv" <- function () { - newlist <- ls (globalenv (), all.names=TRUE) - oldlist <- ls (.rk.watched.symbols, all.names=TRUE) - for (old in oldlist) { # unwatch no longer present items - if (!(old %in% newlist)) { - rm (list=old, envir=.rk.watched.symbols); - } - } - - for (new in newlist) { # watch new items - if (!(new %in% oldlist)) { - .rk.watch.symbol (new) - } - } -} - #' @export ".rk.get.vector.data" <- function (x) { ret <- list (); ret$data <- as.vector (unclass (x)); ret$levels <- levels (x) if (is.null (ret$levels)) ret$levels <- "" i <- attr (x, ".rk.invalid.fields") ret$invalids <- as.character (c (names (i), i)); if (length (ret$invalids) == 0) ret$invalids <- "" ret } # Change storage type of x to mode newmode. # Keeps the .rk.meta attribute, and levels attributes, but the data is erased! #' @export ".rk.set.vector.mode" <- function (x, fun, envir=parent.frame ()) { y <- fun(rep(NA, length.out = length(x))) newattrs <- attributes(y) if (is.null (newattrs)) newattrs <- list () newattrs[[".rk.meta"]] <- attributes(x)[[".rk.meta"]] lvls <- attributes(x)[["levels"]] if (!is.null (lvls)) newattrs[["levels"]] <- lvls attributes(y) <- newattrs eval (substitute (x <- y), envir=envir) } #' @export ".rk.get.structure" <- function (x, name, envlevel=0, namespacename=NULL) { .Call ("rk.get.structure", x, as.character (name), as.integer (envlevel), namespacename, PACKAGE="(embedding)") } #' @export ".rk.try.get.namespace" <- function (name) { tryCatch (asNamespace (name), error = function(e) NULL) } #' @export ".rk.get.structure.global" <- function (name, envlevel=0, namespacename=NULL) { .Call ("rk.get.structure.global", as.character (name), as.integer (envlevel), namespacename, PACKAGE="(embedding)") } #' @export ".rk.get.slots" <- function (x) { slotnames <- methods::slotNames (class (x)) ret <- lapply (slotnames, function (slotname) slot (x, slotname)) names (ret) <- slotnames ret } #' @export ".rk.get.environment.children" <- function (x, envlevel=0, namespacename=NULL) { ret <- list () if (envlevel < 2) { # prevent infinite recursion lst <- ls (x, all.names=TRUE) if (is.null (namespacename)) { for (childname in lst) { ret[[childname]] <- .rk.get.structure (name=childname, envlevel=envlevel, envir=x) } } else { # for R 2.4.0 or greater: operator "::" works if package has no namespace at all, or has a namespace with the symbol in it ns <- tryCatch (asNamespace (namespacename), error = function(e) NULL) for (childname in lst) { misplaced <- FALSE if ((!is.null (ns)) && (!exists (childname, envir=ns, inherits=FALSE))) misplaced <- TRUE ret[[childname]] <- .rk.get.structure (name=childname, envlevel=envlevel, misplaced=misplaced, envir=x) } } } ret } # hidden, as this is not portable to different output formats #' @export ".rk.cat.output" <- function (x) { cat (x, file = rk.get.output.html.file(), append = TRUE) } #' @export ".rk.rerun.plugin.link" <- function (plugin, settings, label) { .rk.cat.output (paste ("", label, "", sep="")) } #' @export ".rk.make.hr" <- function () { .rk.cat.output ("
\n"); } # General purpose storage environment (which will hopefully never get locked by R) #' @export ".rk.variables" <- new.env () assign(".rk.active.device", 1, envir=.rk.variables) assign(".rk.output.html.file", NULL, envir=.rk.variables) assign(".rk.rkreply", NULL, envir=.rk.variables) assign("available.packages.cache", NULL, envir=.rk.variables) +assign(".rk.shadow.envs", new.env(parent=emptyenv()), envir=.rk.variables) #' @export ".rk.backups" <- new.env () # where masking is not enough, we need to assign in the original environment / namespace. This can only be done after package loading, # so we have a separate function for that. #' @export ".rk.fix.assignments" <- function () { ## History manipulation function (overloads for functions by the same name in package utils) rk.replace.function ("loadhistory", as.environment ("package:utils"), function (file = ".Rhistory") { invisible (.rk.do.plain.call ("commandHistory", c ("set", readLines (file)))) }, copy.formals = FALSE) rk.replace.function ("savehistory", as.environment ("package:utils"), function (file = ".Rhistory") { invisible (writeLines (.rk.do.plain.call ("commandHistory", "get"), file)) }, copy.formals = FALSE) rk.replace.function ("timestamp", as.environment ("package:utils"), function (stamp = date(), prefix = "##------ ", suffix = " ------##", quiet = FALSE) { stamp <- paste(prefix, stamp, suffix, sep = "") .rk.do.plain.call ("commandHistory", c ("append", stamp)) if (!quiet) cat(stamp, sep = "\n") invisible(stamp) }, copy.formals = FALSE) ## Interactive menus rk.replace.function ("select.list", as.environment ("package:utils"), function () { # the "list" parameter was renamed to "choices" in R 2.11.0 if (!exists ("list", inherits=FALSE)) list <- choices # the "graphics" parameter was introduced in R 2.11.0, so we cannot rely on its existance if (!exists ("graphics", inherits=FALSE)) graphics <- TRUE if (graphics) { return (rk.select.list (list, preselect, multiple, title)) } # for text list, use the default implementation eval (body (.rk.backups$select.list)) }) rk.replace.function ("menu", as.environment ("package:utils"), function () { if (graphics) { res <- rk.select.list (choices, multiple=FALSE, title=title) return (match(res, choices, nomatch = 0L)) } # for text menus, use the default implementation eval (body (.rk.backups$menu)) }) # call separate assignments functions: if (exists (".rk.fix.assignments.graphics")) eval (body (.rk.fix.assignments.graphics)) # internal_graphics.R }