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

RweaveLatex <- function()
{
    list(setup = RweaveLatexSetup,
         runcode = RweaveLatexRuncode,
         writedoc = RweaveLatexWritedoc,
         finish = RweaveLatexFinish,
         checkopts = RweaveLatexOptions)
}

## We definitely do not want '.' in here, to avoid misidentification
## of file extensions.  Note that - is used literally here.
.SweaveValidFilenameRegexp <- "^[[:alnum:]/#+_-]+$"

RweaveLatexSetup <-
    function(file, syntax, output = NULL, quiet = FALSE, debug = FALSE,
             stylepath, ...)
{
    dots <- list(...)
    if (is.null(output)) {
        prefix.string <- basename(sub(syntax$extension, "", file))
        output <- paste0(prefix.string, ".tex")
    } else prefix.string <- basename(sub("\\.tex$", "", output))

    if (!quiet) cat("Writing to file ", output, "\n",
                   "Processing code chunks with options ...\n", sep = "")
    encoding <- attr(file, "encoding")
    if (encoding %in% c("ASCII", "bytes")) encoding <- ""
    output <- file(output, open = "w", encoding = encoding)

    if (missing(stylepath)) {
        p <- Sys.getenv("SWEAVE_STYLEPATH_DEFAULT")
        stylepath <-
            if (length(p) >= 1L && nzchar(p[1L])) identical(p, "TRUE") else FALSE
    }
    if (stylepath) {
        styfile <- file.path(R.home("share"), "texmf", "tex", "latex", "Sweave")
        if (.Platform$OS.type == "windows")
            styfile <- chartr("\\", "/", styfile)
        if (length(grep(" ", styfile)))
            warning(gettextf("path to %s contains spaces,\n", sQuote(styfile)),
                    gettext("this may cause problems when running LaTeX"),
                    domain = NA)
    } else styfile <- "Sweave"

    options <- list(prefix = TRUE, prefix.string = prefix.string,
                    engine = "R", print = FALSE, eval = TRUE, fig = FALSE,
                    pdf = TRUE, eps = FALSE, png = FALSE, jpeg = FALSE,
                    grdevice = "", width = 6, height = 6, resolution = 300,
                    term = TRUE, echo = TRUE, keep.source = TRUE,
                    results = "verbatim",
                    split = FALSE, strip.white = TRUE, include = TRUE,
                    pdf.version = grDevices::pdf.options()$version,
                    pdf.encoding = grDevices::pdf.options()$encoding,
                    pdf.compress = grDevices::pdf.options()$compress,
                    expand = TRUE, # unused by us, for 'highlight'
                    concordance = FALSE, figs.only = TRUE,
                    ignore.on.weave = FALSE, ignore = FALSE)
    options$.defaults <- options
    if (!is.null(dots$weave))
        dots$ignore.on.weave <- !dots$weave
    options[names(dots)] <- dots

    ## to be on the safe side: see if defaults pass the check
    options <- RweaveLatexOptions(options)

    list(output = output, styfile = styfile, havesty = FALSE,
         haveconcordance = FALSE, debug = debug, quiet = quiet,
         syntax = syntax, options = options,
         chunkout = list(), # a list of open connections
         srclines = integer())
}

