#  File src/library/base/R/source.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2018 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/

source <-
function(file, local = FALSE, echo = verbose, print.eval = echo,
         exprs, spaced = use_file,
	 verbose = getOption("verbose"),
	 prompt.echo = getOption("prompt"),
	 max.deparse.length = 150, width.cutoff = 60L,
         deparseCtrl = "showAttributes", ## rather?  c("keepInteger", "showAttributes", "keepNA"),
         chdir = FALSE,
         encoding = getOption("encoding"),
         continue.echo = getOption("continue"),
         skip.echo = 0, keep.source = getOption("keep.source"))
{
    envir <- if (isTRUE(local)) parent.frame()
	     else if(isFALSE(local)) .GlobalEnv
	     else if (is.environment(local)) local
	     else stop("'local' must be TRUE, FALSE or an environment")
    if (!missing(echo)) {
	if (!is.logical(echo))
	    stop("'echo' must be logical")
	if (!echo && verbose) {
	    warning("'verbose' is TRUE, 'echo' not; ... coercing 'echo <- TRUE'")
	    echo <- TRUE
	}
    }
    if (verbose) {
	cat("'envir' chosen:")
	print(envir)
    }

    if(use_file <- missing(exprs)) {

        ofile <- file # for use with chdir = TRUE
        from_file <- FALSE # true, if not stdin() nor from srcref
        srcfile <- NULL
        if(is.character(file)) {
            have_encoding <- !missing(encoding) && encoding != "unknown"
            if(identical(encoding, "unknown")) {
                enc <- utils::localeToCharset()
                encoding <- enc[length(enc)]
            } else enc <- encoding
            if(length(enc) > 1L) {
                encoding <- NA
                owarn <- options(warn = 2)
                for(e in enc) {
                    if(is.na(e)) next
                    zz <- file(file, encoding = e)
                    res <- tryCatch(readLines(zz, warn = FALSE), error = identity)
                    close(zz)
                    if(!inherits(res, "error")) { encoding <- e; break }
                }
                options(owarn)
            }
            if(is.na(encoding))
                stop("unable to find a plausible encoding")
            if(verbose)
                cat(gettextf('encoding = "%s" chosen', encoding), "\n", sep = "")
            if(file == "") {
                file <- stdin()
                srcfile <- "<stdin>"
            } else {
                filename <- file
                file <- file(filename, "r", encoding = encoding)
                on.exit(close(file))
                if (isTRUE(keep.source)) {
                    lines <- readLines(file, warn = FALSE)
                    on.exit()
                    close(file)
                    srcfile <- srcfilecopy(filename, lines, file.mtime(filename)[1],
                                           isFile = TRUE)
                } else {
                    from_file <- TRUE
                    srcfile <- filename
                }

                ## We translated the file (possibly via a guess),
                ## so don't want to mark the strings.as from that encoding
                ## but we might know what we have encoded to, so
                loc <- utils::localeToCharset()[1L]
                encoding <- if(have_encoding)
                                switch(loc,
                                       "UTF-8" = "UTF-8",
                                       "ISO8859-1" = "latin1",
                                       "unknown")
                            else "unknown"
            }
        } else {
            lines <- readLines(file, warn = FALSE)
            srcfile <-
                if (isTRUE(keep.source))
                    srcfilecopy(deparse(substitute(file)), lines)
                else
                    deparse(substitute(file))
        }

        exprs <- if (!from_file) {
                     if (length(lines))  # there is a C-level test for this
                         .Internal(parse(stdin(), n = -1, lines, "?", srcfile, encoding))
                     else expression()
                 } else
                     .Internal(parse(file, n = -1, NULL, "?", srcfile, encoding))

        on.exit()
        if (from_file) close(file)

        if (verbose)
            cat("--> parsed", length(exprs), "expressions; now eval(.)ing them:\n")

        if (chdir){
            if(is.character(ofile)) {
                if(grepl("^(ftp|http|file)://", ofile)) ## is URL
                    warning("'chdir = TRUE' makes no sense for a URL")
                else if((path <- dirname(ofile)) != ".") {
                    owd <- getwd()
                    if(is.null(owd))
                        stop("cannot 'chdir' as current directory is unknown")
                    on.exit(setwd(owd), add=TRUE)
                    setwd(path)
                }
            } else {
                warning("'chdir = TRUE' makes no sense for a connection")
            }
        }

    } else { # 'exprs' specified: !use_file
	if(!missing(file)) stop("specify either 'file' or 'exprs' but not both")
	if(!is.expression(exprs))
	    exprs <- as.expression(exprs)
    }

    Ne <- length(exprs)
    if (echo) {
	## Reg.exps for string delimiter/ NO-string-del /
	## odd-number-of-str.del needed, when truncating below
	sd <- "\""
	nos <- "[^\"]*"
	oddsd <- paste0("^", nos, sd, "(", nos, sd, nos, sd, ")*", nos, "$")
        ## A helper function for echoing source.  This is simpler than the
        ## same-named one in Sweave
	trySrcLines <- function(srcfile, showfrom, showto) {
	    tryCatch(suppressWarnings(getSrcLines(srcfile, showfrom, showto)),
		     error = function(e) character())
	}
    }
    yy <- NULL
    lastshown <- 0
    srcrefs <- attr(exprs, "srcref")
    if(verbose && !is.null(srcrefs)) {
        cat("has srcrefs:\n"); utils::str(srcrefs) }
    for (i in seq_len(Ne+echo)) {
    	tail <- i > Ne
        if (!tail) {
	    if (verbose)
		cat("\n>>>> eval(expression_nr.", i, ")\n\t	 =================\n")
	    ei <- exprs[i]
	}
	if (echo) {
	    nd <- 0
	    srcref <- if(tail) attr(exprs, "wholeSrcref") else
		if(i <= length(srcrefs)) srcrefs[[i]] # else NULL
 	    if (!is.null(srcref)) {
	    	if (i == 1) lastshown <- min(skip.echo, srcref[3L]-1)
	    	if (lastshown < srcref[3L]) {
	    	    srcfile <- attr(srcref, "srcfile")
	    	    dep <- trySrcLines(srcfile, lastshown+1, srcref[3L])
	    	    if (length(dep)) {
			leading <- if(tail) length(dep) else srcref[1L]-lastshown
			lastshown <- srcref[3L]
			while (length(dep) && grepl("^[[:blank:]]*$", dep[1L])) {
			    dep <- dep[-1L]
			    leading <- leading - 1L
			}
			dep <- paste0(rep.int(c(prompt.echo, continue.echo),
					      c(leading, length(dep)-leading)),
				      dep, collapse="\n")
			nd <- nchar(dep, "c")
		    } else
		    	srcref <- NULL  # Give up and deparse
	    	}
	    }
	    if (is.null(srcref)) {
	    	if (!tail) {
		    # Deparse.  Must drop "expression(...)"
		    dep <- substr(paste(deparse(ei, width.cutoff = width.cutoff,
						control = deparseCtrl),
					collapse = "\n"), 12L, 1e+06L)
		    dep <- paste0(prompt.echo,
				  gsub("\n", paste0("\n", continue.echo), dep))
		    ## We really do want chars here as \n\t may be embedded.
		    nd <- nchar(dep, "c") - 1L
		}
	    }
	    if (nd) {
		do.trunc <- nd > max.deparse.length
		dep <- substr(dep, 1L, if (do.trunc) max.deparse.length else nd)
		cat(if (spaced) "\n", dep, if (do.trunc)
		    paste(if (grepl(sd, dep) && grepl(oddsd, dep))
			  " ...\" ..." else " ....", "[TRUNCATED] "),
		    "\n", sep = "")
	    }
	}
	if (!tail) {
	    yy <- withVisible(eval(ei, envir))
	    i.symbol <- mode(ei[[1L]]) == "name"
	    if (!i.symbol) {
		## ei[[1L]] : the function "<-" or other
		curr.fun <- ei[[1L]][[1L]]
		if (verbose) {
		    cat("curr.fun:")
		    utils::str(curr.fun)
		}
	    }
	    if (verbose >= 2) {
		cat(".... mode(ei[[1L]])=", mode(ei[[1L]]), "; paste(curr.fun)=")
		utils::str(paste(curr.fun))
	    }
	    if (print.eval && yy$visible) {
		if(isS4(yy$value))
		    methods::show(yy$value)
		else
		    print(yy$value)
	    }
	    if (verbose)
		cat(" .. after ", sQuote(deparse(ei, control =
					  unique(c(deparseCtrl, "useSource")))),
		    "\n", sep = "")
 	}
    }
    invisible(yy)
}

