#  File src/library/methods/R/trace.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2016 The R Core Team
#
#  This program 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.
#
#  This program 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.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

## some temporary (!) hooks to trace the tracing code
.doTraceTrace <- function(on) {
 .assignOverBinding(".traceTraceState", on,
                    environment(.doTraceTrace), FALSE)
  on
}

.traceTraceState <- FALSE

## the internal functions in the evaluator.  These are all prohibited,
## although some of them could just barely be accomodated, with some
## specially designed new definitions (not using ..., for example).
## The gain does not seem worth the inconsistencies; and "if" can
## never be traced, since it has to be used to determine if tracing is
## on.  (see .doTrace())
## The remaining invalid functions create miscellaneous bugs, maybe
## related to the use of "..." as the introduced arguments.  Aside from
## .Call, tracing them seems of marginal value.

.InvalidTracedFunctions <- c("if", "where", "for", "repeat", "(", "{",
                            "next", "break", ".Call", ".Internal", ".Primitive")

.TraceWithMethods <- function(what, tracer = NULL, exit = NULL, at = numeric(),
			      print = TRUE, signature = NULL,
			      where = .GlobalEnv, edit = FALSE, from = NULL,
			      untrace = FALSE, classMethod = FALSE) {
    fromPackage <-
        if(is.function(where)) {
            ## start from the function's environment:  important for
            ## tracing from a namespace
            where <- if(is(where, "genericFunction"))
                parent.env(environment(where))
            else
                environment(where)
            getPackageName(where)
        } else ""
    doEdit <- !isFALSE(edit)
    whereF <- NULL
    pname <- character()
    def <- NULL
    tracingWhere <- "in package"
    refCase <- isS4(where) && (is(where, "envRefClass") ||
                               is(where, "refClassRepresentation"))
    if(refCase) {
        ## some error checking
        if(!is.null(signature))
            stop("argument 'signature' is not meaningful for tracing reference methods")
        .where <- where # to avoid substituting where in the eval() below
        ## A reference class object or its class or its generator
        if(is(.where, "refGeneratorSlot") && !classMethod)
            .where <- .where$def # should now be the refClassRepresentation
        if(is(.where, "refClassRepresentation")) {
            pname <- .where@className
            .where <- .where@refMethods
            tracingWhere <- "for class"
        }
        else {
            tracingWhere <- "for object from class"
            pname <- class(.where)
        }
        ## interpret as tracing .where$what
        def <- eval(substitute(.dollarForEnvRefClass(.where, what)))
        if(!is(def, "refMethodDef")) {
            thisName <- substitute(what)
            stop(gettextf("%s is not a method for reference class %s",
			  sQuote(as.character(if(is.symbol(thisName)) thisName
					      else what)),
                          dQuote(class(where))),
                 domain = NA)
        }
        what <- def@name
        whereF <- .where
    }
    else if(is.function(what)) {
        def <- what
        if(is(def, "genericFunction")) {
            what <- def@generic
            whereF <- .genEnv(what, where)
            pname <- def@package
        }
        else {
            fname <- substitute(what)
            if(is.name(fname)) {
                what <- as.character(fname)
                temp <- .findFunEnvAndName(what, where)
                whereF <- temp$whereF
                pname <- temp$pname
            }
            else if(is.call(fname) && identical(fname[[1L]], as.name("::"))) {
                whereF <- as.character(fname[[2L]])
                require(whereF, character.only = TRUE)
                whereF <- as.environment(paste0("package:", whereF))
                pname <-  fname[[2L]]
                what <- as.character(fname[[3L]])
            }
            else if(is.call(fname) && identical(fname[[1L]], as.name(":::"))) {
                pname <- paste(fname[[2L]], "(not-exported)")
                whereF <- loadNamespace(as.character(fname[[2L]]))
                what <- as.character(fname[[3L]])
            }
            else
                stop("argument 'what' should be the name of a function")
        }
    }
    else {
        what <- as(what, "character")
        if(length(what) != 1) {
            for(f in what) {
                if(nargs() == 1)
                    trace(f)
                else
                    Recall(f, tracer, exit, at, print, signature, where, edit, from, untrace)
            }
            return(what)
        }
        temp <- .findFunEnvAndName(what, where, signature)
        whereF <- temp$whereF
        pname <- temp$pname
        fname <- what
    }
    if(what %in% .InvalidTracedFunctions)
        stop(gettextf("tracing the internal function %s is not allowed",
		      sQuote(what)), domain = NA)
    if(.traceTraceState) {
        message(".TraceWithMethods: after computing what, whereF", domain = NA)
        browser()
    }
    if(nargs() == 1) # for back compatibility
	return(if(untrace) .primUntrace(what) else .primTrace(what))
## FIXME: for trace(stats:::.....)  we really want -- how can this be solved
##    	return(if(untrace) .primUntrace(frame) else .primTrace(fname))
    if(is.null(whereF)) {
        allWhere <- findFunction(what, where = where)
        if(length(allWhere)==0)
	    stop(gettextf("no function definition for %s found", sQuote(what)),
                 domain = NA)
        whereF <- as.environment(allWhere[[1L]])
    }
    ## detect use with no action specified (old-style R trace())
    if(is.null(tracer) && is.null(exit) && isFALSE(edit))
        tracer <- quote({})
    if(is.null(def))
        def <- getFunction(what, where = whereF)
    if(is(def, "traceable") && isFALSE(edit) && !untrace)
        def <- .untracedFunction(def)
    if(!is.null(signature)) {
        fdef <- if (!is(def, "genericFunction"))
                    getGeneric(as.character(fname), TRUE, where)
                else def
        def <- selectMethod(what, signature, fdef = fdef, optional = TRUE)
        if(isRematched(def)) {
            expr <- substitute(trace(.local, tracer = tr, at = at,
                                     exit = ex,  print = pr,
                                     edit = ed,
                                     where = sys.frame(sys.nframe())),
                               list( tr = substitute(tracer),
                                    ex = exit, at = at, pr = print,
                                    ed = edit))
            at <- 3L
            tracer <- expr
            print <- FALSE
        }
        if(is.null(def)) {
            warning(gettextf("cannot untrace method for %s; no method defined for this signature: %s",
                             sQuote(what),
                             paste(signature, collapse = ", ")),
                    domain = NA)
            return(def)
        }
        ## pick up signature with package slot from selectMethod
        signature <- def@target
    }
    if(untrace) {
        if(.traceTraceState) {
            message(".TraceWithMethods: untrace case", domain = NA)
            browser()
        }

        if(is.null(signature)) {
            ## ensure that the version to assign is untraced
            if(is(def, "traceable")) {
                newFun <- .untracedFunction(def)
            }
            else {
                .primUntrace(what) # to be safe--no way to know if it's traced or not
### or sometimes rather _FIXME_ ?
###             .primUntrace(fname) # (rather than 'what')
                return(what)
            }
        }
        else {
            if(is(def, "traceable"))
                newFun <- .untracedFunction(def)
            else {
                warning(gettextf("the method for %s for this signature was not being traced",
                                 sQuote(what)),
                        domain = NA)
                return(what)
            }
        }
    }
    else {
        if(!is.null(exit)) {
            if(is.function(exit)) {
                tname <- substitute(exit)
                if(is.name(tname))
                    exit <- tname
                exit <- substitute(TRACE(), list(TRACE=exit))
            }
        }
        if(!is.null(tracer)) {
            if(is.function(tracer)) {
                tname <- substitute(tracer)
                if(is.name(tname))
                    tracer <- tname
                tracer <- substitute(TRACE(), list(TRACE=tracer))
            }
        }
        original <- .untracedFunction(def)
        traceClass <- .traceClassName(class(original))
        if(is.null(getClassDef(traceClass)))
            traceClass <- .makeTraceClass(traceClass, class(original))
        if(doEdit && is.environment(edit)) {
            ## trace with the version found in the edit environment
            def <- .findNewDefForTrace(what, signature, edit, fromPackage)
            environment(def) <- environment(original)
            if(is.null(c(tracer, exit))) {
                newFun <- new(traceClass, original)
                newFun@.Data <- def
            }
            else {
                newFun <- new(traceClass, def = def, tracer = tracer, exit = exit, at = at, print = print, doEdit = FALSE)
                newFun@original <- original # left as def by initialize method
            }
            newFun@source <- edit
        }
        else
            newFun <- new(traceClass,
                      def = if(doEdit) def else original, tracer = tracer, exit = exit, at = at,
                      print = print, doEdit = edit)
    }
    global <- identical(whereF, .GlobalEnv)
    if(.traceTraceState) {
        message(".TraceWithMethods: about to assign or setMethod", domain = NA)
        browser()
    }
    if(is.null(signature)) {
        if(bindingIsLocked(what, whereF))
            .assignOverBinding(what, newFun, whereF, global)
        else
            assign(what, newFun, whereF)
        if (length(pname) != 0) {
            ## update the function also in "imports:" environments of already
            ## loaded packages that import package pname

            spname <- sub("^namespace:", "", pname)
                # catching error in case when spname is not a name of a namespace, but
                # e.g. a reference class
            ipkgs <- tryCatch(getNamespaceUsers(spname), error=function(e){c()})
            for(importingPkg in ipkgs) {
              .updateInImportsEnv(what, newFun, importingPkg)
            }
        }
        if(length(grep("[^.]+[.][^.]+", what)) > 0) { #possible S3 method
            ## check for a registered version of the object
            S3MTableName <- ".__S3MethodsTable__."
            if(!is.null(tbl <- get0(S3MTableName, envir = whereF, inherits = FALSE))) {
                if(exists(what, envir = tbl, inherits = FALSE)) {
		    tracedFun <- get(what, envir = whereF, inherits = TRUE)
		    assign(what, tracedFun, envir = tbl)
                }
            }
        }
    }
    else {
        if(untrace && is(newFun, "MethodDefinition") &&
           !identical(newFun@target, newFun@defined))
            ## we promoted an inherited method for tracing, now we have
            ## to remove that method.  Assertion is that there was no directly
            ## specified method, or else defined, target would be identical
            newFun <- NULL
        ## arrange for setMethod to put the new method in the generic
        ## but NOT to assign the methods list object (binding is ignored)
        setMethod(fdef, signature, newFun, where = baseenv())
    }
    if(!global) {
        action <- if(untrace)"Untracing" else "Tracing"
        nameSpaceCase <- FALSE
        location <- if(.identC(fromPackage, "")) {
            if(length(pname)==0  && !is.null(whereF))
                pname <- getPackageName(whereF)
            nameSpaceCase <- isNamespace(whereF) &&
            !is.na(match(pname, loadedNamespaces())) &&
            identical(whereF, getNamespace(pname))
            if(length(pname)==0)  # but not possible from getPackagename ?
                ""
            else {
                if(nameSpaceCase)
                    paste0(" in environment <namespace:",  pname, ">")
                else
                    paste0(" ", tracingWhere, " \"",  pname, "\"")
            }
        }
        else paste0(" as seen from package \"", fromPackage, "\"")
	object <- if(refCase) "reference method"
		  else if(is.null(signature)) "function"
		  else "specified method for function"
        object <- paste0(" ", object, " \"", what, "\" ")
        .message(action, object, location)
        ## tracing methods (signature not null) works without setting where
        if(nameSpaceCase && !untrace && is.null(signature) && exists(what, envir = .GlobalEnv)) {
	    untcall <- paste0("untrace(\"", what,
			      "\", where = getNamespace(\"", pname, "\"))")
            .message("Warning: Tracing only in the namespace; to untrace you will need:\n    ",
                     untcall, "\n")
        }
    }
    what
}