makeRweaveLatexCodeRunner <- function(evalFunc = RweaveEvalWithOpt)
{
    ## Return a function suitable as the 'runcode' element
    ## of an Sweave driver.  evalFunc will be used for the
    ## actual evaluation of chunk code.
    ## FIXME: well, actually not for the figures.
    ## If there were just one figure option set, we could eval the chunk
    ## only once.
    function(object, chunk, options) {
        pdf.Swd <- function(name, width, height, ...)
            grDevices::pdf(file = paste0(chunkprefix, ".pdf"),
                           width = width, height = height,
                           version = options$pdf.version,
                           encoding = options$pdf.encoding,
                           compress = options$pdf.compress)
        eps.Swd <- function(name, width, height, ...)
            grDevices::postscript(file = paste0(name, ".eps"),
                                  width = width, height = height,
                                  paper = "special", horizontal = FALSE)
        png.Swd <- function(name, width, height, options, ...)
            grDevices::png(filename = paste0(chunkprefix, ".png"),
                           width = width, height = height,
                           res = options$resolution, units = "in")
        jpeg.Swd <- function(name, width, height, options, ...)
            grDevices::jpeg(filename = paste0(chunkprefix, ".jpeg"),
                            width = width, height = height,
                            res = options$resolution, units = "in")

        ## Just return the object if the chunk is omitted, or for
        ## engines other than R and S.
        if (!is.null(options$weave))
            options$ignore.on.weave <- !options$weave
        if (options$ignore.on.weave || options$ignore ||
            !(options$engine %in% c("R", "S")))
            return(object)

        devs <- devoffs <- list()
        if (options$fig && options$eval) {
            if (options$pdf) {
                devs <- c(devs, list(pdf.Swd))
                devoffs <- c(devoffs, list(grDevices::dev.off))
            }
            if (options$eps) {
                devs <- c(devs, list(eps.Swd))
                devoffs <- c(devoffs, list(grDevices::dev.off))
            }
            if (options$png) {
                devs <- c(devs, list(png.Swd))
                devoffs <- c(devoffs, list(grDevices::dev.off))
            }
            if (options$jpeg) {
                devs <- c(devs, list(jpeg.Swd))
                devoffs <- c(devoffs, list(grDevices::dev.off))
            }
            if(nzchar(grd <- options$grdevice)) {
                grdo <- paste0(grd, ".off")
                if(grepl("::", grd, fixed = TRUE)) {
                    devs <- c(devs, eval(str2expression(grd)))
                    devoffs <-
                        c(devoffs,
                          if(!inherits(grdo <- tryCatch(eval(str2expression(grdo)), error = identity),
                                       "error"))
                              list(grdo)
                          else
                              list(grDevices::dev.off))
                } else {
                    devs <- c(devs, list(get(grd, envir = .GlobalEnv)))
                    devoffs <-
                        c(devoffs,
                          if(exists(grdo, envir = .GlobalEnv))
                              list(get(grdo, envir = .GlobalEnv))
                          else
                              list(grDevices::dev.off))
                }
            }
        }
        if (!object$quiet) {
            cat(formatC(options$chunknr, width = 2), ":")
            if (options$echo) cat(" echo")
            if (options$keep.source) cat(" keep.source")
            if (options$eval) {
                if (options$print) cat(" print")
                if (options$term) cat(" term")
                cat("", options$results)
                if (options$fig) {
                    if (options$eps) cat(" eps")
                    if (options$pdf) cat(" pdf")
                    if (options$png) cat(" png")
                    if (options$jpeg) cat(" jpeg")
                    if (!is.null(options$grdevice)) cat("", options$grdevice)
                }
            }
            cat(" (")
            if (!is.null(options$label))
                cat("label = ", options$label, ", ", sep = "")
            filenum <- attr(chunk, "srcFilenum")[1]
            filename <- attr(chunk, "srcFilenames")[filenum]
            cat(basename(filename), ":", attr(chunk, "srclines")[1], ")", sep = "")
            cat("\n")
        }

        chunkprefix <- RweaveChunkPrefix(options)

        if (options$split) {
            ## [x][[1L]] avoids partial matching of x
            chunkout <- object$chunkout[chunkprefix][[1L]]
            if (is.null(chunkout)) {
                chunkout <- file(paste0(chunkprefix, ".tex"), "w")
                if (!is.null(options$label))
                    object$chunkout[[chunkprefix]] <- chunkout
                if(!grepl(.SweaveValidFilenameRegexp, chunkout))
                    warning("file stem ", sQuote(chunkout), " is not portable",
                            call. = FALSE, domain = NA)
            }
        } else chunkout <- object$output

        srcfile <- srcfilecopy(object$filename, chunk, isFile = TRUE)

        ## Note that we edit the error message below, so change both
        ## if you change this line:
        chunkexps <- try(parse(text = chunk, srcfile = srcfile), silent = TRUE)
        if (inherits(chunkexps, "try-error"))
            chunkexps[1L] <- sub(" parse(text = chunk, srcfile = srcfile) : \n ",
                                 "", chunkexps[1L], fixed = TRUE)

        RweaveTryStop(chunkexps, options)

        ## Some worker functions used below...
        putSinput <- function(dce, leading) {
            if (!openSinput) {
                if (!openSchunk) {
                    cat("\\begin{Schunk}\n", file = chunkout)
                    linesout[thisline + 1L] <<- srcline
                    filenumout[thisline + 1L] <<- srcfilenum
                    thisline <<- thisline + 1L
                    openSchunk <<- TRUE
                }
                cat("\\begin{Sinput}", file = chunkout)
                openSinput <<- TRUE
            }
            leading <- max(leading, 1L) # safety check
            cat("\n", paste0(getOption("prompt"), dce[seq_len(leading)],
                             collapse = "\n"),
                file = chunkout, sep = "")
            if (length(dce) > leading)
                cat("\n", paste0(getOption("continue"), dce[-seq_len(leading)],
                                 collapse = "\n"),
                    file = chunkout, sep = "")
            linesout[thisline + seq_along(dce)] <<- srcline
            filenumout[thisline + seq_along(dce)] <<- srcfilenum
            thisline <<- thisline + length(dce)
        }

        trySrcLines <- function(srcfile, showfrom, showto, ce) {
	    tryCatch(suppressWarnings(getSrcLines(srcfile, showfrom, showto)),
                     error = function(e) {
                         if (is.null(ce)) character()
                         else deparse(ce, width.cutoff = 0.75*getOption("width"))
                     })
        }

        echoComments <- function(showto) {
            if (options$echo && !is.na(lastshown) && lastshown < showto) {
                dce <- trySrcLines(srcfile, lastshown + 1L, showto, NULL)
                linedirs <- startsWith(dce, "#line ")
		dce <- dce[!linedirs]
		if (length(dce))
                    putSinput(dce, length(dce)) # These are all trailing comments
                lastshown <<- showto
            }
        }

        openSinput <- FALSE
        openSchunk <- FALSE

        srclines <- attr(chunk, "srclines")
        srcfilenums <- attr(chunk, "srcFilenum")
        linesout <- integer()      # maintains concordance
        filenumout <- integer()	   # ditto
        srcline <- srclines[1L]    # current input line
        srcfilenum <- srcfilenums[1L] # from this file
        thisline <- 0L             # current output line
        lastshown <- 0L            # last line already displayed;

##        refline <- NA    # line containing the current named chunk ref
        leading <- 1L    # How many lines get the user prompt

        srcrefs <- attr(chunkexps, "srcref")

        if (length(devs)) {
            if(!grepl(.SweaveValidFilenameRegexp, chunkprefix))
                warning("file stem ", sQuote(chunkprefix), " is not portable",
                        call. = FALSE, domain = NA)
            if (options$figs.only)
                devs[[1L]](name = chunkprefix,
                           width = options$width, height = options$height,
                           options)
        }
        SweaveHooks(options, run = TRUE)

        for (nce in seq_along(chunkexps)) {
            ce <- chunkexps[[nce]]
            if (options$keep.source && nce <= length(srcrefs) &&
                !is.null(srcref <- srcrefs[[nce]])) {
                showfrom <- srcref[7L]
                showto <- srcref[8L]

                dce <- trySrcLines(srcfile, lastshown+1L, showto, ce)
                leading <- showfrom - lastshown

                lastshown <- showto
                srcline <- srcref[3L]

                linedirs <- startsWith(dce, "#line ")
                dce <- dce[!linedirs]
                # Need to reduce leading lines if some were just removed
                leading <- leading - sum(linedirs[seq_len(leading)])

                while (length(dce) && length(grep("^[[:blank:]]*$", dce[1L]))) {
                    dce <- dce[-1L]
                    leading <- leading - 1L
                }
            } else {
                dce <- deparse(ce, width.cutoff = 0.75*getOption("width"))
                leading <- 1L
            }
            if (object$debug)
                cat("\nRnw> ", paste(dce, collapse = "\n+  "),"\n")

            if (options$echo && length(dce)) putSinput(dce, leading)

            ## avoid the limitations (and overhead) of output text connections
            if (options$eval) {
                tmpcon <- file()
                sink(file = tmpcon)
                err <- tryCatch(evalFunc(ce, options), finally = {
                     cat("\n")           # make sure final line is complete
                     sink()
                })
                output <- readLines(tmpcon)
                close(tmpcon)
                ## delete empty output
                if (length(output) == 1L && !nzchar(output[1L])) output <- NULL
                RweaveTryStop(err, options)
            } else output <- NULL

            ## or writeLines(output)
            if (length(output) && object$debug)
                cat(paste(output, collapse = "\n"))

            if (length(output) && (options$results != "hide")) {
                if (openSinput) {
                    cat("\n\\end{Sinput}\n", file = chunkout)
                    linesout[thisline + 1L:2L] <- srcline
                    filenumout[thisline + 1L:2L] <- srcfilenum
                    thisline <- thisline + 2L
                    openSinput <- FALSE
                }
                if (options$results == "verbatim") {
                    if (!openSchunk) {
                        cat("\\begin{Schunk}\n", file = chunkout)
                        linesout[thisline + 1L] <- srcline
                        filenumout[thisline + 1L] <- srcfilenum
                        thisline <- thisline + 1L
                        openSchunk <- TRUE
                    }
                    cat("\\begin{Soutput}\n", file = chunkout)
                    linesout[thisline + 1L] <- srcline
                    filenumout[thisline + 1L] <- srcfilenum
                    thisline <- thisline + 1L
                }

                output <- paste(output, collapse = "\n")
                if (!isFALSE(options$strip.white)) {
                    output <- sub("^[[:space:]]*\n", "", output)
                    output <- sub("\n[[:space:]]*$", "", output)
                    if (options$strip.white == "all")
                        output <- sub("\n[[:space:]]*\n", "\n", output)
                }
                cat(output, file = chunkout)
                count <- sum(strsplit(output, NULL)[[1L]] == "\n")
                if (count > 0L) {
                    linesout[thisline + 1L:count] <- srcline
                    filenumout[thisline + 1L:count] <- srcfilenum
                    thisline <- thisline + count
                }

                remove(output)

                if (options$results == "verbatim") {
                    cat("\n\\end{Soutput}\n", file = chunkout)
                    linesout[thisline + 1L:2L] <- srcline
                    filenumout[thisline + 1L:2L] <- srcfilenum
                    thisline <- thisline + 2L
                }
            }
        } # end of loop over chunkexps.

        ## Echo remaining comments if necessary
        if (options$keep.source) echoComments(length(srcfile$lines))

        if (openSinput) {
            cat("\n\\end{Sinput}\n", file = chunkout)
            linesout[thisline + 1L:2L] <- srcline
            filenumout[thisline + 1L:2L] <- srcfilenum
            thisline <- thisline + 2L
        }

        if (openSchunk) {
            cat("\\end{Schunk}\n", file = chunkout)
            linesout[thisline + 1L] <- srcline
            filenumout[thisline + 1L] <- srcfilenum
            thisline <- thisline + 1L
        }

        if (is.null(options$label) && options$split) close(chunkout)

        if (options$split && options$include) {
            cat("\\input{", chunkprefix, "}\n", sep = "", file = object$output)
            linesout[thisline + 1L] <- srcline
            filenumout[thisline + 1L] <- srcfilenum
            thisline <- thisline + 1L
        }

        if (length(devs)) {
            if (options$figs.only) devoffs[[1L]]()
            for (i in seq_along(devs)) {
                if (options$figs.only && i == 1) next
                devs[[i]](name = chunkprefix, width = options$width,
                          height = options$height, options)
                err <- tryCatch({
                    SweaveHooks(options, run = TRUE)
                    eval(chunkexps, envir = .GlobalEnv)
                }, error = function(e) {
                    devoffs[[i]]()
                    stop(conditionMessage(e), call. = FALSE, domain = NA)
                })
                devoffs[[i]]()
            }

            if (options$include) {
                cat("\\includegraphics{", chunkprefix, "}\n", sep = "",
                    file = object$output)
                linesout[thisline + 1L] <- srcline
                filenumout[thisline + 1L] <- srcfilenum
                thisline <- thisline + 1L
            }
        }
        object$linesout <- c(object$linesout, linesout)
        object$filenumout <- c(object$filenumout, filenumout)
        object
    }
}

