#  File src/library/tools/R/Rd2txt.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/

## This stops on
##  unrecognized tag
##  \\tabular format must be simple text
##  too many columns for format
##  invalid markup in \[S3]method
##  "Tag ", tag, " not expected in code block"

tabExpand <- function(x) {
    srcref <- attr(x, "srcref")
    start <- if(is.null(srcref)) 0L else srcref[5L] - 1L
    .Call(C_doTabExpand, x, start)
}

Rd2txt_options <- local({
    opts <- list(width = 80L,
                 minIndent = 10L,
    	         extraIndent = 4L,
    	         sectionIndent = 5L,
    	         sectionExtra = 2L,
    	         itemBullet = "* ",
    	         enumFormat = function(n) sprintf("%d. ", n),
    	         showURLs = FALSE,
                 code_quote = TRUE,
                 underline_titles = TRUE)
    function(...) {
        args <- list(...)
        if (!length(args))
            return(opts)
        else {
            if (is.list(args[[1L]])) args <- args[[1L]]
            result <- opts[names(args)]
            opts[names(args)] <<- args
            invisible(result)
        }
    }
})

transformMethod <- function(i, blocks, Rdfile) {
    editblock <- function(block, newtext)
    	list(structure(newtext, Rd_tag = attr(block, "Rd_tag"),
    	                   srcref = attr(block, "srcref")))

    # Most of the internal functions below are more like macros
    # than functions; they mess around with these variables:

    chars <- NULL
    char <- NULL
    j <- NULL

    findOpen <- function(i) {
    	j <- i
    	char <- NULL
    	while (j < length(blocks)) {
    	    j <- j + 1L
    	    tag <- attr(blocks[[j]], "Rd_tag")
    	    if (tag == "RCODE") {

    	        # FIXME:  This search and the ones below will be fooled
    	        # by "#" comments

    	    	chars <- strsplit(blocks[[j]], "")[[1]]
    		parens <- cumsum( (chars == "(") - (chars == ")") )
    		if (any(parens > 0)) {
		    char <- which.max(parens > 0)
    	   	    break
    	   	}
    	    }
    	}
    	if (is.null(char))
    	    stopRd(block, Rdfile, sprintf("no parenthesis following %s", blocktag))
    	chars <<- chars
    	char <<- char
    	j <<- j
    }

    findComma <- function(i) {
	j <- i
	level <- 1L
	char <- NULL
	while (j < length(blocks)) {
	    j <- j + 1L
	    tag <- attr(blocks[[j]], "Rd_tag")
	    if (tag == "RCODE") {
		chars <- strsplit(blocks[[j]], "")[[1]]
		parens <- level + cumsum( (chars == "(") - (chars == ")") )
		if (any(parens == 1 & chars == ",")) {
		    char <- which.max(parens == 1 & chars == ",")
		    break
		}
		if (any(parens == 0))
		    break
		level <- parens[length(parens)]
	    }
	}
	if (is.null(char))
	    stopRd(block, Rdfile, sprintf("no comma in argument list following %s", blocktag))
        chars <<- chars
        char <<- char
        j <<- j
    }


    findClose <- function(i) {
        j <- i
    	level <- 1L
    	char <- NULL
    	while (j < length(blocks)) {
    	    j <- j + 1L
    	    tag <- attr(blocks[[j]], "Rd_tag")
    	    if (tag == "RCODE") {
    	    	chars <- strsplit(blocks[[j]], "")[[1]]
    	    	parens <- level + cumsum( (chars == "(") - (chars == ")") )
    	    	if (any(parens == 0)) {
    	    	    char <- which(parens == 0)[1]
    	    	    break
    	    	}
    	    	level <- parens[length(parens)]
    	    }
    	}
    	if (is.null(char))
    	    stopRd(block, Rdfile, sprintf("no closing parenthesis following %s", blocktag))
	chars <<- chars
        char <<- char
        j <<- j
    }

    rewriteBlocks <- function()
    	c(blocks[seq_len(j-1L)],
    	            editblock(blocks[[j]],
    	                      paste(chars[seq_len(char)], collapse="")),
    	            if (char < length(chars))
    	                editblock(blocks[[j]],
    	                          paste(chars[-seq_len(char)], collapse="")),
	            if (j < length(blocks)) blocks[-seq_len(j)])

    deleteBlanks <- function() {
	while (char < length(chars)) {
	    if (chars[char + 1] == " ") {
	    	char <- char + 1
	    	chars[char] <- ""
	    } else
	    	break
	}
	char <<- char
	chars <<- chars
    }

    block <- blocks[[i]]
    blocktag <- attr(block, "Rd_tag")
    srcref <- attr(block, "srcref")
    class <- block[[2L]] # or signature
    generic <- as.character(block[[1L]])
    default <- as.character(class) == "default"

    if(generic %in% c("[", "[[", "$")) {
	## need to assemble the call by matching parens in RCODE
	findOpen(i) # Sets chars, char and j
	chars[char] <- ""
	blocks <- c(blocks[seq_len(j-1L)],
	            editblock(blocks[[j]],
	                      paste(chars[seq_len(char)], collapse="")),
	            if (char < length(chars))
	                editblock(blocks[[j]],
	                          paste(chars[-seq_len(char)], collapse="")),
	            if (j < length(blocks)) blocks[-seq_len(j)])

	findComma(j) # Sets chars, char and j
	chars[char] <- generic
	# Delete blanks after the comma
	deleteBlanks()
	blocks <- rewriteBlocks()

	findClose(j)
	# Edit the closing paren
	chars[char] <- switch(generic,
		"[" = "]",
		"[[" = "]]",
		"$" = "")
	blocks[j] <- editblock(blocks[[j]],
	                         paste(chars, collapse=""))

	methodtype <- if (grepl("<-", blocks[[j]])) "replacement " else ""
    } else if(grepl(sprintf("^%s$",
			   paste(c("\\+", "\\-", "\\*",
				   "\\/", "\\^", "<=?",
				   ">=?", "!=?", "==",
				   "\\&", "\\|", "!",
				   "\\%[[:alnum:][:punct:]]*\\%"),
				 collapse = "|")),
		   generic)) {
        ## Binary operators and unary '!'.
	findOpen(i)

	if (generic != "!") {
            chars[char] <- ""
            blocks <- rewriteBlocks()
	    findComma(j)
	    chars[char] <- paste0(" ", generic, " ")
	    # Delete blanks after the comma
	    deleteBlanks()
	    blocks <- rewriteBlocks()
	} else {
            chars[char] <- "!"
	    blocks <- rewriteBlocks()
        }

	findClose(j)
	chars[char] <- ""
	blocks[j] <- editblock(blocks[[j]],
                               paste(chars, collapse=""))

	methodtype <- ""
    } else {
        findOpen(i)
	chars[char] <- paste0(generic, "(")
	blocks <- rewriteBlocks()
	findClose(j)
	methodtype <- if (grepl("<-", blocks[[j]])) "replacement " else ""
    }

    if (blocktag == "\\S4method") {
        ## some signatures are very long.
        blocks <- if(nchar(class) > 50L) {
            cl <- paste0("'", as.character(class), "'")
            if(nchar(cl) > 70L) {
                cl <- strsplit(cl, ",")[[1L]]
                ncl <- length(cl)
                cl[-ncl] <- paste0(cl[-ncl], ",")
                cl[-1L] <- paste0("  ", cl[-1L])
            }
            cl <- paste("##", cl, collapse="\n")
            c( blocks[seq_len(i-1L)],
              list(structure(paste0("## S4 ", methodtype, "method for signature \n"),
                             Rd_tag="RCODE", srcref=srcref)),
              list(structure(cl, Rd_tag="TEXT", srcref=srcref)),
              list(structure("\n", Rd_tag="RCODE", srcref=srcref)),
              blocks[-seq_len(i)] )
        } else
            c( blocks[seq_len(i-1L)],
              list(structure(paste0("## S4 ", methodtype, "method for signature '"),
                             Rd_tag="RCODE", srcref=srcref)),
              class,
              list(structure("'\n", Rd_tag="RCODE", srcref=srcref)),
              blocks[-seq_len(i)] )
    } else if (default)
    	blocks <- c( blocks[seq_len(i-1)],
    		     list(structure(paste0("## Default S3 ", methodtype, "method:\n"),
    		     	       Rd_tag="RCODE", srcref=srcref)),
    		     blocks[-seq_len(i)] )
    else
    	blocks <- c( blocks[seq_len(i-1)],
		     list(structure(paste0("## S3 ", methodtype, "method for class '"),
			   Rd_tag="RCODE", srcref=srcref)),
		     class,
		     list(structure("'\n", Rd_tag="RCODE", srcref=srcref)),
		     blocks[-seq_len(i)] )
    blocks
}# transformMethod()