.makeTracedFunction <- function(def, tracer, exit, at, print, doEdit) {
    switch(typeof(def),
           builtin = {
               fBody <- substitute({.prim <- DEF; .prim(...)},
                                   list(DEF = def))
               def <- eval(function(...)NULL)
               body(def, envir = .GlobalEnv) <- fBody
           },
           special = {
               fBody <- substitute({do.call(DEF, list(...))},
                                   list(DEF = def))
               def <- eval(function(...)NULL)
               body(def, envir = .GlobalEnv) <- fBody
               warning("making a traced version of a special; arguments may be altered")
           }
           )
    if(!isFALSE(doEdit)) {
        if(is.character(doEdit) || is.function(doEdit)) {
            editor <- doEdit
            doEdit <- TRUE
        }
        else
            editor <- getOption("editor")
    }
    ## look for a request to edit the definition
    if(doEdit) {
        if(is(def, "traceable"))
            def <- as(def, "function") # retain previous tracing if editing
        if(is(editor, "character") && !is.na(match(editor, c("emacs","xemacs")))) {
            ## cater to the usual emacs modes for editing R functions
            file <- tempfile("emacs")
            file <- sub('..$', ".R", file)
        }
        else
            file <- ""
        ## insert any requested automatic tracing expressions before editing
        if(!(is.null(tracer) && is.null(exit) && length(at)==0))
            def <- Recall(def, tracer, exit, at, print, FALSE)
        def2 <- utils::edit(def, editor = editor, file = file)
        if(!is.function(def2))
            stop(gettextf("the editing in trace() can only change the body of the function; got an object of class %s",
                          dQuote(class(def2))),
                 domain = NA)
        if(!identical(args(def), args(def2)))
            stop("the editing in trace() can only change the body of the function, not the arguments or defaults")
        fBody <- body(def2)
    }
    else {
        def <- .untracedFunction(def) # throw away earlier tracing
        fBody <- body(def)
        if(length(at) > 0) {
            if(is.null(tracer))
                stop("cannot use 'at' argument without a trace expression")
            else if(!inherits(fBody, "{"))
                stop("cannot use 'at' argument unless the function body has the form '{ ... }'")
            for(i in at) {
		fBody[[i]] <-
		    if(print)
			substitute({.doTrace(TRACE, MSG); EXPR},
                                   list(TRACE = tracer,
                                        MSG = paste("step",paste(i, collapse=",")),
                                        EXPR = fBody[[i]]))
		    else
			substitute({.doTrace(TRACE); EXPR},
                                   list(TRACE=tracer, EXPR = fBody[[i]]))
            }
        }
        else if(!is.null(tracer)){
	    fBody <-
		if(print)
		    substitute({.doTrace(TRACE, MSG); EXPR},
                                    list(TRACE = tracer, MSG = paste("on entry"), EXPR = fBody))
		else
		    substitute({.doTrace(TRACE); EXPR},
                                    list(TRACE=tracer, EXPR = fBody))
        }
        if(!is.null(exit)) {
	    exit <-
		if(print)
		    substitute(.doTrace(EXPR, MSG),
                                   list(EXPR = exit, MSG = paste("on exit")))
		else
		    substitute(.doTrace(EXPR),
                                   list(EXPR = exit))
            fBody <- substitute({on.exit(TRACE); BODY},
                                list(TRACE=exit, BODY=fBody))
        }
    }
    body(def, envir = environment(def)) <- fBody
    def
}