RweaveLatexRuncode <- makeRweaveLatexCodeRunner()

RweaveLatexWritedoc <- function(object, chunk)
{
    linesout <- attr(chunk, "srclines")
    filenumout <- attr(chunk, "srcFilenum")

    if (length(grep("\\usepackage[^\\}]*Sweave.*\\}", chunk)))
        object$havesty <- TRUE

    if (!object$havesty) {
 	begindoc <- "^[[:space:]]*\\\\begin\\{document\\}"
 	which <- grep(begindoc, chunk)
 	if (length(which)) {
            chunk[which] <- sub(begindoc,
                                paste0("\\\\usepackage{",
                                       object$styfile,
                                       "}\n\\\\begin{document}"),
                                chunk[which])
            idx <- c(1L:which, which, seq.int(from = which+1L,
                     length.out = length(linesout)-which))
            linesout <- linesout[idx]
            filenumout <- filenumout[idx]
            object$havesty <- TRUE
        }
    }

    while(length(pos <- grep(object$syntax$docexpr, chunk)))
    {
        cmdloc <- regexpr(object$syntax$docexpr, chunk[pos[1L]])
        cmd <- substr(chunk[pos[1L]], cmdloc,
                      cmdloc + attr(cmdloc, "match.length") - 1L)
        cmd <- sub(object$syntax$docexpr, "\\1", cmd)
        if (object$options$eval) {
            val <- tryCatch(as.character(eval(str2expression(cmd), envir = .GlobalEnv)),
		    error = function(e) {
	               filenum <- attr(chunk, "srcFilenum")[pos[1L]]
                       filename <- attr(chunk, "srcFilenames")[filenum]
                       location <- paste0(basename(filename), ":", attr(chunk, "srclines")[pos[1L]])
		       stop("at ",location, ", ", conditionMessage(e), domain = NA, call. = FALSE)
		   })
            ## protect against character(), because sub() will fail
            if (length(val) == 0L) val <- ""
        }
        else val <- paste0("\\\\verb#<<", cmd, ">>#")
        ## it's always debatable what \verb delim-character to use;
        ## originally had '{' but that really can mess up LaTeX

        chunk[pos[1L]] <- sub(object$syntax$docexpr, val, chunk[pos[1L]])
    }

    ## Process \SweaveOpts{} or similar
    ## Since they are only supposed to affect code chunks, it is OK
    ## to process all such in a doc chunk at once.
    while(length(pos <- grep(object$syntax$docopt, chunk)))
    {
        opts <- sub(paste0(".*", object$syntax$docopt, ".*"),
                    "\\1", chunk[pos[1L]])
        object$options <- SweaveParseOptions(opts, object$options,
                                             RweaveLatexOptions)

        if (isTRUE(object$options$concordance)
            && !object$haveconcordance) {
            savelabel <- object$options$label
            object$options$label <- "concordance"
            prefix <- RweaveChunkPrefix(object$options)
            object$options$label <- savelabel
            object$concordfile <- paste0(prefix, ".tex")
            chunk[pos[1L]] <- sub(object$syntax$docopt,
                                  paste0("\\\\input{", prefix, "}"),
                                  chunk[pos[1L]])
            object$haveconcordance <- TRUE
        } else
            chunk[pos[1L]] <- sub(object$syntax$docopt, "", chunk[pos[1L]])
    }

    cat(chunk, sep = "\n", file = object$output)
    object$linesout <- c(object$linesout, linesout)
    object$filenumout <- c(object$filenumout, filenumout)

    object
}

