debug.R

### BREAKPOINTS
.ESSBP. <- new.env()

### DEBUG/UNDEBUG
.ess_find_funcs <- function(env)
    {
        objs <- ls(envir = env, all.names = TRUE)
        objs[sapply(objs, exists, envir = env,
                    mode = 'function', inherits = FALSE)]
    }

.ess_all_functions <- function(packages = c(), env = NULL)
    {
        if(is.null(env))
            env <- parent.frame()
        empty <- emptyenv()
        coll <- list()
        for(p in packages){
            ## package might not be attached
            try({objNS <- .ess_find_funcs(asNamespace(p))
                 objPKG <- .ess_find_funcs(as.environment(paste0('package:', p)))
                 coll[[length(coll) + 1]] <-
                     paste0(p, ':::`', setdiff(objNS, objPKG), '`')
             }, silent = TRUE)
        }
        while(!identical(empty, env)){
            coll[[length(coll) + 1]] <- .ess_find_funcs(env)
            env <- parent.env(env)
        }
        grep('^\\.ess', unlist(coll, use.names = FALSE),
             invert = TRUE, value = TRUE)
    }

.ess_dbg_getTracedAndDebugged <- function(packages = c())
    {
        tr_state <- tracingState(FALSE)
        on.exit(tracingState(tr_state))
        generics <- methods::getGenerics()
        all_traced <- c()
        for(i in seq_along(generics)){
            genf <- methods::getGeneric(generics[[i]],
                                        package=generics@package[[i]])
            if(!is.null(genf)){ ## might happen !! v.2.13
                menv <- methods::getMethodsForDispatch(genf)
                traced <- unlist(eapply(menv, is, 'traceable', all.names=TRUE))
                if(length(traced) && any(traced))
                    all_traced <- c(paste(generics[[i]],':',
                                          names(traced)[traced],sep=''), all_traced)
                tfn <- getFunction(generics[[i]], mustFind=FALSE, where = .GlobalEnv)
                if(!is.null(tfn ) && is(tfn,  'traceable')) # if the default is traced,  it does not appear in the menv :()
                    all_traced <- c(generics[[i]], all_traced)
            }
        }
        debugged_pkg <- unlist(lapply(packages, function(pkgname){
            ns <- asNamespace(pkgname)
            funcs <- .ess_find_funcs(ns)
            dbged <- funcs[unlist(lapply(funcs,
                                         function(f){
                                             isdebugged(get(f, envir = ns, inherits = FALSE))
                                         }))]
            if(length(dbged))
                paste0(pkgname, ':::`', dbged, '`')
        }))
        env <- parent.frame()
        ## traced function don't appear here. Not realy needed and would affect performance.
        all <- .ess_all_functions(packages = packages, env = env)
        which_deb <- lapply(all, function(nm){
            ## if isdebugged is called with string it doess find
            tryCatch(isdebugged(get(nm, envir = env)),
                     error = function(e) FALSE)
            ## try(eval(substitute(isdebugged(nm), list(nm = as.name(nm)))), silent = T)
        })
        debugged <- all[which(unlist(which_deb, recursive=FALSE, use.names=FALSE))]
        unique(c(debugged_pkg, debugged, all_traced))
    }

.ess_dbg_UntraceOrUndebug <- function(name, env = parent.frame())
    {
        tr_state <- tracingState(FALSE)
        on.exit(tracingState(tr_state))
        if( grepl('::', name) ){
            ## foo:::bar name
            eval(parse(text = sprintf('undebug(%s)', name)))
        }else{
            ## name is a name of a function to be undebugged or has a form
            ## name:Class1#Class2#Class3 for traced methods
            name <- strsplit(name, ':', fixed = TRUE)[[1]]
            if( length(name)>1 ){
                ## a method
                fun <- name[[1]]
                sig <- strsplit(paste(name[-1], collapse=''), '#', fixed=TRUE)[[1]]
                untrace(fun, signature = sig)
            }else{
                ## function
                if( is(getFunction(name, where = parent.frame()), 'traceable') )
                    untrace(name)
                else if(grepl(":", name))
                    undebug(name)
                else
                    undebug(get(name, envir = env))
            }}
    }

.ess_dbg_UndebugALL <- function(funcs)
    {
        tr_state <- tracingState(FALSE)
        on.exit(tracingState(tr_state))
        env <- parent.frame()
        invisible(lapply(funcs, function( nm ) {
            ## ugly tryCatch, but there might be several names pointing to the
            ## same function, like foo:::bar and bar. An alternative would be
            ## to call .ess_dbg_getTracedAndDebugged each time but that might
            ## be ery slow
            try(.ess_dbg_UntraceOrUndebug(nm, env = env), TRUE)
        }))
    }

### WATCH
.ess_watch_expressions <- list()

.ess_watch_eval <- function()
    {
        env <- as.environment("ESSR")
        exps <- get('.ess_watch_expressions', envir = env)
        if(length(exps) == 0) {
            ## using old style so this can be parsed by R 1.9.1 (e.g):
            cat('\n# Watch list is empty!\n',
'# a       append new expression',
'# i       insert new expression',
'# k       kill',
'# e       edit the expression',
'# r       rename',
'# n/p     navigate',
'# u/d,U   move the expression up/down',
'# q       kill the buffer',
sep="\n")
        } else {
            .parent_frame <- parent.frame()
            .essWEnames <- allNames(exps)
            len0p <- !nzchar(.essWEnames)
            .essWEnames[len0p] <- seq_along(len0p)[len0p]
            for(i in seq_along(exps)) {
                cat('\n@---- ', .essWEnames[[i]], ' ',
                    rep.int('-', max(0, 35 - nchar(.essWEnames[[i]]))), '-@\n', sep = '')
                cat(paste('@---:', deparse(exps[[i]][[1]])), ' \n', sep = '')
                tryCatch(print(eval(exps[[i]],
                                    envir = .parent_frame)),
                         error = function(e) cat('Error:', e$message, '\n' ),
                         warning = function(w) cat('warning: ', w$message, '\n' ))
            }
        }
    }

.ess_watch_assign_expressions <- function(elist){
    assign(".ess_watch_expressions", elist, envir = as.environment("ESSR"))
}

.ess_log_eval <- function(log_name)
    {
        env <- as.environment("ESSR")
        if(!exists(log_name, envir = env, inherits = FALSE))
            assign(log_name, list(), envir = env)
        log <- get(log_name, envir = env, inherits = FALSE)
        .essWEnames <- allNames(.ess_watch_expressions)
        cur_log <- list()
        .parent_frame <- parent.frame()
        for(i in seq_along(.ess_watch_expressions)) {
            capture.output( {
                cur_log[[i]] <-
                    tryCatch(eval(.ess_watch_expressions[[i]]),
                             envir = .parent_frame,
                             error = function(e) paste('Error:', e$message, '\n'),
                             warning = function(w) paste('warning: ', w$message, '\n'))
                if(is.null(cur_log[i][[1]]))
                    cur_log[i] <- list(NULL)
            })
        }
        names(cur_log) <- .essWEnames
        assign(log_name, c(log, list(cur_log)), envir = env)
        invisible(NULL)
    }

.ess_package_attached <- function(pack_name){
    as.logical(match(paste0("package:", pack_name), search()))
}