## return the untraced version of f
.untracedFunction <- function(f) {
    while(is(f, "traceable"))
        f <- f@original
    f
}


.InitTraceFunctions <- function(envir)  {
    setClass("traceable", representation(original = "PossibleMethod", source = "environment"), contains = "VIRTUAL",
             where = envir); clList <- "traceable"
    ## create the traceable classes
    for(cl in c("function", "MethodDefinition", "MethodWithNext", "genericFunction",
                "standardGeneric", "nonstandardGeneric", "groupGenericFunction",
                "derivedDefaultMethod")) {
        .makeTraceClass(.traceClassName(cl), cl, FALSE)
        clList <- c(clList, .traceClassName(cl))
    }
    setClass("sourceEnvironment", contains = "environment",
             representation(packageName = "character", dateCreated = "POSIXt", sourceFile = "character"),
             prototype = prototype( packageName = "", dateCreated = Sys.time(), sourceFile = ""))
    clList <- c(clList, "sourceEnvironment")
    assign(".SealedClasses", c(get(".SealedClasses", envir), clList), envir)
    setMethod("initialize", "traceable",
              function(.Object, ...) .initTraceable(.Object, ...),
              where = envir)
    if(!isGeneric("show", envir))
        setGeneric("show", where = envir, simpleInheritanceOnly = TRUE)
    setMethod("show", "traceable", .showTraceable, where = envir)
    setMethod("show", "sourceEnvironment", .showSource, where = envir)
}