RweaveLatexFinish <- function(object, error = FALSE)
{
    outputname <- summary(object$output)$description
    if (!object$quiet && !error) {
	if(!file.exists(outputname))
	    stop(gettextf("the output file '%s' has disappeared", outputname))
	cat("\n",
	    sprintf("You can now run (pdf)latex on %s", sQuote(outputname)),
	    "\n", sep = "")
    }
    close(object$output)
    if (length(object$chunkout))
        for (con in object$chunkout) close(con)
    if (object$haveconcordance) {
        concordance <- list(srcLine = object$linesout,
                            srcFile = object$srcFilenames[object$filenumout],
        	            offset = 0)
        class(concordance) <- "Rconcordance"
        if (!is.null(concordance$srcFile)) { # Might be NULL if an error occurred
	    concordance <- as.character(concordance, targetfile = outputname)
	    for (i in seq_along(concordance)) {
	        special <- paste0("\\Sconcordance{",
		                  paste(strwrap(concordance[i]),
		                        collapse = " %\n"),
		                  "}\n")
		cat(special, file = object$concordfile, append = (i > 1L))
	    }
	}
    }
    invisible(outputname)
}

## This is the check function for the RweaveLatex driver (only).
## Logical and numerical options may take their values from objects
## defined in earlier code chunks.
RweaveLatexOptions <- function(options)
{
    defaults <- options[[".defaults"]]

    ## get the (logical) value of a variable, or convert a character
    ## string to logical
    c2l <- function(x)
        if (is.logical(x))
            x
        else if (is.null(x))
            FALSE
        else
            suppressWarnings(as.logical(get0(x, mode = "logical") %||% x))

    ## get the (numeric) value of a variable, or convert a character
    ## string to numeric
    c2n <- function(x)
        if (is.numeric(x))
            x
        else
            suppressWarnings(as.numeric(get0(x, mode = "numeric") %||% x))

    ## numeric
    NUMOPTS <- c("width", "height", "resolution")

    ## character: largely for safety, but 'label' matters as there
    ## is no default (and someone uses "F"); 'strip.white' also
    ## accepts logicals, but is treated separately
    CHAROPTS <- c("results", "prefix.string", "engine", "label",
                  "strip.white", "pdf.version", "pdf.encoding", "grdevice")

    for (opt in names(options)) {
        if(opt == ".defaults") next
        oldval <- options[[opt]]
        defval <- defaults[[opt]]
        if(opt %in% CHAROPTS || is.character(defval)) {
        } else if(is.logical(defval)) {
            if(!is.logical(oldval)) options[[opt]] <- c2l(oldval)
        } else if(opt %in% NUMOPTS || is.numeric(defval)) {
            if(!is.numeric(oldval)) options[[opt]] <- c2n(oldval)
        } else if(!is.na(newval <- c2l(oldval)))
            options[[opt]] <- newval
        else if(!is.na(newval <- c2n(oldval)))
            options[[opt]] <- newval
        if (is.na(options[[opt]]))
            stop(gettextf("invalid value for %s : %s", sQuote(opt), oldval),
                 domain = NA)
    }

    if (!is.null(options$results)) {
        res <- as.character(options$results)
        if(tolower(res) != res) # documented as lower-case
            warning("value of option 'results' should be lowercase",
                    call. = FALSE)
        options$results <- tolower(res)
    }
    options$results <- match.arg(options$results, c("verbatim", "tex", "hide"))

    ## 'strip.white' admits TRUE (default), FALSE, "all" (with partial
    ## matching), and "true" and "false" (with partial matching) for
    ## backward compatibility
    options$strip.white <-
        if (is.null(options$strip.white))
            TRUE
        else if (!is.na(newval <- suppressWarnings(as.logical(options$strip.white))))
            newval
        else {
            res <- as.character(options$strip.white)
            if(tolower(res) != res)
                warning("value of option 'strip.white' should be lowercase",
                        call. = FALSE)
            res <- match.arg(tolower(res), c("true", "false", "all"))
            if (res != "all") as.logical(res) else res
        }

    options
}