sys.source <-
function(file, envir = baseenv(), chdir = FALSE,
	 keep.source = getOption("keep.source.pkgs"),
	 keep.parse.data = getOption("keep.parse.data.pkgs"),
	 toplevel.env = as.environment(envir))
{
    if(!(is.character(file) && file.exists(file)))
	stop(gettextf("'%s' is not an existing file", file))
    keep.source <- as.logical(keep.source)
    keep.parse.data <- as.logical(keep.parse.data)
    oop <- options(keep.source = keep.source,
                   keep.parse.data = keep.parse.data,
                   topLevelEnvironment = toplevel.env)
    on.exit(options(oop))
    if (keep.source) {
    	lines <- readLines(file, warn = FALSE)
    	srcfile <- srcfilecopy(file, lines, file.mtime(file), isFile = TRUE)
    	exprs <- parse(text = lines, srcfile = srcfile, keep.source = TRUE)
    } else
    	exprs <- parse(n = -1, file = file, srcfile = NULL, keep.source = FALSE)
    if (length(exprs) == 0L)
	return(invisible())
    if (chdir && (path <- dirname(file)) != ".") {
	owd <- getwd()
        if(is.null(owd))
            stop("cannot 'chdir' as current directory is unknown")
	on.exit(setwd(owd), add = TRUE)
	setwd(path)
    }
    for (i in seq_along(exprs)) eval(exprs[i], envir)
    invisible()
}

withAutoprint <- function(exprs, evaluated = FALSE, local = parent.frame(),
                          print. = TRUE, echo = TRUE, max.deparse.length = Inf,
                          width.cutoff = max(20, getOption("width")),
                          deparseCtrl = c("keepInteger", "showAttributes", "keepNA"),
                          ...)
{
    if(!evaluated) {
	exprs <- substitute(exprs)
	if(is.call(exprs)) {
	    if(exprs[[1]] == quote(`{`))
		exprs <- as.list(exprs[-1])
	    ## else: use that call
	} ## else can be 'symbol' or e.g. numeric constant
    }
    source(exprs = exprs, local = local, print.eval = print., echo = echo,
           max.deparse.length = max.deparse.length, width.cutoff = width.cutoff,
	   deparseCtrl = deparseCtrl, ...)
}