## allow control over whether methods & classes are cached when assigned
## to a particular environment. defaults to TRUE
cacheOnAssign <- function(env) is.null(env$.cacheOnAssign) || env$.cacheOnAssign
setCacheOnAssign <- function(env, onOff = cacheOnAssign(env))
    env$.cacheOnAssign <- if(onOff) TRUE else FALSE

.showTraceable <- function(object) {
    if(identical(object@source, emptyenv())) {
        cat("Object with tracing code, class \"", class(object),
        "\"\nOriginal definition: \n", sep="")
        callGeneric(object@original)
        cat("\n## (to see the tracing code, look at body(object))\n")
    }
    else {
        cat("Object of class \"", class(object),
            "\", from source\n", sep = "")
        callGeneric(object@.Data)
        cat("\n## (to see original from package, look at object@original)\n")
    }
}

.initTraceable <- function(.Object, def, tracer, exit, at, print, doEdit) {
    .Object@source <- emptyenv()
    if(missing(def))
        return(.Object)
    oldClass <- class(def)
    oldClassDef <- getClass(oldClass)
    if(!is.null(oldClassDef) && length(oldClassDef@slots) > 0)
        as(.Object, oldClass) <- def # to get other slots in def
    .Object@original <- def
    if(nargs() > 2) {
	if(!is.null(elNamed(getSlots(getClass(class(def))), ".Data")))
	    def <- def@.Data
        .Object@.Data <- .makeTracedFunction(def, tracer, exit, at, print, doEdit)
    }
    .Object
}