RweaveChunkPrefix <- function(options)
{
    if (!is.null(options$label)) {
	if (options$prefix)
	    paste0(options$prefix.string, "-", options$label)
	else
	    options$label
    } else
	paste0(options$prefix.string, "-",
	       formatC(options$chunknr, flag = "0", width = 3))
}

RweaveEvalWithOpt <- function (expr, options)
{
    if (options$eval) {
	## Note: try() as opposed to tryCatch() for back compatibility;
	##       and  RweaveTryStop()  will work with it
        res <- try(withVisible(eval(expr, .GlobalEnv)), silent = TRUE)
        if (inherits(res, "try-error")) return(res)
        if (options$print || (options$term && res$visible)) {
            if (.isMethodsDispatchOn() && isS4(res$value))
                methods::show(res$value) else print(res$value)
        }
    }
    res
}

RweaveTryStop <- function(err, options)
{
    if (inherits(err, "try-error")) { ## from  RweaveEvalWithOpt()
        cat("\n")
        msg <- paste(" chunk", options$chunknr)
        if (!is.null(options$label))
            msg <- paste0(msg, " (label = ", options$label, ")")
        msg <- paste(msg, "\n")
        stop(msg, err, call. = FALSE)
    }
}

###------------------------------------------------------------------------

Rtangle <-  function()
{
    list(setup = RtangleSetup,
         runcode = RtangleRuncode,
         writedoc = RtangleWritedoc,
         finish = RtangleFinish,
         checkopts = RtangleOptions)
}


