getParseData() - for first-file objects - PR#16756 thanks to Duncan M…

…urdoch

git-svn-id: https://svn.r-project.org/R/trunk@84538 00db46b3-68df-0310-9c12-caf00c1e9a41

doc/NEWS.Rd

@@ -47,7 +47,7 @@
 
       \item When \R packages are built, typically by \command{R CMD build <pkg>},
       the new \command{--user=<build_user>} option overrides the
-      (internally determined) user name, currently \code{Sys.info()["user"]} 
+      (internally determined) user name, currently \code{Sys.info()["user"]}
       or \env{LOGNAME}.  This is a (modified) fulfillment of Will Landau's
       suggestion in \PR{17530}.
     }
@@ -118,6 +118,10 @@
       \item \code{S3method(<gen>, <class>, <func>)} in the \file{NAMESPACE}
       file now works (again) when \code{<func>} is visible from the
       namespace, e.g., imported, or in base.
+
+      \item \code{getParseData(f)} now also works for a function defined
+      in the first of several \file{<pkg>/R/*.R} source files, thanks to
+      Kirill Müller's report and Duncan Murdoch's patch in \PR{16756}.
     }
   }
 }

src/library/utils/R/sourceutils.R

@@ -140,6 +140,10 @@ getParseData <- function(x, includeText = NA) {
     	return(NULL)
     else
     	data <- srcfile$parseData
+
+    if (is.null(data) && !is.null(srcfile$original))
+        data <- srcfile$original$parseData
+
     if (!is.null(data)) {
         tokens <- attr(data, "tokens")
         data <- t(unclass(data))

src/main/gram.c

@@ -66,9 +66,9 @@
 
 /*
  *  R : A Computer Language for Statistical Data Analysis
- *  Copyright (C) 1995, 1996, 1997  Robert Gentleman and Ross Ihaka
- *  Copyright (C) 1997--2022  The R Core Team
+ *  Copyright (C) 1997--2023  The R Core Team
  *  Copyright (C) 2009--2011  Romain Francois
+ *  Copyright (C) 1995--1997  Robert Gentleman and Ross Ihaka
  *
  *  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
@@ -6517,6 +6517,9 @@ static void finalizeData(void){
     setAttrib(newdata, R_ClassSymbol, mkString("parseData"));
 
     /* Put it into the srcfile environment */
+    if (isEnvironment(PS_ORIGINAL))
+	defineVar(install("parseData"), newdata, PS_ORIGINAL);    
+    else
     if (isEnvironment(PS_SRCFILE))
 	defineVar(install("parseData"), newdata, PS_SRCFILE);
     UNPROTECT(4); /* tokens, newdata, newtext, dims */

src/main/gram.y

@@ -1,9 +1,9 @@
 %{
 /*
  *  R : A Computer Language for Statistical Data Analysis
- *  Copyright (C) 1995, 1996, 1997  Robert Gentleman and Ross Ihaka
- *  Copyright (C) 1997--2022  The R Core Team
+ *  Copyright (C) 1997--2023  The R Core Team
  *  Copyright (C) 2009--2011  Romain Francois
+ *  Copyright (C) 1995--1997  Robert Gentleman and Ross Ihaka
  *
  *  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
@@ -4285,7 +4285,10 @@ static void finalizeData(void){
 
     setAttrib(newdata, R_ClassSymbol, mkString("parseData"));
 
-    /* Put it into the srcfile environment */
+    /* Put it into the original or srcfile environment */
+    if (isEnvironment(PS_ORIGINAL))
+	defineVar(install("parseData"), newdata, PS_ORIGINAL);    
+    else
     if (isEnvironment(PS_SRCFILE))
 	defineVar(install("parseData"), newdata, PS_SRCFILE);
     UNPROTECT(4); /* tokens, newdata, newtext, dims */

tests/Pkgs/parseDataEx/DESCRIPTION

@@ -0,0 +1,11 @@
+Package: parseDataEx
+Title: Example Showing PR_16756
+Version: 0.1-0
+Author: Martin Maechler, Kirill Mueller
+Maintainer: R Core <[email protected]>
+Description: Dummy Package Showing PR_16756.
+  See  <https://bugs.r-project.org/show_bug.cgi?id=16756>,
+  also <https://rpubs.com/krlmlr/getParseData>
+License: GPL-3
+KeepSource: true
+

tests/Pkgs/parseDataEx/NAMESPACE

@@ -0,0 +1 @@
+export(f, g, h)

tests/Pkgs/parseDataEx/R/a.R

@@ -0,0 +1,5 @@
+f <- function() {
+  if (FALSE) # never ..
+    TRUE
+  ## i.e., we will always return an   invisible()  NULL
+}

tests/Pkgs/parseDataEx/R/b.R

@@ -0,0 +1,12 @@
+## a function w/o "{ .. }"  .. this is all about keeping parse data:
+g <- function(x) # comment g()
+    if(x) TRUE
+
+## with "{ .. }"
+h <- function(x) { # argument x
+    if(is.atomic(x))
+        x # atomic vector
+    else list(if(length(x)) x[[1]], # <-- "nothing" when length zero
+              le = length(x), cl = class(x)) # something else
+}
+

tests/Pkgs/parseDataEx/tests/test-getSrc.R

@@ -0,0 +1,50 @@
+pkg <- "parseDataEx"
+
+options(keep.source.pkgs     = TRUE, # default: FALSE
+        keep.parse.data.pkgs = TRUE, #    "       "
+        keep.parse.data = TRUE, keep.source = TRUE)  # just in case
+
+library(pkg, character.only=TRUE)
+
+## This is *NOT* about parse data !!  -------> see ./test-parseD.R <-----  ,  using getParseData()
+
+stopifnot(exprs = {
+    is.null(f())
+    identical(g(1), TRUE)
+    is.null(  g(0))
+})
+
+getSrcStuff <- function(x, unique=TRUE, full.names=FALSE, first=TRUE) {
+    list(filename = getSrcFilename(x, full.names=full.names, unique=unique),
+         dir      = getSrcDirectory(x, unique=unique),
+         srcref   = getSrcref(x),
+         loc      = {
+             whs <- eval(formals(getSrcLocation)$which)
+             ## sapply(): all integer(1); keep nms:
+             sapply(whs, \(wh) getSrcLocation(x, which=wh, first=first))
+         })
+}
+
+nms <- ls(paste0("package:", pkg))
+
+srcObj <- lapply(setNames(,nms), get, envir=asNamespace(pkg))
+srcAll <- lapply(srcObj, getSrcStuff)
+
+# shows all functions in the original formatting incl comments:
+(srcrefs <- lapply(srcAll, `[[`, "srcref"))
+(sfiles  <- lapply(srcrefs, attr, "srcfile"))
+origs <- lapply(sfiles, `[[`, "original")
+
+stopifnot(exprs = {
+    identical(sapply(srcAll, `[[`, "filename"),
+              c(f = "a.R", g = "b.R", h = "b.R"))
+    sapply(sfiles, is.environment) # all TRUE
+    sapply(origs,  is.environment)
+    length(unique(origs)) == 1L # the same concatenated file
+    class(orig <- origs[[1]]) == c("srcfilecopy", "srcfile")
+})
+## class(.) does *not* contain "environment" ==> as.list() does *not* work:
+str(as.list.environment(orig))
+
+str(srcAll)
+## (could test quite a bit more)

tests/Pkgs/parseDataEx/tests/test-parseD.R

@@ -0,0 +1,54 @@
+pkg <- "parseDataEx"
+
+options(keep.source.pkgs     = TRUE, # {default: FALSE}
+        keep.parse.data.pkgs = TRUE, # {default: FALSE}
+        keep.parse.data = TRUE, keep.source = TRUE)  # just in case
+
+sessionInfo()
+library(pkg, character.only=TRUE)
+packageDescription(pkg)
+
+## now, the same 123 for all: the same *concatenated* *.R files --> the *same* 1 file
+nrow(f.pd <- getParseData(f)) # gave 0  in R <= 4.3.1
+nrow(g.pd <- getParseData(g)) # was ok already
+nrow(h.pd <- getParseData(h)) # (ditto)
+
+head(f.pd)
+str(f.pd)
+(eq.f.g <- all.equal(f.pd, g.pd))# one difference: srcfile->filename
+stopifnot(exprs = {
+    nrow(g.pd) > 120
+    identical(nrow(f.pd), nrow(g.pd))
+    identical(g.pd, h.pd) # because they are in the *same* source file ../R/b.R
+    is.character(eq.f.g)
+    length(eq.f.g) == 1
+    sapply(c("srcfile", "filename"), grepl, x = eq.f.g, fixed = TRUE)
+})
+f_srcref <- getSrcref(f)
+f_srcfile <- attr(f_srcref, "srcfile")
+ls(f_srcfile)
+f_srcfile$original
+ls(f_srcfile$original)
+
+g_srcfile <- attr(getSrcref(g), "srcfile")
+
+(f.fn <- f_srcfile$filename)
+(g.fn <- g_srcfile$filename)
+
+basename3 <- function(f) sub(paste0("^", dirname(dirname(dirname(f)))), "", f)
+pkgR <- function(f) paste0("/",pkg,"/R/", f)
+
+basename3(attr(h.pd, "srcfile")$filename)
+
+stopifnot(exprs = {
+    identical(attr(f.pd, "srcfile"), f_srcfile)
+    is.environment(f_srcfile)
+    basename3(f.fn) == pkgR("a.R")
+    basename3(g.fn) == pkgR("b.R")
+    is.environment(f_srcfile$original)
+    "parseData" %in% names(f_srcfile$original)
+    "parseData" %in% names(g_srcfile$original)
+    ## both `original` are identical {<==> the concatenated *.R files}:
+    identical(f_srcfile$original,
+              g_srcfile$original)
+})

tests/reg-packages.R

@@ -20,6 +20,7 @@ showProc.time <- local({ ## function + 'pct' variable
 	    final)
     }
 })