.showSource <- function(object) {
    cat("Object of class \"", class(object), "\"\n", sep = "")
    cat("Source environment created ", format(object@dateCreated), "\n")
    if(nzchar(object@packageName))
        cat("For package \"",object@packageName, "\"\n", sep = "")
    if(nzchar(object@sourceFile))
        cat("From source file \"", object@sourceFile, "\"\n", sep = "")
}

.doTracePrint <- function(msg = "") {
    call <- deparse(sys.call(sys.parent(1)))
    if(length(call)>1)
        call <- paste(call[[1L]], "....")
    cat("Tracing", call, msg, "\n")
}

.traceClassName <- function(className) {
    className[] <- paste0(className, "WithTrace")
    className
}

.assignOverBinding <- function(what, value, where, verbose = TRUE) {
    if(verbose) {
        pname <- getPackageName(where)
        msg <-
            gettextf("assigning over the binding of symbol %s in environment/package %s",
                     sQuote(what), sQuote(pname))
        message(strwrap(msg), domain = NA)
    }
    warnOpt <- options(warn= -1) # kill the obsolete warning from R_LockBinding
    on.exit(options(warnOpt))
    if(is.function(value)) {
        ## assign in the namespace for the function as well
        fenv <- environment(value)
        if(is.null(fenv)) # primitives
          fenv <- baseenv()
        if(!identical(fenv, where) && exists(what, envir = fenv, inherits = FALSE #?
                                             ) && bindingIsLocked(what, fenv)) {
            unlockBinding(what, fenv)
            assign(what, value, fenv)
            lockBinding(what, fenv)
        }
    }
    if(exists(what, envir = where, inherits = FALSE) && bindingIsLocked(what, where)) {
      unlockBinding(what, where)
      assign(what, value, where)
      lockBinding(what, where)
    }
    else
      assign(what, value, where)
}

.setMethodOverBinding <- function(what, signature, method, where, verbose = TRUE) {
    if(verbose)
        warning(gettextf("setting a method over the binding of symbol %s in environment/package %s",
                         sQuote(what),
                         sQuote(getPackageName(where))),
                domain = NA)
    if(exists(what, envir = where, inherits = FALSE)) {
        fdef <- get(what, envir = where)
        hasFunction <- is(fdef, "genericFunction")
    }

        hasFunction <- FALSE
    if(hasFunction) {
        ## find the generic in the corresponding namespace
        where2 <- findFunction(what, where = environment(fdef))[[1L]] # must find it?
        unlockBinding(what, where)
        setMethod(what, signature, method, where = where)
        lockBinding(what, where)
        ## assign in the package namespace as well
        unlockBinding(what, where2)
        setMethod(what, signature, method, where = where2)
        lockBinding(what, where2)
    }
    else {
        setMethod(what, signature, method, where = where)
    }
}

.getImportsEnv <- function(pkg) {
    iname = paste0("imports:", pkg)
    empty = emptyenv()
    env = asNamespace(pkg)

    while(!identical(env, empty)) {
        if (identical(attr(env, "name"), iname))
            return(env)
        env = parent.env(env)
    }
    NULL
}

.updateInImportsEnv <- function(what, newFun, importingPkg) {
    where = .getImportsEnv(importingPkg)
    if (!is.null(where) && (what %in% names(where))) {
        .assignOverBinding(what, newFun, where, FALSE)
    }
}

### finding the package name for a loaded namespace
.searchNamespaceNames <- function(env)
    paste0("namespace:", getNamespaceName(env))

.findFunEnvAndName <- function(what, where, signature = NULL) {
    pname <- character()
    if(is.null(signature)) {
        whereF <- findFunction(what, where = where)
        if(length(whereF)>0)
            whereF <- whereF[[1L]]
        else return(list(pname = pname, whereF = baseenv()))
    } else
        whereF <- .genEnv(what, where)

    ## avoid partial matches to "names"
    if("name" %in% names(attributes(whereF)))
        pname <- gsub("^.*:", "", attr(whereF, "name"))
    else if(isNamespace(whereF))
        pname <- .searchNamespaceNames(whereF)
    list(pname = pname, whereF = whereF)
}