RtangleSetup <-
    function(file, syntax, output = NULL, annotate = TRUE, split = FALSE,
             quiet = FALSE, drop.evalFALSE = FALSE, chunk.sep = "\n\n", ...)
{
    dots <- list(...)
    if (is.null(output)) {
        prefix.string <- basename(sub(syntax$extension, "", file))
        ## This is odd, since for split = TRUE it uses the engine name.
        output <- paste0(prefix.string, ".R")
    } else
        prefix.string <- basename(sub("\\.[rsRS]$", "", output))

    if (!split) {
        if (identical(output, "stdout")) output <- stdout()
        else if (identical(output, "stderr")) output <- stderr()
        else {
            if (!quiet) cat("Writing to file", output, "\n")
            encoding <- attr(file, "encoding")
            if (encoding %in% c("ASCII", "bytes")) encoding <- ""
            output <- file(output, open = "w", encoding = encoding)
        }
        lines <- c(paste("###",
                         sprintf("R code from vignette source '%s'",
                                 file)),
                   "")
        writeLines(lines, output)
    } else {
        if (!quiet) cat("Writing chunks to files ...\n")
        output <- NULL
    }

    options <- list(split = split, prefix = TRUE,
                    prefix.string = prefix.string,
                    engine = "R", eval = TRUE,
                    show.line.nos = FALSE,
                    chunk.sep = if (isTRUE(chunk.sep)) "\n\n" else chunk.sep,
                    extension = TRUE, ignore.on.tangle = FALSE, ignore = FALSE)
    options$.defaults <- options
    if (!is.null(dots$tangle))
        dots$ignore.on.tangle <- !dots$tangle
    options[names(dots)] <- dots

    ## to be on the safe side: see if defaults pass the check
    options <- RtangleOptions(options)

    list(output = output, annotate = annotate, options = options,
         chunkout = list(), quiet = quiet, syntax = syntax,
         drop.evalFALSE = drop.evalFALSE)
}

