Rcpp Version 1.0.9
Environment.h
Go to the documentation of this file.
1 // -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*-
2 //
3 // Environment.h: Rcpp R/C++ interface class library -- access R environments
4 //
5 // Copyright (C) 2009 - 2013 Dirk Eddelbuettel and Romain Francois
6 // Copyright (C) 2014 - 2020 Dirk Eddelbuettel, Romain Francois and Kevin Ushey
7 //
8 // This file is part of Rcpp.
9 //
10 // Rcpp 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 // Rcpp 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 Rcpp. If not, see <http://www.gnu.org/licenses/>.
22 
23 #ifndef Rcpp_Environment_h
24 #define Rcpp_Environment_h
25 
26 namespace Rcpp{
27 
30  {
31  private:
32  inline SEXP as_environment(SEXP x){
33  if( Rf_isEnvironment(x) ) return x ;
34  SEXP asEnvironmentSym = Rf_install("as.environment");
35  try {
36  Shield<SEXP> call(Rf_lang2(asEnvironmentSym, x));
37  return Rcpp_fast_eval(call, R_GlobalEnv);
38  } catch( const eval_error& ex) {
39  const char* fmt = "Cannot convert object to an environment: "
40  "[type=%s; target=ENVSXP].";
41  throw not_compatible(fmt, Rf_type2char(TYPEOF(x)));
42  }
43  }
44 
45  public:
47 
49  Storage::set__(R_GlobalEnv) ;
50  } ;
51 
57  Environment_Impl(SEXP x) {
58  Shield<SEXP> env(as_environment(x));
59  Storage::set__(env) ;
60  }
61 
67  Environment_Impl( const std::string& name ) ;
68 
75  Environment_Impl( int pos ) ;
76 
85  SEXP ls(bool all) const {
86  SEXP env = Storage::get__() ;
87  if( is_user_database() ){
88  R_ObjectTable *tb = (R_ObjectTable*) R_ExternalPtrAddr(HASHTAB(env));
89  return tb->objects(tb) ;
90  } else {
91  return R_lsInternal( env, all ? TRUE : FALSE ) ;
92  }
93  return R_NilValue ;
94  }
95 
103  SEXP get(const std::string& name) const {
104  SEXP env = Storage::get__() ;
105  SEXP nameSym = Rf_install(name.c_str());
106  SEXP res = Rf_findVarInFrame( env, nameSym ) ;
107 
108  if( res == R_UnboundValue ) return R_NilValue ;
109 
110  /* We need to evaluate if it is a promise */
111  if( TYPEOF(res) == PROMSXP){
112  res = internal::Rcpp_eval_impl( res, env ) ;
113  }
114  return res ;
115  }
116 
124  SEXP get(Symbol name) const {
125  SEXP env = Storage::get__() ;
126  SEXP res = Rf_findVarInFrame( env, name ) ;
127 
128  if( res == R_UnboundValue ) return R_NilValue ;
129 
130  /* We need to evaluate if it is a promise */
131  if( TYPEOF(res) == PROMSXP){
132  res = internal::Rcpp_eval_impl( res, env ) ;
133  }
134  return res ;
135  }
136 
137 
145  SEXP find( const std::string& name) const{
146  SEXP env = Storage::get__() ;
147  SEXP nameSym = Rf_install(name.c_str());
148  SEXP res = Rf_findVar( nameSym, env ) ;
149 
150  if( res == R_UnboundValue ) throw binding_not_found(name) ;
151 
152  /* We need to evaluate if it is a promise */
153  if( TYPEOF(res) == PROMSXP){
154  res = internal::Rcpp_eval_impl( res, env ) ;
155  }
156  return res ;
157  }
158 
165  SEXP find(Symbol name) const{
166  SEXP env = Storage::get__() ;
167  SEXP res = Rf_findVar( name, env ) ;
168 
169  if( res == R_UnboundValue ) {
170  // Pass on the const char* to the RCPP_EXCEPTION_CLASS's
171  // const std::string& requirement
172  throw binding_not_found(name.c_str()) ;
173  }
174 
175  /* We need to evaluate if it is a promise */
176  if( TYPEOF(res) == PROMSXP){
177  res = internal::Rcpp_eval_impl( res, env ) ;
178  }
179  return res ;
180  }
181 
190  bool exists( const std::string& name ) const {
191  SEXP nameSym = Rf_install(name.c_str());
192  SEXP res = Rf_findVarInFrame( Storage::get__() , nameSym ) ;
193  return res != R_UnboundValue ;
194  }
195 
207  bool assign( const std::string& name, SEXP x ) const{
208  if( exists( name) && bindingIsLocked(name) ) throw binding_is_locked(name) ;
209  SEXP nameSym = Rf_install(name.c_str());
210  Rf_defineVar( nameSym, x, Storage::get__() );
211  return true ;
212  }
213 
214  bool assign(const std::string& name, const Shield<SEXP>& x) const {
215  return assign(name, (SEXP) x);
216  }
217 
226  template <typename WRAPPABLE>
227  bool assign( const std::string& name, const WRAPPABLE& x) const ;
228 
233  bool isLocked() const {
234  return R_EnvironmentIsLocked(Storage::get__());
235  }
236 
240  bool remove( const std::string& name ){
241  if( exists(name) ){
242  if( bindingIsLocked(name) ){
243  throw binding_is_locked(name) ;
244  } else{
245  /* unless we want to copy all of do_remove,
246  we have to go back to R to do this operation */
247  SEXP internalSym = Rf_install( ".Internal" );
248  SEXP removeSym = Rf_install( "remove" );
249  Shield<SEXP> str(Rf_mkString(name.c_str()));
250  Shield<SEXP> call(Rf_lang2(internalSym, Rf_lang4(removeSym, str, Storage::get__(), Rf_ScalarLogical(FALSE))));
251  Rcpp_fast_eval( call, R_GlobalEnv ) ;
252  }
253  } else{
254  throw no_such_binding(name) ;
255  }
256  return true;
257  }
258 
264  void lock(bool bindings = false) {
265  R_LockEnvironment( Storage::get__(), bindings ? TRUE: FALSE ) ;
266  }
267 
274  void lockBinding(const std::string& name){
275  if( !exists( name) ) throw no_such_binding(name) ;
276  SEXP nameSym = Rf_install(name.c_str());
277  R_LockBinding( nameSym, Storage::get__() );
278  }
279 
286  void unlockBinding(const std::string& name){
287  if( !exists( name) ) throw no_such_binding(name) ;
288  SEXP nameSym = Rf_install(name.c_str());
289  R_unLockBinding( nameSym, Storage::get__() );
290  }
291 
300  bool bindingIsLocked(const std::string& name) const{
301  if( !exists( name) ) throw no_such_binding(name) ;
302  SEXP nameSym = Rf_install(name.c_str());
303  return R_BindingIsLocked(nameSym, Storage::get__() ) ;
304  }
305 
315  bool bindingIsActive(const std::string& name) const {
316  if( !exists( name) ) throw no_such_binding(name) ;
317  SEXP nameSym = Rf_install(name.c_str());
318  return R_BindingIsActive(nameSym, Storage::get__()) ;
319  }
320 
324  bool is_user_database() const {
325  SEXP env = Storage::get__() ;
326  return OBJECT(env) && Rf_inherits(env, "UserDefinedDatabase") ;
327  }
328 
333  return R_GlobalEnv ;
334  }
335 
340  return R_EmptyEnv ;
341  }
342 
347  return R_BaseEnv ;
348  }
349 
354  return R_BaseNamespace ;
355  }
356 
362  }
363 
371  static Environment_Impl namespace_env(const std::string& package){
372  Armor<SEXP> env ;
373  try{
374  SEXP getNamespaceSym = Rf_install("getNamespace");
375  Shield<SEXP> package_str( Rf_mkString(package.c_str()) );
376  Shield<SEXP> call( Rf_lang2(getNamespaceSym, package_str) );
377  env = Rcpp_fast_eval(call, R_GlobalEnv);
378  } catch( ... ){
379  throw no_such_namespace( package ) ;
380  }
381  return Environment_Impl( env ) ;
382  }
383 
388  return Environment_Impl( ENCLOS(Storage::get__()) ) ;
389  }
390 
394  Environment_Impl new_child(bool hashed) const {
395  SEXP newEnvSym = Rf_install("new.env");
396  Shield<SEXP> call(Rf_lang3(newEnvSym, Rf_ScalarLogical(hashed), Storage::get__()));
397  return Environment_Impl(Rcpp_fast_eval(call, R_GlobalEnv));
398  }
399 
400  void update(SEXP){}
401  };
402 
403 typedef Environment_Impl<PreserveStorage> Environment ;
404 
405 } // namespace Rcpp
406 
407 #endif
#define RCPP_GENERATE_CTOR_ASSIGN(__CLASS__)
Definition: interface.h:21
attribute_hidden SEXP get_Rcpp_namespace()
Definition: routines.h:121
SEXP Rcpp_eval_impl(SEXP expr, SEXP env)
Definition: Rcpp_eval.h:48
Rcpp API.
Definition: algo.h:28
void lockBinding(const std::string &name)
Definition: Environment.h:274
bool remove(const std::string &name)
Definition: Environment.h:240
static Environment_Impl global_env()
Definition: Environment.h:332
static Environment_Impl Rcpp_namespace()
Definition: Environment.h:360
bool is_user_database() const
Definition: Environment.h:324
void lock(bool bindings=false)
Definition: Environment.h:264
void update(SEXP)
Definition: Environment.h:400
bool assign(const std::string &name, SEXP x) const
Definition: Environment.h:207
void unlockBinding(const std::string &name)
Definition: Environment.h:286
sugar::All< NA, T > all(const Rcpp::VectorBase< LGLSXP, NA, T > &t)
Definition: all.h:84
RCPP_API_CLASS(DottedPair_Impl)
SEXP Rcpp_fast_eval(SEXP expr, SEXP env)
Definition: Rcpp_eval.h:68
SEXP get(const std::string &name) const
Definition: Environment.h:103
SEXP find(const std::string &name) const
Definition: Environment.h:145
static Environment_Impl base_env()
Definition: Environment.h:346
static Environment_Impl namespace_env(const std::string &package)
Definition: Environment.h:371
static Environment_Impl empty_env()
Definition: Environment.h:339
bool bindingIsLocked(const std::string &name) const
Definition: Environment.h:300
Environment_Impl parent() const
Definition: Environment.h:387
Environment_Impl(SEXP x)
Definition: Environment.h:57
static Environment_Impl base_namespace()
Definition: Environment.h:353
Environment_Impl< PreserveStorage > Environment
Definition: Environment.h:401
Environment_Impl new_child(bool hashed) const
Definition: Environment.h:394
Symbol_Impl< NoProtectStorage > Symbol
Definition: Symbol.h:82
bool exists(const std::string &name) const
Definition: Environment.h:190
SEXP ls(bool all) const
Definition: Environment.h:85
bool isLocked() const
Definition: Environment.h:233
bool bindingIsActive(const std::string &name) const
Definition: Environment.h:315