.makeTraceClass <- function(traceClassName, className, verbose = TRUE) {
  ## called because the traceClassName not a class
  ## first check whether it may exist but not in the same package
  if(isClass(as.character(traceClassName)))
    return(as.character(traceClassName))
  if(verbose)
    message(sprintf("Constructing traceable class %s", dQuote(traceClassName)),
            domain = NA)
  env <- .classEnv(className)
  if(environmentIsLocked(env)) {
    message(gettextf("Environment of class %s is locked; using global environment for new class",
                     dQuote(className)),
            domain = NA)
    env <- .GlobalEnv
    packageSlot(traceClassName) <- NULL
  }
  setClass(traceClassName,
                 contains = c(className, "traceable"), where = env)
  if(existsMethod("show", className, env)) # override it for traceClassName
    setMethod("show", traceClassName, .showTraceable)
  traceClassName
}


utils::globalVariables("fdef")
.dummySetMethod <- function(f, signature = character(), definition,
	     where = topenv(parent.frame()), valueClass = NULL,
	     sealed = FALSE)
{
    if(is.function(f) && is(f, "genericFunction"))
        f <- fdef@generic
    else if(is.function(f)) {
        if(is.primitive(f))
            f <- .primname(f)
        else
            stop("a function for argument 'f' must be a generic function")
    } else
        f <- switch(f, "as.double" = "as.numeric", f)
    assign(.dummyMethodName(f, signature), definition, envir = where)
}

.functionsOverriden <- c("setClass", "setClassUnion", "setGeneric", "setIs", "setMethod", "setValidity")

.setEnvForSource <- function(env) {
    doNothing <- function(x, ...)x
    ## establish some dummy definitions & a special setMethod()
    for(f in .functionsOverriden)
        assign(f, switch(f, setMethod = .dummySetMethod, doNothing),
               envir = env)
    env
}

.dummyMethodName <- function(f, signature)
    paste(c(f,signature), collapse="#")

.guessPackageName <- function(env) {
    allObjects <- names(env)
    allObjects <- allObjects[is.na(match(allObjects, .functionsOverriden))]
    ## counts of packaages containing objects; objects not found don't count
    possible <- sort(table(unlist(lapply(allObjects, utils::find))),
                     decreasing = TRUE)
##    message <- ""
    if(length(possible) == 0)
        stop("none of the objects in the source code could be found:  need to attach or specify the package")
    else if(length(possible) > 1L) {
        global <- match(".GlobalEnv", names(possible), 0)
        if(global > 0) {
            possible <- possible[-global] # even if it's the most common
        }
        if(length(possible) > 1L)
            warning(gettextf("objects found in multiple packages: using %s and ignoring %s",
                             sQuote(names(possible[[1L]])),
                             paste(sQuote(names(possible[-1L])),
                                   collapse = ", ")),
                    domain = NA)
    }
    .rmpkg(names(possible[1L])) # the package name, or .GlobalEnv
}

## extract the new definitions from the source file
evalSource <- function(source, package = "", lock = TRUE, cache = FALSE) {
    if(!nzchar(package))
        envp <- .GlobalEnv # will look for the package after evaluating source
    else {
        pstring <- paste0("package:",package)
        packageIsVisible <- pstring %in% search()
        if(packageIsVisible) {
            envp <- as.environment(pstring)
##            envns <- tryCatch(asNamespace(package), error = function(cond) NULL)
        }
        else {
            envp <- tryCatch(asNamespace(package), error = function(cond) NULL)
##            envns <- envp
        }
        if(is.null(envp))
            stop(gettextf("package %s is not attached and no namespace found for it",
                          sQuote(package)),
                 domain = NA)
    }
    env <- new("sourceEnvironment", new.env(parent = envp),
        packageName = package,
        sourceFile = (if(is.character(source)) source else ""))
    env$.packageName <- package # Fixme: should be done by an initialize method
    setCacheOnAssign(env, cache)
    if(is(source, "character"))
        for(text in source) sys.source(text, envir = env)
    else if(is(source, "connection")) sys.source(source, envir = env)
    else if(!is(source, "environment"))
        stop(gettextf("invalid 'source' argument: expected file names or a connection but got an object of class %s",
                      dQuote(class(source)[[1L]])),
             domain = NA)
    if(lock)
        lockEnvironment(env, bindings = TRUE) # no further changes allowed
    env
}

