Environment.h

Go to the documentation of this file.

// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*-
//
// Environment.h: Rcpp R/C++ interface class library -- access R environments
//
// Copyright (C) 2009 - 2013  Dirk Eddelbuettel and Romain Francois
// Copyright (C) 2014 - 2020  Dirk Eddelbuettel, Romain Francois and Kevin Ushey
//
// This file is part of Rcpp.
//
// Rcpp 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.
//
// Rcpp is distributed in the hope that it will be useful, but
// WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
// GNU General Public License for more details.
//
// You should have received a copy of the GNU General Public License
// along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
 
#ifndef Rcpp_Environment_h
#define Rcpp_Environment_h
 
namespace Rcpp{
 
    RCPP_API_CLASS(Environment_Impl),
        public BindingPolicy< Environment_Impl<StoragePolicy> >
    {
    private:
        inline SEXP as_environment(SEXP x){
            if( Rf_isEnvironment(x) ) return x ;
            SEXP asEnvironmentSym = Rf_install("as.environment");
            try {
                Shield<SEXP> call(Rf_lang2(asEnvironmentSym, x));
                return Rcpp_fast_eval(call, R_GlobalEnv);
            } catch( const eval_error& ex) {
                const char* fmt = "Cannot convert object to an environment: "
                                  "[type=%s; target=ENVSXP].";
                throw not_compatible(fmt, Rf_type2char(TYPEOF(x)));
            }
        }
 
    public:
        RCPP_GENERATE_CTOR_ASSIGN(Environment_Impl)
 
        Environment_Impl(){
            Storage::set__(R_GlobalEnv) ;
        } ;
 
        Environment_Impl(SEXP x) {
            Shield<SEXP> env(as_environment(x));
            Storage::set__(env) ;
        }
 
        Environment_Impl( const std::string& name ) ;
 
        Environment_Impl( int pos ) ;
 
        SEXP ls(bool all) const {
            SEXP env = Storage::get__() ;
            if( is_user_database() ){
                R_ObjectTable *tb = (R_ObjectTable*) R_ExternalPtrAddr(HASHTAB(env));
                return tb->objects(tb) ;
            } else {
                return R_lsInternal( env, all ? TRUE : FALSE ) ;
            }
            return R_NilValue ;
        }
 
        SEXP get(const std::string& name) const {
            SEXP env = Storage::get__() ;
            SEXP nameSym = Rf_install(name.c_str());
            SEXP res = Rf_findVarInFrame( env, nameSym ) ;
 
            if( res == R_UnboundValue ) return R_NilValue ;
 
            /* We need to evaluate if it is a promise */
            if( TYPEOF(res) == PROMSXP){
                res = internal::Rcpp_eval_impl( res, env ) ;
            }
            return res ;
        }
 
        SEXP get(Symbol name) const {
            SEXP env = Storage::get__() ;
            SEXP res = Rf_findVarInFrame( env, name ) ;
 
            if( res == R_UnboundValue ) return R_NilValue ;
 
            /* We need to evaluate if it is a promise */
            if( TYPEOF(res) == PROMSXP){
                res = internal::Rcpp_eval_impl( res, env ) ;
            }
            return res ;
        }
 
 
        SEXP find( const std::string& name) const{
            SEXP env = Storage::get__() ;
            SEXP nameSym = Rf_install(name.c_str());
            SEXP res = Rf_findVar( nameSym, env ) ;
 
            if( res == R_UnboundValue ) throw binding_not_found(name) ;
 
            /* We need to evaluate if it is a promise */
            if( TYPEOF(res) == PROMSXP){
                res = internal::Rcpp_eval_impl( res, env ) ;
            }
            return res ;
        }
 
        SEXP find(Symbol name) const{
            SEXP env = Storage::get__() ;
            SEXP res = Rf_findVar( name, env ) ;
 
            if( res == R_UnboundValue ) {
                // Pass on the const char* to the RCPP_EXCEPTION_CLASS's
                // const std::string& requirement
                throw binding_not_found(name.c_str()) ;
            }
 
            /* We need to evaluate if it is a promise */
            if( TYPEOF(res) == PROMSXP){
                res = internal::Rcpp_eval_impl( res, env ) ;
            }
            return res ;
        }
 
        bool exists( const std::string& name ) const {
            SEXP nameSym = Rf_install(name.c_str());
            SEXP res = Rf_findVarInFrame( Storage::get__() , nameSym  ) ;
            return res != R_UnboundValue ;
        }
 
        bool assign( const std::string& name, SEXP x ) const{
            if( exists( name) && bindingIsLocked(name) ) throw binding_is_locked(name) ;
            SEXP nameSym = Rf_install(name.c_str());
            Rf_defineVar( nameSym, x, Storage::get__() );
            return true ;
        }
 
        bool assign(const std::string& name, const Shield<SEXP>& x) const {
            return assign(name, (SEXP) x);
        }
 
        template <typename WRAPPABLE>
        bool assign( const std::string& name, const WRAPPABLE& x) const ;
 
        bool isLocked() const {
             return R_EnvironmentIsLocked(Storage::get__());
        }
 
        bool remove( const std::string& name ){
            if( exists(name) ){
                if( bindingIsLocked(name) ){
                    throw binding_is_locked(name) ;
                } else{
                    /* unless we want to copy all of do_remove,
                       we have to go back to R to do this operation */
                    SEXP internalSym = Rf_install( ".Internal" );
                    SEXP removeSym = Rf_install( "remove" );
                    Shield<SEXP> str(Rf_mkString(name.c_str()));
                    Shield<SEXP> call(Rf_lang2(internalSym, Rf_lang4(removeSym, str, Storage::get__(), Rf_ScalarLogical(FALSE))));
                    Rcpp_fast_eval( call, R_GlobalEnv ) ;
                }
            } else{
                throw no_such_binding(name) ;
            }
            return true;
        }
 
        void lock(bool bindings = false) {
            R_LockEnvironment( Storage::get__(), bindings ? TRUE: FALSE ) ;
        }
 
        void lockBinding(const std::string& name){
            if( !exists( name) ) throw no_such_binding(name) ;
            SEXP nameSym = Rf_install(name.c_str());
            R_LockBinding( nameSym, Storage::get__() );
        }
 
        void unlockBinding(const std::string& name){
            if( !exists( name) ) throw no_such_binding(name) ;
            SEXP nameSym = Rf_install(name.c_str());
            R_unLockBinding( nameSym, Storage::get__() );
        }
 
        bool bindingIsLocked(const std::string& name) const{
            if( !exists( name) ) throw no_such_binding(name) ;
            SEXP nameSym = Rf_install(name.c_str());
            return R_BindingIsLocked(nameSym, Storage::get__() ) ;
        }
 
        bool bindingIsActive(const std::string& name) const {
            if( !exists( name) ) throw no_such_binding(name) ;
            SEXP nameSym = Rf_install(name.c_str());
            return R_BindingIsActive(nameSym, Storage::get__()) ;
        }
 
        bool is_user_database() const {
            SEXP env = Storage::get__() ;
            return OBJECT(env) && Rf_inherits(env, "UserDefinedDatabase") ;
        }
 
        static Environment_Impl global_env(){
            return R_GlobalEnv ;
        }
 
        static Environment_Impl empty_env(){
            return R_EmptyEnv ;
        }
 
        static Environment_Impl base_env(){
            return R_BaseEnv ;
        }
 
        static Environment_Impl base_namespace(){
            return R_BaseNamespace ;
        }
 
        static Environment_Impl Rcpp_namespace(){
            return Rcpp::internal::get_Rcpp_namespace() ;
        }
 
        static Environment_Impl namespace_env(const std::string& package){
            Armor<SEXP> env ;
            try{
                SEXP getNamespaceSym = Rf_install("getNamespace");
                Shield<SEXP> package_str( Rf_mkString(package.c_str()) );
                Shield<SEXP> call( Rf_lang2(getNamespaceSym, package_str) );
                env = Rcpp_fast_eval(call, R_GlobalEnv);
            } catch( ... ){
                throw no_such_namespace( package  ) ;
            }
            return Environment_Impl( env ) ;
        }
 
        Environment_Impl parent() const {
            return Environment_Impl( ENCLOS(Storage::get__()) ) ;
        }
 
        Environment_Impl new_child(bool hashed) const {
            SEXP newEnvSym = Rf_install("new.env");
            Shield<SEXP> call(Rf_lang3(newEnvSym, Rf_ScalarLogical(hashed), Storage::get__()));
            return Environment_Impl(Rcpp_fast_eval(call, R_GlobalEnv));
        }
 
        void update(SEXP){}
    };
 
typedef Environment_Impl<PreserveStorage> Environment ;
 
} // namespace Rcpp
 
#endif