[Rcpp-devel] [Rcpp-commits] r246 - in pkg: inst/doc inst/unitTests man src src/Rcpp
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Dec 31 11:59:31 CET 2009
Author: romain
Date: 2009-12-31 11:59:31 +0100 (Thu, 31 Dec 2009)
New Revision: 246
Modified:
pkg/inst/doc/Rcpp-unitTests.R
pkg/inst/unitTests/runit.environments.R
pkg/man/RcppUnitTests.Rd
pkg/src/Environment.cpp
pkg/src/Rcpp/Environment.h
Log:
some more methods in Rcpp::Environment
Modified: pkg/inst/doc/Rcpp-unitTests.R
===================================================================
--- pkg/inst/doc/Rcpp-unitTests.R 2009-12-30 22:33:13 UTC (rev 245)
+++ pkg/inst/doc/Rcpp-unitTests.R 2009-12-31 10:59:31 UTC (rev 246)
@@ -24,5 +24,8 @@
tests <- runTestSuite(testSuite)
printHTMLProtocol(tests, fileName="Rcpp-unitTests.html" )
printTextProtocol(tests, fileName="Rcpp-unitTests.txt" )
+if( file.exists( "/tmp" ) ){
+ file.copy( "Rcpp-unitTests.txt", "/tmp", overwrite = TRUE )
+ file.copy( "Rcpp-unitTests.html", "/tmp", overwrite = TRUE )
+}
-
Modified: pkg/inst/unitTests/runit.environments.R
===================================================================
--- pkg/inst/unitTests/runit.environments.R 2009-12-30 22:33:13 UTC (rev 245)
+++ pkg/inst/unitTests/runit.environments.R 2009-12-31 10:59:31 UTC (rev 246)
@@ -94,8 +94,11 @@
checkEquals( e$a, 1:10, msg = "Environment::assign, checking value 1" )
checkEquals( e$b, Rcpp:::CxxFlags, msg = "Environment::assign, checking value 2" )
- lockBinding( "a", e )
- checkTrue( !funx(e, "a", letters ), msg = "Environment::assign and locked bindings" )
+ lockBinding( "a", e )
+ checkTrue(
+ tryCatch( { funx(e, "a", letters ) ; FALSE}, "Rcpp::Environment::binding_is_locked" = function(e) TRUE ),
+ msg = "cannot assign to locked binding (catch exception)" )
+
}
test.environment.isLocked <- function(){
@@ -121,10 +124,12 @@
e <- new.env()
e$a <- 1:10
makeActiveBinding( "b", function(x) 10, e )
-
+
checkTrue( !funx(e, "a" ), msg = "Environment::bindingIsActive( non active ) -> false" )
checkTrue( funx(e, "b" ), msg = "Environment::bindingIsActive( active ) -> true" )
- checkTrue( !funx(e, "xx" ), msg = "Environment::bindingIsActive( no binding ) -> false" )
+ checkTrue(
+ tryCatch( { funx(e, "xx" ) ; FALSE}, "Rcpp::Environment::no_such_binding" = function(e) TRUE ),
+ msg = "Environment::bindingIsActive(no binding) -> exception)" )
}
@@ -143,7 +148,9 @@
checkTrue( !funx(e, "a" ), msg = "Environment::bindingIsActive( non active ) -> false" )
checkTrue( funx(e, "b" ), msg = "Environment::bindingIsActive( active ) -> true" )
- checkTrue( !funx(e, "xx" ), msg = "Environment::bindingIsActive( no binding ) -> false" )
+ checkTrue(
+ tryCatch( { funx(e, "xx" ) ; FALSE}, "Rcpp::Environment::no_such_binding" = function(e) TRUE ),
+ msg = "Environment::bindingIsLocked(no binding) -> exception)" )
}
@@ -156,3 +163,80 @@
checkException( funx( NULL ), msg = "not an environment" )
}
+
+test.environment.lockBinding <- function(){
+ funx <- cfunction(signature(x="environment", name = "character" ), '
+ Rcpp::Environment env(x) ;
+ std::string st = Rcpp::RObject(name).asStdString() ;
+ env.lockBinding( st ) ;
+ return R_NilValue ;
+ ', Rcpp=TRUE, verbose=FALSE)
+
+ e <- new.env()
+ e$a <- 1:10
+ e$b <- letters
+ funx(e, "b")
+ checkTrue( bindingIsLocked("b", e ), msg = "Environment::lockBinding()" )
+ checkTrue(
+ tryCatch( { funx(e, "xx" ) ; FALSE}, "Rcpp::Environment::no_such_binding" = function(e) TRUE ),
+ msg = "Environment::lockBinding(no binding) -> exception)" )
+
+}
+
+test.environment.unlockBinding <- function(){
+ funx <- cfunction(signature(x="environment", name = "character" ), '
+ Rcpp::Environment env(x) ;
+ std::string st = Rcpp::RObject(name).asStdString() ;
+ env.unlockBinding( st ) ;
+ return R_NilValue ;
+ ', Rcpp=TRUE, verbose=FALSE)
+
+ e <- new.env()
+ e$a <- 1:10
+ e$b <- letters
+ lockBinding( "b", e )
+ funx(e, "b")
+ checkTrue( !bindingIsLocked("b", e ), msg = "Environment::lockBinding()" )
+ checkTrue(
+ tryCatch( { funx(e, "xx" ) ; FALSE}, "Rcpp::Environment::no_such_binding" = function(e) TRUE ),
+ msg = "Environment::unlockBinding(no binding) -> exception)" )
+
+}
+
+test.environment.global.env <- function(){
+ funx <- cfunction(signature(),
+ 'return Rcpp::Environment::global_env(); ', Rcpp=TRUE, verbose=FALSE)
+ checkEquals( funx(), globalenv(), msg = "REnvironment::global_env" )
+}
+
+test.environment.empty.env <- function(){
+ funx <- cfunction(signature(),
+ 'return Rcpp::Environment::empty_env(); ', Rcpp=TRUE, verbose=FALSE)
+ checkEquals( funx(), emptyenv(), msg = "REnvironment::empty_env" )
+}
+
+test.environment.base.env <- function(){
+ funx <- cfunction(signature(),
+ 'return Rcpp::Environment::base_env(); ', Rcpp=TRUE, verbose=FALSE)
+ checkEquals( funx(), baseenv(), msg = "REnvironment::base_env" )
+}
+
+test.environment.empty.env <- function(){
+ funx <- cfunction(signature(),
+ 'return Rcpp::Environment::base_namespace(); ', Rcpp=TRUE, verbose=FALSE)
+ checkEquals( funx(), .BaseNamespaceEnv, msg = "REnvironment::base_namespace" )
+}
+
+test.environment.namespace.env <- function(){
+ funx <- cfunction(signature(env = "character" ), '
+ std::string st = Rcpp::RObject(env).asStdString() ;
+ return Rcpp::Environment::namespace_env(st); ', Rcpp=TRUE, verbose=FALSE)
+ checkEquals( funx("Rcpp"), asNamespace("Rcpp"), msg = "REnvironment::base_namespace" )
+ checkTrue(
+ tryCatch( { funx("----" ) ; FALSE}, "Rcpp::Environment::no_such_namespace" = function(e) TRUE ),
+ msg = "Environment::namespace_env(no namespace) -> exception)" )
+
+}
+
+
+
Modified: pkg/man/RcppUnitTests.Rd
===================================================================
--- pkg/man/RcppUnitTests.Rd 2009-12-30 22:33:13 UTC (rev 245)
+++ pkg/man/RcppUnitTests.Rd 2009-12-31 10:59:31 UTC (rev 246)
@@ -16,7 +16,7 @@
}
\details{
-\Sexpr[echo=FALSE,results=text]{ Rcpp:::dumpUnitTestReport() }
+\Sexpr[echo=FALSE,results=text]{ if(exists("dumpUnitTestReport", asNamespace("Rcpp"))) Rcpp:::dumpUnitTestReport() else ""}
}
\examples{
Modified: pkg/src/Environment.cpp
===================================================================
--- pkg/src/Environment.cpp 2009-12-30 22:33:13 UTC (rev 245)
+++ pkg/src/Environment.cpp 2009-12-31 10:59:31 UTC (rev 246)
@@ -32,13 +32,20 @@
struct safeAssign_s *s = (struct safeAssign_s*) data;
Rf_defineVar(s->sym, s->val, s->rho);
}
-
-
+
+struct safeFindNamespace_s {
+ SEXP sym, val ;
+};
+static void safeFindNamespace(void *data) {
+ struct safeFindNamespace_s *s = (struct safeFindNamespace_s*) data;
+ s->val = R_FindNamespace(s->sym);
+}
+
+
Environment::Environment( SEXP m_sexp = R_GlobalEnv) : RObject::RObject(m_sexp){
if( TYPEOF(m_sexp) != ENVSXP ){
throw std::runtime_error( "not an environment" ) ;
}
- is_user_database = IS_USER_DATABASE(m_sexp) ;
}
Environment::~Environment(){
@@ -46,7 +53,7 @@
}
SEXP Environment::ls( bool all = true) const {
- if( is_user_database ){
+ if( is_user_database() ){
R_ObjectTable *tb = (R_ObjectTable*)
R_ExternalPtrAddr(HASHTAB(m_sexp));
return tb->objects(tb) ;
@@ -74,9 +81,14 @@
return res != R_UnboundValue ;
}
- bool Environment::assign( const std::string& name, SEXP x = R_NilValue) const{
+ bool Environment::assign( const std::string& name, SEXP x = R_NilValue) const throw(binding_is_locked){
+ if( exists( name) && bindingIsLocked(name) ) throw binding_is_locked(name) ;
+
/* borrowed from JRI, we cannot just use defineVar since it might
crash on locked bindings */
+
+ /* TODO: we need to modify R_ToplevelExec so that it does not print
+ the error message as it currently does*/
struct safeAssign_s s;
s.sym = Rf_install( name.c_str() ) ;
if( !s.sym || s.sym == R_NilValue ) return false ;
@@ -87,18 +99,86 @@
}
bool Environment::isLocked() const{
- return static_cast<bool>(R_EnvironmentIsLocked(m_sexp));
+ return R_EnvironmentIsLocked(m_sexp);
}
- bool Environment::bindingIsActive(const std::string& name) const{
- if( !exists( name) ) return false ; /* should this be an exception instead ? */
- return static_cast<bool>(R_BindingIsActive(Rf_install(name.c_str()), m_sexp)) ;
+ bool Environment::bindingIsActive(const std::string& name) const throw(no_such_binding) {
+ if( !exists( name) ) throw no_such_binding(name) ;
+ return R_BindingIsActive(Rf_install(name.c_str()), m_sexp) ;
}
- bool Environment::bindingIsLocked(const std::string& name) const{
- if( !exists( name) ) return false ; /* should this be an exception instead ? */
- return static_cast<bool>(R_BindingIsLocked(Rf_install(name.c_str()), m_sexp)) ;
+ bool Environment::bindingIsLocked(const std::string& name) const throw(no_such_binding) {
+ if( !exists( name) ) throw no_such_binding(name) ;
+ return R_BindingIsLocked(Rf_install(name.c_str()), m_sexp) ;
}
+ void Environment::lock( bool bindings = false ) {
+ R_LockEnvironment( m_sexp, bindings ? TRUE: FALSE ) ;
+ }
+
+ void Environment::lockBinding(const std::string& name) throw(no_such_binding) {
+ if( !exists( name) ) throw no_such_binding(name) ;
+ R_LockBinding( Rf_install( name.c_str() ), m_sexp );
+ }
+
+ void Environment::unlockBinding(const std::string& name) throw(no_such_binding) {
+ if( !exists( name) ) throw no_such_binding(name) ;
+ R_unLockBinding( Rf_install( name.c_str() ), m_sexp );
+ }
+
+ bool Environment::is_user_database() const {
+ return OBJECT(m_sexp) && Rf_inherits(m_sexp, "UserDefinedDatabase") ;
+ }
+
+ /* static */
+
+ Environment Environment::global_env() throw() {
+ return Environment(R_GlobalEnv) ;
+ }
+
+ Environment Environment::empty_env() throw() {
+ return Environment(R_GlobalEnv) ;
+ }
+
+ Environment Environment::base_env() throw(){
+ return Environment(R_BaseEnv) ;
+ }
+
+ Environment Environment::base_namespace() throw() {
+ return Environment(R_BaseNamespace) ;
+ }
+
+ Environment Environment::namespace_env(const std::string& package) throw(no_such_namespace) {
+ struct safeFindNamespace_s s;
+ s.sym = Rf_mkString( package.c_str() ) ;
+ if( !s.sym || s.sym == R_NilValue || !R_ToplevelExec(safeFindNamespace, (void*) &s) ){
+ throw no_such_namespace(package) ;
+ }
+ return s.val ;
+ }
+
+ /* exceptions */
+
+ Environment::no_such_binding::no_such_binding(const std::string& binding) :
+ message( "no such binding : '" + binding + "'" ) {}
+ const char* Environment::no_such_binding::what() const throw(){
+ return message.c_str() ;
+ }
+ Environment::no_such_binding::~no_such_binding() throw() {}
+
+ Environment::binding_is_locked::binding_is_locked(const std::string& binding) :
+ message("binding is locked : '" + binding + "'" ) {}
+ const char* Environment::binding_is_locked::what() const throw(){
+ return message.c_str() ;
+ }
+ Environment::binding_is_locked::~binding_is_locked() throw() {}
+
+ Environment::no_such_namespace::no_such_namespace(const std::string& package) :
+ message("no such namespace : '" + package + "'" ) {}
+ const char* Environment::no_such_namespace::what() const throw(){
+ return message.c_str() ;
+ }
+ Environment::no_such_namespace::~no_such_namespace() throw() {}
+
} // namespace Rcpp
Modified: pkg/src/Rcpp/Environment.h
===================================================================
--- pkg/src/Rcpp/Environment.h 2009-12-30 22:33:13 UTC (rev 245)
+++ pkg/src/Rcpp/Environment.h 2009-12-31 10:59:31 UTC (rev 246)
@@ -25,14 +25,77 @@
#include <RcppCommon.h>
#include <Rcpp/RObject.h>
-#define IS_USER_DATABASE(rho) OBJECT((rho)) && Rf_inherits((rho), "UserDefinedDatabase")
-
namespace Rcpp{
class Environment: public RObject{
public:
-
+
+ /**
+ * Exception thrown when attempting to perform an operation on
+ * a binding and there is no such binding
+ */
+ class no_such_binding: public std::exception{
+ public:
+ /**
+ * @param binding name of the binding
+ */
+ no_such_binding( const std::string& binding) ;
+
+ /**
+ * The message: no such binding : '{binding}'
+ */
+ const char* what() const throw();
+
+ ~no_such_binding() throw() ;
+
+ private:
+ std::string message ;
+ } ;
+
/**
+ * Exception thrown when attempting to assign a value to a binding
+ * that is locked
+ */
+ class binding_is_locked: public std::exception{
+ public:
+ /**
+ * @param binding name of the binding
+ */
+ binding_is_locked( const std::string& binding) ;
+
+ /**
+ * The message: binding is locked : '{binding}'
+ */
+ const char* what() const throw() ;
+
+ ~binding_is_locked() throw() ;
+ private:
+ std::string message ;
+ } ;
+
+ /**
+ * Exception thrown when attempting to get a namespace that does
+ * not exist
+ */
+ class no_such_namespace: public std::exception{
+ public:
+ /**
+ * @param package name of the package
+ */
+ no_such_namespace( const std::string& package) ;
+
+ /**
+ * The message: no such namespace : '{package}'
+ */
+ const char* what() const throw() ;
+
+ ~no_such_namespace() throw() ;
+ private:
+ std::string message ;
+ } ;
+
+
+ /**
* wraps the given environment
*
* if the SEXP is not an environment, and exception is thrown
@@ -80,8 +143,11 @@
* @param x object to assign
*
* @return true if the assign was successfull
+ * see ?bindingIsLocked
+ *
+ * @throw binding_is_locked if the binding is locked
*/
- bool assign( const std::string& name, SEXP x ) const ;
+ bool assign( const std::string& name, SEXP x ) const throw(binding_is_locked) ;
/**
* @return true if this environment is locked
@@ -90,12 +156,40 @@
bool isLocked() const ;
/**
+ * locks this environment. See ?lockEnvironment
+ *
+ * @param bindings also lock the bindings of this environment ?
+ */
+ void lock(bool bindings) ;
+
+ /* maybe we should have a separate class, e.g. Binding to deal
+ with the 4 below functions ? */
+
+ /**
+ * Locks the given binding in the environment.
+ * see ?bindingIsLocked
+ *
+ * @throw no_such_binding if there is no such binding in this environment
+ */
+ void lockBinding(const std::string& name) throw(no_such_binding);
+
+ /**
+ * unlocks the given binding
+ * see ?bindingIsLocked
+ *
+ * @throw no_such_binding if there is no such binding in this environment
+ */
+ void unlockBinding(const std::string& name) throw(no_such_binding) ;
+
+ /**
* @param name name of a potential binding
*
* @return true if the binding is locked in this environment
* see ?bindingIsLocked
+ *
+ * @throw no_such_binding if there is no such binding in this environment
*/
- bool bindingIsLocked(const std::string& name) const ;
+ bool bindingIsLocked(const std::string& name) const throw(no_such_binding) ;
/**
*
@@ -103,16 +197,44 @@
*
* @return true if the binding is active in this environment
* see ?bindingIsActive
+ *
+ * @throw no_such_binding if there is no such binding in this environment
*/
- bool bindingIsActive(const std::string& name) const ;
+ bool bindingIsActive(const std::string& name) const throw(no_such_binding) ;
-protected:
-
+ /**
+ * Indicates if this is a user defined database.
+ */
+ bool is_user_database() const ;
+
/**
- * we cache whether this environment is a user defined database
- * or a standard environment
+ * @return the global environment. See ?globalenv
*/
- bool is_user_database ;
+ static Environment global_env() throw() ;
+
+ /**
+ * @return The empty environment. See ?emptyenv
+ */
+ static Environment empty_env() throw() ;
+
+ /**
+ * @return the base environment. See ?baseenv
+ */
+ static Environment base_env() throw() ;
+
+ /**
+ * @return the base namespace. See ?baseenv
+ */
+ static Environment base_namespace() throw() ;
+
+ /**
+ * @param name the name of the package of which we want the namespace
+ *
+ * @return the namespace of the package
+ *
+ * @throw no_such_namespace
+ */
+ static Environment namespace_env(const std::string& ) throw(no_such_namespace) ;
};
} // namespace Rcpp
_______________________________________________
Rcpp-commits mailing list
Rcpp-commits at lists.r-forge.r-project.org
https://lists.r-forge.r-project.org/cgi-bin/mailman/listinfo/rcpp-commits
More information about the Rcpp-devel
mailing list