insertSource <- function(source, package = "",
                         functions = allPlainObjects(),
                         methods = (if(missing(functions)) allMethodTables() else NULL)
##                         ,classes = (if(missing(functions)) allClassDefs() else NULL)
                         , force = missing(functions) & missing(methods)
                     ){
    MPattern <- .TableMetaPattern()
    CPattern <- .ClassMetaPattern()
    allPlainObjects <- function()
        allObjects[!(grepl(MPattern, allObjects) | grepl(CPattern, allObjects) | ".cacheOnAssign" == allObjects)]
    allMethodTables <- function()
        allObjects[grepl(MPattern, allObjects)]
##    allClassDefs <- function()
##        allObjects[grepl(CPattern, allObjects)]
    differs <- function(f1, f2)
        !(identical(body(f1), body(f2)) && identical(args(f1), args(f2)))
    if(is.environment(source) && !nzchar(package)) {
        if(is(source, "sourceEnvironment"))
            package <- source@packageName
        else if(exists(".packageName", envir = source, inherits = FALSE))
            package <- get(".packageName", envir =source)
    }
    if(is(source, "environment"))
        env <- source
    else
        env <- evalSource(source, package, FALSE) # sourceEnvironment, unlocked
    envPackage <- getPackageName(env, FALSE)
    ## identify an environment and (if possible) namespace for the package
    envp <- parent.env(env)
    if(identical(envp, .GlobalEnv) || !nzchar(envPackage)) { # no package name in the eval, guess one
        if(!nzchar(package))
            package <- .guessPackageName(env) # use find() on objects in env
        if(identical(package, ".GlobalEnv"))
            envns <- NULL
        else {
            pname <- paste0("package:", package)
            envp <- tryCatch(as.environment(pname), error = function(cond)NULL)
            if(is.null(envp)) {
                envp <- tryCatch(as.environment(pname), error = function(cond)NULL)
                if(is.null(envp))
                    stop(gettextf(
                     "cannot find an environment corresponding to package name \'%s\"",
                     package), domain = NA)
            }
            envns <- tryCatch(asNamespace(package), error = function(cond)NULL)
        }
        if(nzchar(package))
            assign(".packageName", package, envir = env)
    }
    else {
        if(isNamespace(envp))
            envns <- envp
        else
            envns <- tryCatch(asNamespace(package), error = function(cond)NULL)
    }
    if(nzchar(envPackage) && envPackage != package)
        warning(gettextf("supplied package, %s, differs from package inferred from source, %s",
                         sQuote(package), sQuote(envPackage)),
                domain = NA)
    packageSlot(env) <- package
    ## at this point, envp is the target environment (package or other)
    ## and envns is the corresponding namespace if any, or NULL
    allObjects <- names(env)
    ## Figure out what to trace.
    if(!missing(functions)) {
        notThere <- is.na(match(functions, allObjects))
        if(any(notThere)) {
            warning(gettextf("cannot insert these (not found in source): %s",
                    paste0('"', functions[notThere], '"',
                           collapse = ", ")),
                    domain = NA)
        }
    }
    .mnames <- allMethodTables()
    if(length(methods) > 0) {
	notThere <- vapply(methods, function(fname)
	    length(grep(fname, .mnames, fixed = TRUE)) == 0, NA)
        if(any(notThere)) {
            warning(gettextf("cannot insert methods for these functions (methods table not found in source): %s",
                    paste0('"', methods[notThere], '"',
                           collapse = ", ")),
                    domain = NA)
            methods <- methods[!notThere]
        }
        methodNames <- vapply(methods, function(fname)
                              .mnames[[grep(fname, .mnames, fixed = TRUE)[[1]]]], "")
    }
    else {
        methodNames <- .mnames
        methods <- sub(.TableMetaPrefix(), "", methodNames)
        methods <- sub(":.*","",methods)
    }
    ## if(!missing(classes)) {
    ##     .mnames <- allMethodNames()
    ##     notThere <- sapply(classes,
    ##      function(fname) length(grep(fname, .mnames, fixed = TRUE) == 0)
    ##     )
    ##     if(any(notThere)) {
    ##         warning(gettextf("Can't insert these classes (class definition not found in source): %s",
    ##                 paste('"',classes[notThere],'"',
    ##                       sep = "", collapse = ", ")),
    ##                 domain = NA)
    ##         classes <- classes[!notThere]
    ##     }
    ## }
    notTraceable <- newObjects <- objectsDone <- character()
    for(i in seq_along(functions)) {
        this <- functions[[i]]
        thisWhere <- NULL
        if(is.null(envns) ||
           exists(this, envir = envp, inherits = FALSE)) {
            envwhere <- envp
            thisWhere <- get(this, envir = envp)
        }
        else {
            envwhere <- envns
            if(is.environment(envns)  &&
               exists(this, envir = envns, inherits = FALSE))
                thisWhere <- get(this, envir = envns)
        }
        thisObj <- get(this, envir = env)
        if(is.function(thisObj) && is.function(thisWhere)
           && differs(thisObj, thisWhere)) {
            suppressMessages(
               .TraceWithMethods(this, where = envwhere, edit = env))
            objectsDone <- c(objectsDone, this)
        }
        else if(force)
            assign(this, thisObj, envir = envwhere)
        else if(!is.function(thisObj))
            notTraceable <- c(notTraceable, this)
        else if(is.null(thisWhere))
            newObjects <- c(newObjects, this)
    }
    if(length(notTraceable) > 0)
        message(gettextf("Non-function objects are not currently inserted (not traceable): %s",
                         paste(notTraceable, collapse = ", ")), domain = NA)
    if(length(newObjects) > 0)
        message(gettextf("New functions are not currently inserted (not untraceable): %s",
                         paste(newObjects, collapse = ", ")), domain = NA)
    if(length(objectsDone) > 0)
        message(gettextf("Modified functions inserted through trace(): %s",
                         paste(objectsDone, collapse = ", ")), domain = NA)
    for(i in seq_along(methods)) {
        .copyMethods(methods[[i]], methodNames[[i]], env, envp)
    }
    ## for(class in classes) {
    ##     .copyClass(class, env, envwhere)
    ## }
    ## return the environment, after cleaning up the dummy functions and
    ## adding a time stamp, if the source was parssed on this call
    if(!is.environment(source)) {
        lockEnvironment(env, bindings = TRUE) # no further changes allowed
        invisible(env)
    }
    else
        invisible(source)
}