.RtangleCodeLabel <- function(chunk) {
    if(length(lnos <- grep("^#line ", chunk, value = TRUE))) {
        srclines <- attr(chunk, "srclines")
        ## srcfilenum <- attr(chunk, "srcFilenum")
        ## this currently includes the chunk header
        lno <- if (length(srclines))
                   paste(min(srclines), max(srclines), sep = "-")
               else srclines
        fn <- sub('[^"]*"([^"]+).*', "\\1", lnos[1L])
        paste(fn, lno, sep = ":")
    } else
        "(missing #line/file info)"
}

RtangleRuncode <- function(object, chunk, options)
{
    ## Just return the object if the chunk is omitted, or for
    ## engines other than R and S.
    if (!is.null(options$tangle))
        options$ignore.on.tangle <- !options$tangle
    if (options$ignore.on.tangle || options$ignore ||
        !(options$engine %in% c("R", "S")))
        return(object)

    chunkprefix <- RweaveChunkPrefix(options)

    if (options$split) {
        if(!grepl(.SweaveValidFilenameRegexp, chunkprefix))
            warning("file stem ", sQuote(chunkprefix), " is not portable",
                    call. = FALSE, domain = NA)
        ## Use the engine as default extension.
        if (isTRUE(options$extension))
            options$extension <- options$engine
        ## Use an extension for the filename unless the option
        ## 'extension' is FALSE.
        ext <- if (!isFALSE(options$extension)) paste0(".", options$extension)
        outfile <- paste0(chunkprefix, ext)
        if (!object$quiet) cat(options$chunknr, ":", outfile,"\n")
        ## Use 'outfile' (instead of 'chunkprefix') for the name of
        ## the list element to avoid clashes in the case where chunks
        ## share the same label, but with different extensions.
        ## [x][[1L]] avoids partial matching of x.
        chunkout <- object$chunkout[outfile][[1L]]
        if (is.null(chunkout)) {
            chunkout <- file(outfile, "w")
            if (!is.null(options$label))
                object$chunkout[[outfile]] <- chunkout # see above
        }
    } else
        chunkout <- object$output

    showOut <- options$eval || !object$drop.evalFALSE
    if(showOut) {
        ## First print the chunk separator if the current connection
        ## object is not used for the first time (it has an attribute)
        ## and option 'chunk.sep' is not FALSE.
        if (!is.null(attr(chunkout, "not.first")) && !isFALSE(options$chunk.sep))
            cat(options$chunk.sep, file = chunkout)
        annotate <- object$annotate
        if (is.logical(annotate) && annotate) {
            cat("###################################################\n",
                "### code chunk number ", options$chunknr, ": ",
                options$label %||% .RtangleCodeLabel(chunk),
                if(!options$eval) " (eval = FALSE)", "\n",
                "###################################################\n",
                file = chunkout, sep = "")
        } else if(is.function(annotate))
            annotate(options, chunk = chunk, output = chunkout)
    }

    ## The next returns a character vector of the logical options
    ## which are true and have hooks set.
    hooks <- SweaveHooks(options, run = FALSE)
    for (k in hooks)
        cat("getOption(\"SweaveHooks\")[[\"", k, "\"]]()\n",
            file = chunkout, sep = "")

    if(showOut) {
        if (!options$show.line.nos) # drop "#line ...." lines
            chunk <- grep("^#line ", chunk, value = TRUE, invert = TRUE)
        if (!options$eval) chunk <- paste("##", chunk)
        cat(chunk, file = chunkout, sep = "\n")
        ## Add an attribute to the connection object (the value is not
        ## important) to indicate text was written to it at least once.
        if (options$split)
        {
            if (!is.null(options$label))
                attr(object$chunkout[[outfile]], "not.first") <- TRUE
        }
        else attr(object$output, "not.first") <- TRUE
    }
    if (is.null(options$label) && options$split) close(chunkout)
    object
}