Rd2txt <-
    function(Rd, out="", package = "", defines=.Platform$OS.type,
             stages = "render", outputEncoding = "",
             fragment = FALSE, options, ...)
{

    ## we need to keep track of where we are.
    buffer <- character()	# Buffer not yet written to con
    				# Newlines have been processed, each line in buffer is
    				# treated as a separate input line (but may be wrapped before output)
    linestart <- TRUE		# At start of line?
    indent <- 0L		# Default indent
    wrapping <- TRUE		# Do word wrap?
    keepFirstIndent <- FALSE	# Keep first line indent?
    dropBlank <- FALSE		# Drop initial blank lines?
    haveBlanks <- 0L		# How many blank lines have just been written?
    enumItem <- 0L		# Last enumeration item number
    inEqn <- FALSE		# Should we do edits needed in an eqn?
    sectionLevel <- 0		# How deeply nested within sections/subsections

    saveOpts <- Rd2txt_options()
    on.exit(Rd2txt_options(saveOpts))# Rd files may change these, so restore them
    				     # whether or not the caller set them.
    if (!missing(options)) Rd2txt_options(options)

## these attempt to mimic pre-2.10.0 layout
    WIDTH <- 0.9 * Rd2txt_options()$width
    HDR_WIDTH <- WIDTH - 2L

    startCapture <- function() {
    	save <- list(buffer=buffer, linestart=linestart, indent=indent,
                     wrapping=wrapping, keepFirstIndent=keepFirstIndent,
                     dropBlank=dropBlank, haveBlanks=haveBlanks,
                     enumItem=enumItem, inEqn=inEqn)
    	buffer <<- character()
    	linestart <<- TRUE
    	indent <<- 0L
    	wrapping <<- TRUE
    	keepFirstIndent <<- FALSE
    	dropBlank <<- FALSE
    	haveBlanks <<- 0L
    	enumItem <<- 0L
    	inEqn <<- FALSE
    	save
    }

    endCapture <- function(saved) {
    	result <- buffer
    	buffer <<- saved$buffer
    	linestart <<- saved$linestart
    	indent <<- saved$indent
    	wrapping <<- saved$wrapping
    	keepFirstIndent <<- saved$keepFirstIndent
    	dropBlank <<- saved$dropBlank
    	haveBlanks <<- saved$haveBlanks
    	enumItem <<- saved$enumItem
    	inEqn <<- saved$inEqn
    	result
    }

    ## for efficiency
    WriteLines <-
        if(outputEncoding == "UTF-8" ||
           (outputEncoding == "" && l10n_info()[["UTF-8"]])) {
        function(x, con, outputEncoding, ...)
            writeLines(x, con, useBytes = TRUE, ...)
    } else {
        function(x, con, outputEncoding, ...) {
            x <- iconv(x, "UTF-8", outputEncoding, sub="byte", mark=FALSE)
            writeLines(x, con, useBytes = TRUE, ...)
        }
    }

    ## Use display widths as used by cat not print.
    frmt <- function(x, justify="left", width = 0L) {
        justify <- match.arg(justify, c("left", "right", "centre", "none"))
        w <- sum(nchar(x, "width")) # copes with 0-length x
        if(w < width && justify != "none") {
            excess <- width - w
            left <- right <- 0L
            if(justify == "left") right <- excess
            else if(justify == "right")  left <- excess
            else if(justify == "centre") {
                left <- excess %/% 2
                right <- excess-left
            }
            paste(c(rep_len(" ", left), x, rep_len(" ", right)), collapse = "")
        } else x
    }

    wrap <- function(doWrap = TRUE)
	if (doWrap != wrapping) { flushBuffer(); wrapping <<- doWrap }

    putw <- function(...)  { wrap(TRUE); put(...) }

    putf <- function(...)  { wrap(FALSE); put(...) }

    put <- function(...) {
        txt <- paste0(..., collapse="")
        trail <- endsWith(txt, "\n")
        # Convert newlines
        txt <- strsplit(txt, "\n", fixed = TRUE)[[1L]]
        if (dropBlank) {
            while(length(txt) && grepl("^[[:space:]]*$", txt[1L]))
            	txt <- txt[-1L]
            if (length(txt)) dropBlank <<- FALSE
        }
        if(!length(txt)) return()
        haveBlanks <<- 0

        if (linestart) buffer <<- c(buffer, txt)
        else if (length(buffer)) {
            buffer[length(buffer)] <<-
                paste0(buffer[length(buffer)], txt[1L])
            buffer <<- c(buffer, txt[-1L])
        }
        else buffer <<- txt
        linestart <<- trail
    }

    flushBuffer <- function() {
    	if (!length(buffer)) return()

    	if (wrapping) {
	    if (keepFirstIndent) {
		first <- nchar(psub1("[^ ].*", "", buffer[1L]))
		keepFirstIndent <<- FALSE
	    } else
		first <- indent

	    buffer <<- c(buffer, "")  # Add an extra blank sentinel
	    blankLines <- grep("^[[:space:]]*$", buffer)
	    result <- character()
	    start <- 1L
	    for (i in seq_along(blankLines)) {
		if (blankLines[i] > start) {
		    result <- c(result,
                                strwrap(paste(buffer[start:(blankLines[i]-1L)],
                                              collapse = " "),
                                        WIDTH, indent = first, exdent = indent))
		    first <- indent
                }
                result <- c(result, "")
		start <- blankLines[i]+1L
	    }
            ## we want to collapse multiple blank lines when wrapping
            ## and to remove the sentinel (which we need to do first or
            ## we will drop a single blank line)
            buffer <<- result[-length(result)]
            empty <- !nzchar(buffer)
            drop <- empty & c(FALSE, empty[-length(empty)])
            buffer <<- buffer[!drop]
	} else {  # Not wrapping
	    if (keepFirstIndent) {
		if (length(buffer) > 1L)
		    buffer[-1L] <<- paste0(strrep(" ", indent), buffer[-1L])
		keepFirstIndent <- FALSE
	    } else
		buffer <<- paste0(strrep(" ", indent), buffer)
	}

    	if (length(buffer)) WriteLines(buffer, con, outputEncoding)
    	buffer <<- character()
    	linestart <<- TRUE
    }

    encoding <- "unknown"

    li <- l10n_info()
    ## See the comment in ?Rd2txt as to why we do not attempt fancy quotes
    ## in Windows CJK locales -- and in any case they would need more work
    ## This covers the common single-byte locales and Thai (874)
    use_fancy_quotes <-
        (.Platform$OS.type == "windows" &&
         ((li$codepage >= 1250 && li$codepage <= 1258) || li$codepage == 874)) ||
        li[["UTF-8"]]

    if(!isFALSE(getOption("useFancyQuotes")) &&
       use_fancy_quotes) {
        ## On Windows, Unicode literals are translated to local code page
    	LSQM <- intToUtf8("0x2018") # Left single quote
    	RSQM <- intToUtf8("0x2019") # Right single quote
    	LDQM <- intToUtf8("0x201c") # Left double quote
    	RDQM <- intToUtf8("0x201d") # Right double quote
    } else {
        LSQM <- RSQM <- "'"
        LDQM <- RDQM <- '"'
    }

    trim <- function(x) {
        x <- psub1("^\\s*", "", x)
        psub1("\\s*$", "", x)
    }

    ## underline via backspacing
    txt_header <- function(header) {
        opts <- Rd2txt_options()
        header <- paste(strwrap(header, WIDTH), collapse="\n")
        if (opts$underline_titles) {
            letters <- strsplit(header, "", fixed = TRUE)[[1L]]
            isaln <- grep("[[:alnum:]]", letters)
            letters[isaln] <- paste0("_\b", letters[isaln])
            paste(letters, collapse = "")
        } else header
    }

    unescape <- function(x) {
        x <- psub("(---|--)", "-", x)
        x
    }

    writeCode <- function(x) {
        txt <- as.character(x)
        if(inEqn) txt <- txt_eqn(txt)
        txt <- fsub('"\\{"', '"{"', txt)
        ## \dots gets left in noquote.Rd
        txt <- fsub("\\dots",  "...", txt)
        put(txt)
    }

    # This function strips pending blank lines, then adds n new ones.
    blankLine <- function(n = 1L) {
    	while (length(buffer) &&
               grepl("^[[:blank:]]*$", buffer[length(buffer)]))
    	    buffer <<- buffer[-length(buffer)]
	flushBuffer()
	if (n > haveBlanks) {
	    buffer <<- rep_len("", n - haveBlanks)
	    flushBuffer()
	    haveBlanks <<- n
	}
	dropBlank <<- TRUE
    }

    txt_eqn <- function(x) {
        x <- psub("\\\\(Alpha|Beta|Gamma|Delta|Epsilon|Zeta|Eta|Theta|Iota|Kappa|Lambda|Mu|Nu|Xi|Omicron|Pi|Rho|Sigma|Tau|Upsilon|Phi|Chi|Psi|Omega|alpha|beta|gamma|delta|epsilon|zeta|eta|theta|iota|kappa|lambda|mu|nu|xi|omicron|pi|rho|sigma|tau|upsilon|phi|chi|psi|omega|sum|prod|sqrt)", "\\1", x)
        x <- psub("\\\\(dots|ldots)", "...", x)
        x <- fsub("\\le", "<=", x)
        x <- fsub("\\ge", ">=", x)
        x <- fsub("\\infty", "Inf", x)
        ## FIXME: are these needed?
        x <- psub("\\\\(bold|strong|emph|var)\\{([^}]*)\\}", "\\2", x)
        x <- psub("\\\\(code|samp)\\{([^}]*)\\}", "'\\2'", x)
        x
    }

    writeDR <- function(block, tag) {
        if (length(block) > 1L) {
            putf('## Not run:\n')
            writeCodeBlock(block, tag)
            blankLine(0L)
            putf('## End(Not run)\n')
        } else {
            putf('## Not run: ')
            writeCodeBlock(block, tag)
            blankLine(0L)
        }
    }

    writeQ <- function(block, tag, quote=tag)
    {
        if (use_fancy_quotes) {
            if (quote == "\\sQuote") {
                put(LSQM); writeContent(block, tag); put(RSQM)
            } else {
                put(LDQM); writeContent(block, tag); put(RDQM)
            }
        } else {
            if (quote == "\\sQuote") {
                put("'"); writeContent(block, tag); put("'")
            } else {
                put("\""); writeContent(block,tag); put("\"")
            }
        }
    }

    writeBlock <- function(block, tag, blocktag) {
        switch(tag,
               UNKNOWN =,
               VERB =,
               RCODE = writeCode(tabExpand(block)),
               TEXT = if(blocktag == "\\command") putw(block) else putw(unescape(tabExpand(block))),
               USERMACRO =,
               "\\newcommand" =,
               "\\renewcommand" =,
               COMMENT = {},
               LIST = writeContent(block, tag),
               "\\describe" = {
               	   blankLine(0L)
                   writeContent(block, tag)
                   blankLine()
               },
               "\\itemize"=,
               "\\enumerate"= {
               	   blankLine(0L)
                   enumItem0 <- enumItem
                   enumItem <<- 0L
                   indent0 <- indent
                   opts <- Rd2txt_options()
                   indent <<- max(opts$minIndent,
                              indent + opts$extraIndent)
                   dropBlank <<- TRUE
                   writeContent(block, tag)
                   blankLine()
                   indent <<- indent0
                   enumItem <<- enumItem0
               },
               "\\code"=,
               "\\command"=,
               "\\env"=,
               "\\file"=,
               "\\kbd"=,
               "\\option"=,
               "\\pkg"=,
               "\\samp" = {
                   opts <- Rd2txt_options()
                   if(opts$code_quote)
                       writeQ(block, tag, quote="\\sQuote")
                   else writeContent(block,tag)
               },
               "\\email" = {
                   put("<email: ",
                       trimws(gsub("\n", "",
                                   paste(as.character(block),
                                         collapse=""))),
                       ">")
               },
               "\\url" = {
                   put("<URL: ",
                       trimws(gsub("\n", "",
                                   paste(as.character(block),
                                         collapse=""))),
                       ">")
               },
               "\\href" = {
                   opts <- Rd2txt_options()
                   writeContent(block[[2L]], tag)
                   if (opts$showURLs)
  			put(" (URL: ",
  			    trimws(gsub("\n", "",
                                        paste(as.character(block[[1L]]),
                                              collapse=""))),
  			    ")")
               },
               "\\Sexpr"= put(as.character.Rd(block, deparse=TRUE)),
               "\\acronym" =,
               "\\cite"=,
               "\\dfn"= ,
               "\\special" = ,
               "\\var" = writeContent(block, tag),

               "\\bold"=,
               "\\strong"= {
                   put("*")
                   writeContent(block, tag)
                   put("*")
               },
               "\\emph"= {
                   put("_")
                   writeContent(block, tag)
                   put("_")
               },
               "\\sQuote" =,
               "\\dQuote"= writeQ(block, tag) ,
               "\\preformatted"= {
                   putf("\n")
                   writeCodeBlock(block, tag)
               },
               "\\verb"= put(block),
               "\\linkS4class" =,
               "\\link" = writeContent(block, tag),
               "\\cr" = {
                   ## we want to print out what we have, and if
                   ## followed immediately by \n (as it usually is)
                   ## discard that.  This is not entirely correct,
                   ## but it is better than before ....
                   flushBuffer()
                   dropBlank <<- TRUE
                   },
               "\\dots" =,
               "\\ldots" = put("..."),
               "\\R" = put("R"),
               "\\enc" = {
                   ## Test to see if we can convert the encoded version
                   txt <- as.character(block[[1L]])
                   test <- iconv(txt, "UTF-8", outputEncoding, mark = FALSE)
                   txt <- if(!anyNA(test)) txt else as.character(block[[2L]])
                   put(txt)
               } ,
               "\\eqn" = {
                   block <- block[[length(block)]]
                   ## FIXME: treat 2 of 2 differently?
                   inEqn0 <- inEqn
                   inEqn <<- TRUE
                   writeContent(block, tag)
                   inEqn <<- inEqn0
               },
               "\\deqn" = {
                   blankLine()
                   block <- block[[length(block)]]
                   save <- startCapture()
                   inEqn <<- TRUE
                   writeContent(block, tag)
                   eqn <- endCapture(save)
                   eqn <- frmt(eqn, justify="centre", width=WIDTH-indent)
                   putf(paste(eqn, collapse="\n"))
    		   blankLine()
               },
               "\\figure" = {
                   blankLine()
                   save <- startCapture()
                   writeContent(block[[length(block)]], tag)
                   alt <- endCapture(save)
                   if (length(alt)) {
                   	alt <- frmt(alt, justify = "centre",
                                    width = WIDTH - indent)
                   	putf(paste(alt, collapse = "\n"))
                   	blankLine()
                   }
               },
               "\\tabular" = writeTabular(block),
               "\\subsection" = writeSection(block, tag),
               "\\if"=,
               "\\ifelse" =
                   if (testRdConditional("text", block, Rdfile))
               		writeContent(block[[2L]], tag)
               	   else if (tag == "\\ifelse")
               	   	writeContent(block[[3L]], tag),
               "\\out" = for (i in seq_along(block))
		   put(block[[i]]),
               stopRd(block, Rdfile, "Tag ", tag, " not recognized")
               )
    }

    writeTabular <- function(table) {
    	formats <- table[[1L]]
    	content <- table[[2L]]
    	if (length(formats) != 1L || RdTags(formats) != "TEXT")
    	    stopRd(table, Rdfile, "\\tabular format must be simple text")
    	formats <- strsplit(formats[[1L]], "", fixed = TRUE)[[1L]]
        tags <- RdTags(content)
        entries <- list()
        row <- 1L
        col <- 1L
        save <- startCapture()
        dropBlank <<- TRUE
        newEntry <- function() {
            entries <<- c(entries, list(list(text=trim(endCapture(save)),
	                   	             row=row, col=col)))
            save <<- startCapture()
            dropBlank <<- TRUE
        }
        for (i in seq_along(tags)) {
            switch(tags[i],
                  "\\tab" = {
                  	newEntry()
                   	col <- col + 1
                   	if (col > length(formats))
                   	    stopRd(content[[i]], Rdfile,
                                   sprintf("too many columns for format '%s'",
                                           table[[1L]]))
                   },
                   "\\cr" = {
                   	newEntry()
                   	row <- row + 1L
			col <- 1L
                    },
                   writeBlock(content[[i]], tags[i], "\\tabular")
                   )
        }
        newEntry()
        endCapture(save)
        entries <- with(entries[[length(entries)]],
        	    {
                        if (!length(text) && col == 1L)
                            entries[-length(entries)]
                        else
                            entries
                    })
        if(!length(entries)) return()
        rows <- entries[[length(entries)]]$row
        cols <- max(sapply(entries, function(e) e$col))
        widths <- rep_len(0L, cols)
        lines <- rep_len(1L, rows)
        for (i in seq_along(entries)) {
            e <- entries[[i]]
            while(length(e$text) && !nzchar(e$text[length(e$text)])) {
            	e$text <- e$text[-length(e$text)]
            	entries[[i]] <- e
            }
            if (any(nzchar(e$text)))
            	widths[e$col] <- max(widths[e$col], max(nchar(e$text, "w")))
            lines[e$row] <- max(lines[e$row], length(e$text))
        }
        result <- matrix("", sum(lines), cols)
        for (i in seq_len(cols))
            result[, i] <- strrep(" ", widths[i])
        firstline <- c(1L, 1L+cumsum(lines))
        for (i in seq_along(entries)) {
            e <- entries[[i]]
            if(!length(e$text)) next
            ## FIXME: this is not right: it justifies strings as if
            ## they are escaped, so in particular \ takes two columns.
            text <- frmt(e$text, justify=formats[e$col], width=widths[e$col])
            for (j in seq_along(text))
            	result[firstline[e$row] + j - 1L, e$col] <- text[j]
        }
        blankLine()
        indent0 <- indent
        indent <<- indent + 1L
        for (i in seq_len(nrow(result))) {
            putf(paste0(" ", result[i,], " ", collapse=""))
# This version stripped leading blanks on the first line
#            for (j in seq_len(cols))
#            	putf(" ", result[i,j], " ")
            putf("\n")
        }
        blankLine()
        indent <<- indent0
    }

    writeCodeBlock <- function(blocks, blocktag)
    {
    	tags <- RdTags(blocks)
	i <- 0
	while (i < length(tags)) {
	    i <- i + 1
            block <- blocks[[i]]
            tag <- tags[i]
            switch(tag,
                   "\\method" =,
                   "\\S3method" =,
                   "\\S4method" = {
                   	blocks <- transformMethod(i, blocks, Rdfile)
                   	tags <- RdTags(blocks)
                   	i <- i - 1
                   },
                   UNKNOWN =,
                   VERB =,
                   RCODE =,
                   TEXT = writeCode(tabExpand(block)),
                   "\\donttest" =,
                   "\\special" =,
                   "\\var" = writeCodeBlock(block, tag),
                   "\\dots" =, # \ldots is not really allowed
                   "\\ldots" = put("..."),
                   "\\dontrun"= writeDR(block, tag),
		   USERMACRO =,
		   "\\newcommand" =,
		   "\\renewcommand" =,
                   COMMENT =,
                   "\\dontshow" =,
                   "\\testonly" = {}, # do nothing
                   ## All the markup such as \emph
                   stopRd(block, Rdfile, "Tag ", tag,
                          " not expected in code block")
                   )
        }
    }

    writeContent <- function(blocks, blocktag) {
        itemskip <- FALSE
	tags <- RdTags(blocks)

	for (i in seq_along(tags)) {
            tag <- tags[i]
            block <- blocks[[i]]
            switch(tag,
                   "\\item" = {
                       switch(blocktag,
                              "\\describe"= {
                                  blankLine()
                                  save <- startCapture()
                                  dropBlank <<- TRUE
                                  writeContent(block[[1L]], tag)
                                  DLlab <- endCapture(save)
                                  indent0 <- indent
                                  opts <- Rd2txt_options()
                                  indent <<- max(opts$minIndent,
                                                 indent + opts$extraIndent)
                                  keepFirstIndent <<- TRUE
                                  putw(strrep(" ", indent0),
                                       frmt(paste0(DLlab),
                                            justify="left", width=indent),
                                       " ")
                                  writeContent(block[[2L]], tag)
			  	  blankLine(0L)
                                  indent <<- indent0
                              },
                              "\\value"=,
                              "\\arguments"= {
                                  blankLine()
                                  save <- startCapture()
                                  dropBlank <<- TRUE
                                  writeContent(block[[1L]], tag)
                                  DLlab <- endCapture(save)
                                  indent0 <- indent
                                  opts <- Rd2txt_options()
                                  indent <<- max(opts$minIndent, indent + opts$extraIndent)
                                  keepFirstIndent <<- TRUE
                                  putw(frmt(paste0(DLlab, ": "),
                                              justify="right", width=indent))
                                  writeContent(block[[2L]], tag)
			  	  blankLine(0L)
                                  indent <<- indent0
                              },
                              "\\itemize" =,
                              "\\enumerate" = {
                              	  blankLine()
                              	  keepFirstIndent <<- TRUE
                              	  opts <- Rd2txt_options()
                              	  if (blocktag == "\\itemize")
                              	      label <- opts$itemBullet
                              	  else {
                              	      enumItem <<- enumItem + 1L
                              	      label <- opts$enumFormat(enumItem)
                              	  }
                              	  putw(frmt(label, justify="right",
                                            width=indent))
                              })
                       itemskip <- TRUE
                   },
               { # default
                   if (itemskip) {
                       ## The next item must be TEXT, and start with a space.
                       itemskip <- FALSE
                       if (tag == "TEXT") {
                           txt <- psub("^ ", "", as.character(tabExpand(block)))
                           put(txt)
                       } else writeBlock(block, tag, blocktag) # should not happen
                   } else writeBlock(block, tag, blocktag)
               })
	}
    }

    writeSection <- function(section, tag) {
        if (tag %in% c("\\alias", "\\concept", "\\encoding", "\\keyword"))
            return()
    	save <- c(indent, sectionLevel, keepFirstIndent, dropBlank, wrapping)
    	blankLine(min(sectionLevel, 1L))
    	titlePrefix <- strrep("  ", sectionLevel)
    	opts <- Rd2txt_options()
        indent <<- opts$sectionIndent + opts$sectionExtra*sectionLevel
        sectionLevel <<- sectionLevel + 1
        keepFirstIndent <<- TRUE
        if (tag == "\\section" || tag == "\\subsection") {
            ## section header could have markup
            title <- .Rd_format_title(.Rd_get_text(section[[1L]]))
            putf(titlePrefix, txt_header(title), ":")
            blankLine()
            dropBlank <<- TRUE
            wrapping <<- TRUE
            keepFirstIndent <<- FALSE
    	    writeContent(section[[2L]], tag)
    	} else if (tag %in% c("\\usage", "\\examples")) {
            putf(txt_header(sectionTitles[tag]), ":")
            blankLine()
            dropBlank <<- TRUE
            wrapping <<- FALSE
            keepFirstIndent <<- FALSE
            writeCodeBlock(section, tag)
    	} else {
            putf(txt_header(sectionTitles[tag]), ":")
            blankLine()
            dropBlank <<- TRUE
            wrapping <<- TRUE
            keepFirstIndent <<- FALSE
            writeContent(section, tag)
        }
        blankLine()

        indent <<- save[1L]
        sectionLevel <<- save[2L]
        keepFirstIndent <<- save[3L]
        dropBlank <<- save[4L]
        wrapping <<- save[5L]
    }

    if (is.character(out)) {
        if(out == "") {
            con <- stdout()
        } else {
	    con <- file(out, "wt")
	    on.exit(close(con), add=TRUE)
	}
    } else {
    	con <- out
    	out <- summary(con)$description
    }

    Rd <- prepare_Rd(Rd, defines=defines, stages=stages, fragment=fragment, ...)
    Rdfile <- attr(Rd, "Rdfile")
    sections <- RdTags(Rd)
    if (fragment) {
    	if (sections[1L] %in% names(sectionOrder))
    	    for (i in seq_along(sections))
    	    	writeSection(Rd[[i]], sections[i])
    	else
    	    for (i in seq_along(sections))
    	    	writeBlock(Rd[[i]], sections[i], "")
    } else {
	title <- .Rd_format_title(.Rd_get_title(Rd))

	name <- trim(Rd[[2L]][[1L]])

	if(nzchar(package)) {
	    left <- name
	    mid <- if(nzchar(package)) paste0("package:", package) else ""
	    right <- "R Documentation"
	    if(encoding != "unknown")
		right <- paste0(right, "(", encoding, ")")
	    pad <- max(HDR_WIDTH - nchar(left, "w") - nchar(mid, "w") - nchar(right, "w"), 0)
	    pad0 <- pad %/% 2L
	    pad1 <- strrep(" ", pad0)
	    pad2 <- strrep(" ", pad - pad0)
	    putf(paste0(left, pad1, mid, pad2, right, "\n\n"))
	}

	putf(txt_header(title))
	blankLine()

	for (i in seq_along(sections)[-(1:2)])
	    writeSection(Rd[[i]], sections[i])
    }
    blankLine(0L)
    invisible(out)
}