Merge pull request #218 from r-lib/fix-clone-env-portable

Fix env for cloned portable classes with inheritance

NEWS.md

@@ -3,7 +3,7 @@ R6 2.4.1.9001
 
 * Resolved #195: Slightly clearer message when there is an error in the `initialize()` method.
 
-* Fixed #214: When a non-portable object inheritance was cloned, methods that were inherited (and not overridden) had the wrong environment. (#215)
+* Fixed #214: When a non-portable object inheritance was cloned, methods that were inherited (and not overridden) had the wrong environment. (#215, #217)
 
 * Printing R6 objects, no longer includes `.__active__`.
 

R/clone.R

@@ -158,7 +158,7 @@ generator_funs$clone_method <- function(deep = FALSE) {
 
 
   # This creates a slice other than the first one.
-  make_new_slice <- function(old_slice, self, private, enclosing_parent, portable) {
+  make_new_slice <- function(old_slice, self, private, enclosing_parent) {
     enclosing <- new.env(enclosing_parent, hash = FALSE)
     binding   <- new.env(emptyenv(), hash = FALSE)
 
@@ -187,12 +187,17 @@ generator_funs$clone_method <- function(deep = FALSE) {
   # Mirror the super environments from the old object
   if (length(old) > 1) {
     for (i in seq.int(2, length(old))) {
+      if (portable) {
+        enclosing_parent <- parent.env(old[[i]]$enclosing)
+      } else {
+        enclosing_parent <- new_1_enclosing
+      }
+
       new[[i]] <- make_new_slice(
         old[[i]],
         new_1_binding,
         new_1_private,
-        new_1_enclosing,
-        portable
+        enclosing_parent
       )
     }
 

tests/testthat/test-clone.R

@@ -426,6 +426,234 @@ test_that("Lock state", {
 })
 
 
+test_that("Cloning and inheritance of parent env", {
+  # ==========================
+  # Portable
+  # ==========================
+  A <- local({
+    y <- 1
+    R6Class("A",
+      public = list(
+        x = 1,
+        getx = function() self$x,
+        gety = function() y
+      )
+    )
+  })
+
+  # Check the environments of the original class
+  a <- A$new()
+  expect_identical(a$.__enclos_env__, environment(a$getx))
+  expect_identical(a, a$.__enclos_env__$self)
+
+  a2 <- a$clone()
+  expect_identical(a2$.__enclos_env__, environment(a2$getx))
+  expect_identical(a2, a2$.__enclos_env__$self)
+
+  expect_false(identical(a, a2))
+
+  B <- local({
+    y <- 2
+    R6Class("B",
+      inherit = A,
+      public = list(
+        getx_super = function() super$getx(),
+        gety_super = function() super$gety()
+      )
+    )
+  })
+
+  b <- B$new()
+  expect_false(exists("super", envir = environment(b$getx)))
+  expect_false(identical(b$.__enclos_env__, environment(b$getx)))
+  expect_true(exists("y", envir = parent.env(environment(b$getx))))
+  # If the method is inherited, the super (of the object, not the method) method
+  # should be the same as the inherited method
+  expect_identical(b$.__enclos_env__$super$getx, b$getx)
+  expect_identical(b, environment(b$getx)$self)
+
+  # Inherited method
+  expect_identical(b$getx(), 1)
+  # Method which calls super
+  expect_identical(b$getx_super(), 1)
+  expect_identical(b$gety(), 1)
+  expect_identical(b$gety_super(), 1)
+
+  b2 <- b$clone()
+  expect_false(exists("super", envir = environment(b2$getx)))
+  expect_false(identical(b2$.__enclos_env__, environment(b2$getx)))
+  expect_true(exists("y", envir = parent.env(environment(b2$getx))))
+  # If the method is inherited, the super (of the object, not the method) method
+  # should be the same as the inherited method
+  expect_identical(b2$.__enclos_env__$super$getx, b2$getx)
+  expect_identical(b2, environment(b2$getx)$self)
+
+  expect_identical(b2$getx(), 1)
+  expect_identical(b2$getx_super(), 1)
+  expect_identical(b$gety(), 1)
+  expect_identical(b$gety_super(), 1)
+
+  b2$x <- 3
+  expect_identical(b2$getx(), 3)
+  expect_identical(b2$getx_super(), 3)
+
+  C <- local({
+    y <- 3
+    R6Class("C",
+      inherit = B,
+      public = list(
+        getx_super = function() super$getx(),
+        gety_super = function() super$gety()
+      )
+    )
+  })
+
+  c <- C$new()
+  expect_false(exists("super", envir = environment(c$getx)))
+  expect_false(identical(c$.__enclos_env__, environment(b$getx)))
+  expect_true(exists("y", envir = parent.env(environment(c$getx))))
+  # If the method is inherited, the super (of the object, not the method) method
+  # should be the same as the inherited method
+  expect_identical(c$.__enclos_env__$super$getx, c$getx)
+  expect_identical(c, environment(c$getx)$self)
+
+  # Inherited method
+  expect_identical(c$getx(), 1)
+  # Method which calls super
+  expect_identical(c$getx_super(), 1)
+  expect_identical(c$gety(), 1)
+  expect_identical(c$gety_super(), 1)
+
+  c2 <- c$clone()
+  expect_false(exists("super", envir = environment(c2$getx)))
+  expect_false(identical(c2$.__enclos_env__, environment(c2$getx)))
+  expect_true(exists("y", envir = parent.env(environment(c2$getx))))
+  # If the method is inherited, the super (of the object, not the method) method
+  # should be the same as the inherited method
+  expect_identical(c2$.__enclos_env__$super$getx, c2$getx)
+  expect_identical(c2, environment(c2$getx)$self)
+
+  expect_identical(c2$getx(), 1)
+  expect_identical(c2$getx_super(), 1)
+  expect_identical(c$gety(), 1)
+  expect_identical(c$gety_super(), 1)
+
+  # ==========================
+  # Non-portable
+  # ==========================
+  A <- local({
+    y <- 1
+    R6Class("A",
+      portable = FALSE,
+      public = list(
+        x = 1,
+        getx = function() x,
+        gety = function() y
+      )
+    )
+  })
+
+  # Check the environments of the original class
+  a <- A$new()
+  expect_identical(a, environment(a$getx))
+  expect_identical(a, a$.__enclos_env__)
+
+  a2 <- a$clone()
+  expect_identical(a, environment(a$getx))
+  expect_identical(a, a$.__enclos_env__)
+
+  expect_false(identical(a, a2))
+
+  B <- local({
+    y <- 2
+    R6Class("B",
+      portable = FALSE,
+      inherit = A,
+      public = list(
+        getx_super = function() super$getx(),
+        gety_super = function() super$gety()
+      )
+    )
+  })
+
+  b <- B$new()
+  expect_identical(b, parent.env(environment(b$getx)))
+  expect_identical(b, b$.__enclos_env__)
+  # The parent of the enclosing env of a super method should be the object
+  # itself.
+  expect_identical(parent.env(environment(b$super$getx)), b)
+  # Inherited method
+  expect_identical(b$getx(), 1)
+  # Method which calls super
+  expect_identical(b$getx_super(), 1)
+  # Because portable=F, the inherited method gets the subclass's environment.
+  expect_identical(b$gety(), 2)
+  expect_identical(b$gety_super(), 2)
+
+  b2 <- b$clone()
+  expect_identical(b2, parent.env(environment(b2$getx)))
+  expect_identical(b2, b2$.__enclos_env__)
+  expect_identical(parent.env(environment(b2$super$getx)), b2)
+
+  expect_identical(b2$getx(), 1)
+  expect_identical(b2$getx_super(), 1)
+  expect_identical(b2$gety(), 2)
+  expect_identical(b2$gety_super(), 2)
+
+  # The original and the clone have the same parent env
+  expect_identical(parent.env(b), parent.env(b2))
+
+  b2$x <- 3
+  expect_identical(b2$getx(), 3)
+  expect_identical(b2$getx_super(), 3)
+
+  b3 <- b2$clone()
+  expect_identical(b3$getx(), 3)
+  expect_identical(b3$getx_super(), 3)
+  expect_identical(b3$gety(), 2)
+  expect_identical(b3$gety_super(), 2)
+
+  C <- local({
+    y <- 3
+    R6Class("C",
+      portable = FALSE,
+      inherit = B,
+      public = list(
+        getx_super = function() super$getx(),
+        gety_super = function() super$gety()
+      )
+    )
+  })
+
+  c <- C$new()
+  expect_identical(c, parent.env(environment(c$getx)))
+  expect_identical(c, c$.__enclos_env__)
+  # The parent of the enclosing env of a super method should be the object
+  # itself.
+  expect_identical(parent.env(environment(c$super$getx)), c)
+  # Inherited method
+  expect_identical(c$getx(), 1)
+  # Method which calls super
+  expect_identical(c$getx_super(), 1)
+  # Because portable=F, the inherited method gets the subclass's environment.
+  expect_identical(c$gety(), 3)
+  expect_identical(c$gety_super(), 3)
+
+  c2 <- c$clone()
+  expect_identical(c2, parent.env(environment(c2$getx)))
+  expect_identical(c2, c2$.__enclos_env__)
+  expect_identical(parent.env(environment(c2$super$getx)), c2)
+
+  expect_identical(c2$getx(), 1)
+  expect_identical(c2$getx_super(), 1)
+  expect_identical(c2$gety(), 3)
+  expect_identical(c2$gety_super(), 3)
+
+  # The original and the clone have the same parent env
+  expect_identical(parent.env(c), parent.env(c2))
+})
+
+
 test_that("Cloning inherited methods for portable classes", {
   # This set of tests makes sure that inherited methods refer to the correct
   # self, private, and super. They also test multiple levels of inheritance.