RtangleWritedoc <- function(object, chunk)
{
    while(length(pos <- grep(object$syntax$docopt, chunk))) {
        opts <- sub(paste0(".*", object$syntax$docopt, ".*"),
                    "\\1", chunk[pos[1L]])
        object$options <- SweaveParseOptions(opts, object$options,
                                             RtangleOptions)
        chunk[pos[1L]] <- sub(object$syntax$docopt, "", chunk[pos[1L]])
    }
    object
}

RtangleFinish <- function(object, error = FALSE)
{
    ## might be stdout() or stderr()
    if (!is.null(object$output) && object$output >= 3)
        close(object$output)

    if (length(object$chunkout))
        for (con in object$chunkout) close(con)
}

## Check function for the Rtangle driver. Since code chunks are not
## evaluated on tangling, options may *not* take their values from
## objects. An invalid value for an option is replaced by its default
## value, with a warning.
RtangleOptions <- function(options)
{
    defaults <- options[[".defaults"]]

    ## convert a character string to logical
    c2l <- function(x)
        if (is.logical(x))
            x
        else if (is.null(x))
            FALSE
        else
            suppressWarnings(as.logical(x))

    ## character: largely for safety, but 'label' matters as there
    ## is no default (and someone uses "F")
    CHAROPTS <- c("prefix.string", "engine", "label")

    ## character or logical
    CHARLOGICOPTS <- c("chunk.sep", "extension")

    for (opt in names(options)) {
        if(opt == ".defaults") next
        oldval <- options[[opt]]
        defval <- defaults[[opt]]
        if(opt %in% CHARLOGICOPTS) {
            if(!is.logical(oldval) && !is.na(newval <- c2l(oldval)))
                options[[opt]] <- newval
        } else if(opt %in% CHAROPTS || is.character(defval)) {
        } else if(is.logical(defval)) {
            options[[opt]] <- c2l(oldval)
        } else if(!is.na(newval <- c2l(oldval)))
            options[[opt]] <- newval
        if (is.na(options[[opt]]) && !is.null(defval)) {
            options[[opt]] <- defval
            warning(gettextf("invalid value for %s : %s", sQuote(opt), oldval),
                    "; ",
                    gettextf("using default value %s", defval),
                    domain = NA)
        }
    }

    if (!is.null(options$chunk.sep) && isTRUE(options$chunk.sep))
        options$chunk.sep <- defaults$chunk.sep
    options
}