+options(width=120)
 
 ## PR 1271  detach("package:base") crashes R.
 tools::assertError(detach("package:base"))
@@ -192,11 +193,14 @@ iBrace <- grep("closing brace", f2lns, fixed=TRUE)
 (writeLines(f3lns, f3nm))
 p.fails <- paste0("PR17859.", 1:3)
 io859 <- c("--no-help", "--no-test-load", "--no-byte-compile")
-InstOpts <- list("exSexpr" = "--html")
+InstOpts <- list("exSexpr" = "--html"
+               , "parseDataEx" = c("--with-keep.parse.data", "--with-keep.source", "--install-tests")
+                 )
 for(p in p.fails) InstOpts <- c(InstOpts, `names<-`(list(io859), p))
 p.lis <- c(if("Matrix" %in% row.names(installed.packages(.Library)))
                c("pkgA", "pkgB", if(okB2) "pkgB2", if(okB3) "pkgB3", "pkgC"),
            "PR17501",
+           "parseDataEx", # PR16756
            p.fails,
            "S3export",
            "exNSS4", "exNSS4nil", "exSexpr")
@@ -437,6 +441,13 @@ if(dir.exists(file.path("myLib", "exNSS4"))) withAutoprint({
 showProc.time()
 
 
+require("parseDataEx", lib="myLib") # installed with --install-tests :
+stopifnot(dir.exists(tdir <- system.file(package="parseDataEx", "tests")))
+## run the tests/*.R
+invisible( lapply(dir(tdir, pattern="[.]R$", full.names = TRUE), source) )
+showProc.time()
+
+
 ## Part 3: repository construction ---------------------------------------------
 ## test tools::write_PACKAGES and tools::update_PACKAGES
 oldpkgdir <- file.path(tempdir(), "pkgfiles/old")