RInside Version 0.2.12
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros
RInside.cpp
Go to the documentation of this file.
1 // -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*-
2 //
3 // RInside.cpp: R/C++ interface class library -- Easier R embedding into C++
4 //
5 // Copyright (C) 2009 Dirk Eddelbuettel
6 // Copyright (C) 2010 - 2015 Dirk Eddelbuettel and Romain Francois
7 //
8 // This file is part of RInside.
9 //
10 // RInside is free software: you can redistribute it and/or modify it
11 // under the terms of the GNU General Public License as published by
12 // the Free Software Foundation, either version 2 of the License, or
13 // (at your option) any later version.
14 //
15 // RInside is distributed in the hope that it will be useful, but
16 // WITHOUT ANY WARRANTY; without even the implied warranty of
17 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 // GNU General Public License for more details.
19 //
20 // You should have received a copy of the GNU General Public License
21 // along with RInside. If not, see <http://www.gnu.org/licenses/>.
22 
23 #include <RInside.h>
24 #include <Callbacks.h>
25 
27 
28 const char *programName = "RInside";
29 
30 #ifdef WIN32
31  // on Windows, we need to provide setenv which is in the file setenv.c here
32  #include "setenv/setenv.c"
33  extern int optind;
34 #endif
35 
36 RInside::~RInside() { // now empty as MemBuf is internal
37  R_dot_Last();
38  R_RunExitFinalizers();
39  R_CleanTempDir();
40  //Rf_KillAllDevices();
41  //#ifndef WIN32
42  //fpu_setup(FALSE);
43  //#endif
44  Rf_endEmbeddedR(0);
45  instance_m = 0 ;
46  delete global_env_m;
47 }
48 
49 RInside::RInside(): global_env_m(NULL)
50 #ifdef RINSIDE_CALLBACKS
51  , callbacks(0)
52 #endif
53 {
54  initialize(0, 0, false, false, false);
55 }
56 
57 #ifdef WIN32
58 static int myReadConsole(const char *prompt, char *buf, int len, int addtohistory) {
59  fputs(prompt, stdout);
60  fflush(stdout);
61  if (fgets(buf, len, stdin))
62  return 1;
63  else
64  return 0;
65 }
66 
67 static void myWriteConsole(const char *buf, int len) {
68  fwrite(buf, sizeof(char), len, stdout);
69  fflush(stdout);
70 }
71 
72 static void myCallBack() {
73  /* called during i/o, eval, graphics in ProcessEvents */
74 }
75 
76 static void myBusy(int which) {
77  /* set a busy cursor ... if which = 1, unset if which = 0 */
78 }
79 
80 void myAskOk(const char *info) {
81 
82 }
83 
84 int myAskYesNoCancel(const char *question) {
85  const int yes = 1;
86  return yes;
87 }
88 
89 #endif
90 
91 RInside::RInside(const int argc, const char* const argv[], const bool loadRcpp,
92  const bool verbose, const bool interactive)
93 #ifdef RINSIDE_CALLBACKS
94  : callbacks(0)
95 #endif
96 {
97  initialize(argc, argv, loadRcpp, verbose, interactive);
98 }
99 
100 // TODO: use a vector<string> would make all this a bit more readable
101 void RInside::initialize(const int argc, const char* const argv[], const bool loadRcpp,
102  const bool verbose, const bool interactive) {
103 
104  if (instance_m) {
105  throw std::runtime_error( "can only have one RInside instance" ) ;
106  } else {
107  instance_m = this ;
108  }
109 
110  verbose_m = verbose; // Default is false
111  interactive_m = interactive;
112 
113  // generated from Makevars{.win}
114  #include "RInsideEnvVars.h"
115 
116  #ifdef WIN32
117  // we need a special case for Windows where users may deploy an RInside binary from CRAN
118  // which will have R_HOME set at compile time to CRAN's value -- so let's try to correct
119  // this here: a) allow user's setting of R_HOME and b) use R's get_R_HOME() function
120  if (getenv("R_HOME") == NULL) { // if on Windows and not set
121  char *rhome = get_R_HOME(); // query it, including registry
122  if (rhome != NULL) { // if something was found
123  setenv("R_HOME", get_R_HOME(), 1); // store what we got as R_HOME
124  } // this will now be used in next blocks
125  }
126  #endif
127 
128  for (int i = 0; R_VARS[i] != NULL; i+= 2) {
129  if (getenv(R_VARS[i]) == NULL) { // if env variable is not yet set
130  if (setenv(R_VARS[i],R_VARS[i+1],1) != 0){
131  throw std::runtime_error(std::string("Could not set R environment variable ") +
132  std::string(R_VARS[i]) + std::string(" to ") +
133  std::string(R_VARS[i+1]));
134  }
135  }
136  }
137 
138  #ifndef WIN32
139  R_SignalHandlers = 0; // Don't let R set up its own signal handlers
140  #endif
141 
142  init_tempdir();
143 
144  const char *R_argv[] = {(char*)programName, "--gui=none", "--no-save",
145  "--no-readline", "--silent", "--vanilla", "--slave"};
146  int R_argc = sizeof(R_argv) / sizeof(R_argv[0]);
147  Rf_initEmbeddedR(R_argc, (char**)R_argv);
148 
149  #ifndef WIN32
150  R_CStackLimit = -1; // Don't do any stack checking, see R Exts, '8.1.5 Threading issues'
151  #endif
152 
153  R_ReplDLLinit(); // this is to populate the repl console buffers
154 
155  structRstart Rst;
156  R_DefParams(&Rst);
157  Rst.R_Interactive = (Rboolean) interactive_m; // sets interactive() to eval to false
158  #ifdef WIN32
159  Rst.rhome = getenv("R_HOME"); // which is set above as part of R_VARS
160  Rst.home = getRUser();
161  Rst.CharacterMode = LinkDLL;
162  Rst.ReadConsole = myReadConsole;
163  Rst.WriteConsole = myWriteConsole;
164  Rst.CallBack = myCallBack;
165  Rst.ShowMessage = myAskOk;
166  Rst.YesNoCancel = myAskYesNoCancel;
167  Rst.Busy = myBusy;
168  #endif
169  R_SetParams(&Rst);
170 
171  if (true || loadRcpp) { // we always need Rcpp, so load it anyway
172  // Rf_install is used best by first assigning like this so that symbols get into the symbol table
173  // where they cannot be garbage collected; doing it on the fly does expose a minuscule risk of garbage
174  // collection -- with thanks to Doug Bates for the explanation and Luke Tierney for the heads-up
175  SEXP suppressMessagesSymbol = Rf_install("suppressMessages");
176  SEXP requireSymbol = Rf_install("require");
177  Rf_eval(Rf_lang2(suppressMessagesSymbol, Rf_lang2(requireSymbol, Rf_mkString("Rcpp"))), R_GlobalEnv);
178  }
179 
180  global_env_m = new Rcpp::Environment(); // member variable for access to R's global environment
181 
182  autoloads(); // loads all default packages, using code autogenerate from Makevars{,.win}
183 
184  if ((argc - optind) > 1){ // for argv vector in Global Env */
185  Rcpp::CharacterVector s_argv( argv+(1+optind), argv+argc );
186  assign(s_argv, "argv");
187  } else {
188  assign(R_NilValue, "argv") ;
189  }
190 
191  init_rand(); // for tempfile() to work correctly */
192 }
193 
195  const char *tmp;
196  // FIXME: if per-session temp directory is used (as R does) then return
197  tmp = getenv("TMPDIR");
198  if (tmp == NULL) {
199  tmp = getenv("TMP");
200  if (tmp == NULL) {
201  tmp = getenv("TEMP");
202  if (tmp == NULL)
203  tmp = "/tmp";
204  }
205  }
206  R_TempDir = (char*) tmp;
207  if (setenv("R_SESSION_TMPDIR",tmp,1) != 0){
208  throw std::runtime_error(std::string("Could not set / replace R_SESSION_TMPDIR to ") + std::string(tmp));
209  }
210 }
211 
212 void RInside::init_rand(void) { // code borrows from R's TimeToSeed() in datetime.c
213  unsigned int pid = getpid();
214  struct timeval tv; // this is ifdef'ed by R, we just assume we have it
215  gettimeofday (&tv, NULL);
216  unsigned int seed = ((uint64_t) tv.tv_usec << 16) ^ tv.tv_sec;
217  seed ^= (pid << 16); // R 2.14.0 started to also use pid to support parallel
218  srand(seed);
219 }
220 
222 
223  #include "RInsideAutoloads.h"
224 
225  // Autoload default packages and names from autoloads.h
226  //
227  // This function behaves in almost every way like
228  // R's autoload:
229  // function (name, package, reset = FALSE, ...)
230  // {
231  // if (!reset && exists(name, envir = .GlobalEnv, inherits = FALSE))
232  // stop("an object with that name already exists")
233  // m <- match.call()
234  // m[[1]] <- as.name("list")
235  // newcall <- eval(m, parent.frame())
236  // newcall <- as.call(c(as.name("autoloader"), newcall))
237  // newcall$reset <- NULL
238  // if (is.na(match(package, .Autoloaded)))
239  // assign(".Autoloaded", c(package, .Autoloaded), env = .AutoloadEnv)
240  // do.call("delayedAssign", list(name, newcall, .GlobalEnv,
241  // .AutoloadEnv))
242  // invisible()
243  // }
244  //
245  // What's missing is the updating of the string vector .Autoloaded with
246  // the list of packages, which by my code analysis is useless and only
247  // for informational purposes.
248  //
249  //
250 
251  // we build the call :
252  //
253  // delayedAssign( NAME,
254  // autoloader( name = NAME, package = PACKAGE),
255  // .GlobalEnv,
256  // .AutoloadEnv )
257  //
258  // where :
259  // - PACKAGE is updated in a loop
260  // - NAME is updated in a loop
261  //
262  //
263 
264  int i,j, idx=0, nobj ;
265  Rcpp::Language delayed_assign_call(Rcpp::Function("delayedAssign"),
266  R_NilValue, // arg1: assigned in loop
267  R_NilValue, // arg2: assigned in loop
268  *global_env_m,
269  global_env_m->find(".AutoloadEnv")
270  );
271  Rcpp::Language::Proxy delayed_assign_name = delayed_assign_call[1];
272 
273  Rcpp::Language autoloader_call(Rcpp::Function("autoloader"),
274  Rcpp::Named( "name", R_NilValue) , // arg1 : assigned in loop
275  Rcpp::Named( "package", R_NilValue) // arg2 : assigned in loop
276  );
277  Rcpp::Language::Proxy autoloader_name = autoloader_call[1];
278  Rcpp::Language::Proxy autoloader_pack = autoloader_call[2];
279  delayed_assign_call[2] = autoloader_call;
280 
281  try {
282  for( i=0; i<packc; i++){
283 
284  // set the 'package' argument of the autoloader call */
285  autoloader_pack = pack[i] ;
286 
287  nobj = packobjc[i] ;
288  for (j = 0; j < nobj ; j++){
289 
290  // set the 'name' argument of the autoloader call */
291  autoloader_name = packobj[idx+j] ;
292 
293  // Set the 'name' argument of the delayedAssign call */
294  delayed_assign_name = packobj[idx+j] ;
295 
296  // evaluate the call */
297  delayed_assign_call.eval() ;
298 
299  }
300  idx += packobjc[i] ;
301  }
302  } catch( std::exception& ex){
303  throw std::runtime_error(std::string("Error calling delayedAssign: ") + std::string(ex.what()));
304  }
305 }
306 
307 // this is a non-throwing version returning an error code
308 int RInside::parseEval(const std::string & line, SEXP & ans) {
309  ParseStatus status;
310  SEXP cmdSexp, cmdexpr = R_NilValue;
311  int i, errorOccurred;
312 
313  mb_m.add((char*)line.c_str());
314 
315  PROTECT(cmdSexp = Rf_allocVector(STRSXP, 1));
316  SET_STRING_ELT(cmdSexp, 0, Rf_mkChar(mb_m.getBufPtr()));
317 
318  cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
319 
320  switch (status){
321  case PARSE_OK:
322  // Loop is needed here as EXPSEXP might be of length > 1
323  for(i = 0; i < Rf_length(cmdexpr); i++){
324  ans = R_tryEval(VECTOR_ELT(cmdexpr, i), *global_env_m, &errorOccurred);
325  if (errorOccurred) {
326  if (verbose_m) Rf_warning("%s: Error in evaluating R code (%d)\n", programName, status);
327  UNPROTECT(2);
328  mb_m.rewind();
329  return 1;
330  }
331  if (verbose_m) {
332  Rf_PrintValue(ans);
333  }
334  }
335  mb_m.rewind();
336  break;
337  case PARSE_INCOMPLETE:
338  // need to read another line
339  break;
340  case PARSE_NULL:
341  if (verbose_m) Rf_warning("%s: ParseStatus is null (%d)\n", programName, status);
342  UNPROTECT(2);
343  mb_m.rewind();
344  return 1;
345  break;
346  case PARSE_ERROR:
347  if (verbose_m) Rf_warning("Parse Error: \"%s\"\n", line.c_str());
348  UNPROTECT(2);
349  mb_m.rewind();
350  return 1;
351  break;
352  case PARSE_EOF:
353  if (verbose_m) Rf_warning("%s: ParseStatus is eof (%d)\n", programName, status);
354  break;
355  default:
356  if (verbose_m) Rf_warning("%s: ParseStatus is not documented %d\n", programName, status);
357  UNPROTECT(2);
358  mb_m.rewind();
359  return 1;
360  break;
361  }
362  UNPROTECT(2);
363  return 0;
364 }
365 
366 void RInside::parseEvalQ(const std::string & line) {
367  SEXP ans;
368  int rc = parseEval(line, ans);
369  if (rc != 0) {
370  throw std::runtime_error(std::string("Error evaluating: ") + line);
371  }
372 }
373 
374 void RInside::parseEvalQNT(const std::string & line) {
375  SEXP ans;
376  parseEval(line, ans);
377 }
378 
379 RInside::Proxy RInside::parseEval(const std::string & line) {
380  SEXP ans;
381  int rc = parseEval(line, ans);
382  if (rc != 0) {
383  throw std::runtime_error(std::string("Error evaluating: ") + line);
384  }
385  return Proxy( ans );
386 }
387 
388 RInside::Proxy RInside::parseEvalNT(const std::string & line) {
389  SEXP ans;
390  parseEval(line, ans);
391  return Proxy( ans );
392 }
393 
394 Rcpp::Environment::Binding RInside::operator[]( const std::string& name ){
395  return (*global_env_m)[name];
396 }
397 
399  return *instance_m;
400 }
401 
403  return instance_m;
404 }
405 
406 /* callbacks */
407 
408 #ifdef RINSIDE_CALLBACKS
409 
410 void Callbacks::Busy_( int which ){
411  R_is_busy = static_cast<bool>( which ) ;
412  Busy( R_is_busy ) ;
413 }
414 
415 int Callbacks::ReadConsole_( const char* prompt, unsigned char* buf, int len, int addtohistory ){
416  try {
417  std::string res( ReadConsole( prompt, static_cast<bool>(addtohistory) ) ) ;
418 
419  /* At some point we need to figure out what to do if the result is
420  * longer than "len"... For now, just truncate. */
421 
422  int l = res.size() ;
423  int last = (l>len-1)?len-1:l ;
424  strncpy( (char*)buf, res.c_str(), last ) ;
425  buf[last] = 0 ;
426  return 1 ;
427  } catch( const std::exception& ex){
428  return -1 ;
429  }
430 }
431 
432 
433 void Callbacks::WriteConsole_( const char* buf, int len, int oType ){
434  if( len ){
435  buffer.assign( buf, len ) ;
436  WriteConsole( buffer, oType) ;
437  }
438 }
439 
440 void RInside_ShowMessage( const char* message ){
441  RInside::instance().callbacks->ShowMessage( message ) ;
442 }
443 
444 void RInside_WriteConsoleEx( const char* message, int len, int oType ){
445  RInside::instance().callbacks->WriteConsole_( message, len, oType ) ;
446 }
447 
448 int RInside_ReadConsole(const char *prompt, unsigned char *buf, int len, int addtohistory){
449  return RInside::instance().callbacks->ReadConsole_( prompt, buf, len, addtohistory ) ;
450 }
451 
452 void RInside_ResetConsole(){
453  RInside::instance().callbacks->ResetConsole() ;
454 }
455 
456 void RInside_FlushConsole(){
457  RInside::instance().callbacks->FlushConsole() ;
458 }
459 
460 void RInside_ClearerrConsole(){
461  RInside::instance().callbacks->CleanerrConsole() ;
462 }
463 
464 void RInside_Busy( int which ){
465  RInside::instance().callbacks->Busy_(which) ;
466 }
467 
468 void RInside::set_callbacks(Callbacks* callbacks_){
469  callbacks = callbacks_ ;
470 
471 #ifdef WIN32
472  // do something to tell user that he doesn't get this
473 #else
474 
475  /* short circuit the callback function pointers */
476  if( callbacks->has_ShowMessage() ){
477  ptr_R_ShowMessage = RInside_ShowMessage ;
478  }
479  if( callbacks->has_ReadConsole() ){
480  ptr_R_ReadConsole = RInside_ReadConsole;
481  }
482  if( callbacks->has_WriteConsole() ){
483  ptr_R_WriteConsoleEx = RInside_WriteConsoleEx ;
484  ptr_R_WriteConsole = NULL;
485  }
486  if( callbacks->has_ResetConsole() ){
487  ptr_R_ResetConsole = RInside_ResetConsole;
488  }
489  if( callbacks->has_FlushConsole() ){
490  ptr_R_FlushConsole = RInside_FlushConsole;
491  }
492  if( callbacks->has_CleanerrConsole() ){
493  ptr_R_ClearerrConsole = RInside_ClearerrConsole;
494  }
495  if( callbacks->has_Busy() ){
496  ptr_R_Busy = RInside_Busy;
497  }
498 
499  R_Outputfile = NULL;
500  R_Consolefile = NULL;
501 #endif
502 }
503 
504 void RInside::repl(){
505  R_ReplDLLinit();
506  while( R_ReplDLLdo1() > 0 ) {}
507 }
508 
509 #endif
RInside()
Definition: RInside.cpp:49
void autoloads(void)
Definition: RInside.cpp:221
bool interactive_m
Definition: RInside.h:35
~RInside()
Definition: RInside.cpp:36
void rewind()
Definition: MemBuf.cpp:42
Rcpp::Environment::Binding operator[](const std::string &name)
Definition: RInside.cpp:394
MemBuf mb_m
Definition: RInside.h:31
bool verbose_m
Definition: RInside.h:34
void parseEvalQ(const std::string &line)
Definition: RInside.cpp:366
static RInside * instancePtr()
Definition: RInside.cpp:402
void add(const std::string &)
Definition: MemBuf.cpp:46
static RInside * instance_m
Definition: RInside.h:44
int setenv(const char *env_var, const char *env_val, int dummy)
Definition: setenv.c:28
int parseEval(const std::string &line, SEXP &ans)
Definition: RInside.cpp:308
Proxy parseEvalNT(const std::string &line)
Definition: RInside.cpp:388
void parseEvalQNT(const std::string &line)
Definition: RInside.cpp:374
const char * getBufPtr()
Definition: MemBuf.h:33
void initialize(const int argc, const char *const argv[], const bool loadRcpp, const bool verbose, const bool interactive)
Definition: RInside.cpp:101
Rcpp::Environment * global_env_m
Definition: RInside.h:32
const char * programName
Definition: RInside.cpp:28
void assign(const T &object, const std::string &nam)
Definition: RInside.h:78
bool verbose
static RInside & instance()
Definition: RInside.cpp:398
void init_rand(void)
Definition: RInside.cpp:212
void init_tempdir(void)
Definition: RInside.cpp:194
uintptr_t R_CStackLimit