.copyMethods <- function(f, tableName, env, envwhere) {
    differs <- function(o1, o2)
        !(is.function(o2) && # o2 can be NULL
          identical(body(o2), body(o2)) && identical(args(o1), args(o2)))
    table <- get(tableName, envir=env)
    fdef <- getGeneric(f, where = envwhere)
    if(!is(fdef, "genericFunction")) {
        message(gettextf("%s() is not a generic function in the target environment -- methods will not be inserted",
                         f), domain = NA)
        return(NULL)
    }
    curTable <- getMethodsForDispatch(fdef)
    allObjects <- sort(names(table))
    if(length(allObjects) > 0) {
        methodsInserted <- as.character(Filter(function(this) {
            def <- get(this, envir = table)
            curdef <- curTable[[this]]
            if(differs(def, curdef)) {
                suppressMessages(
                   .TraceWithMethods(f, signature = this, where = envwhere,
                              edit = env))
                TRUE
            } else
                FALSE
        }, allObjects))
        if(length(methodsInserted) > 0)
            message(gettextf("Methods inserted for function %s(): %s",
                  f, paste(methodsInserted, collapse =", ")),
                  domain = NA)
    }
}

.copyClass <- function(class, env, envwhere) {
    message("Pretend we inserted class ", class, domain = NA)
}

.findNewDefForTrace <- function(what, signature, env, package) {
    if(is.null(signature)) {
        if(exists(what, envir = env, inherits = FALSE))
            newObject <- get(what, envir = env)
        else
            stop(gettextf("no definition for object %s found in tracing environment",
                          sQuote(what), source),
                 domain = NA)
    }
    else {
        ## we don't know the package for the generic (which may not
        ## be active), so we search for the string w/o package
        table <- .TableMetaName(what, "")
        allObjects <- sort(names(env))
        i <- grep(table, allObjects, fixed = TRUE)
        if(length(i) == 1)
            table <- env[[allObjects[[i]]]]
        else if(length(i) >1) {
            table <- allObjects[[i[[1]]]]
            warning(gettextf("multiple generics match pattern, using table %s", table)
                , domain = NA)
            table <- env[[table]]
        }
        else
            stop(gettextf("does not seem to be a method table for generic %s in tracing environment",
                          sQuote(what)),
                 domain = NA)
        if(exists(signature, envir = table, inherits = FALSE))
          newObject <- get(signature, envir = table)
        else
          stop(gettextf("no method in methods table for %s for signature %s",
                        sQuote(what),
                        sQuote(signature)),
               domain = NA)
    }
    newObject
}