1context("finalizer") 2 3 4test_that("Finalizers are called, portable", { 5 parenv <- new.env() 6 parenv$peekaboo <- FALSE 7 AC <- R6Class("AC", 8 public = list(finalize = function() peekaboo <<- TRUE), 9 portable = TRUE, 10 parent_env = parenv 11 ) 12 a <- AC$new() 13 rm(a) 14 gc() 15 expect_true(parenv$peekaboo) 16}) 17 18 19test_that("Finalizers are called, non-portable", { 20 parenv <- new.env() 21 parenv$peekaboo <- FALSE 22 AC <- R6Class("AC", 23 public = list(finalize = function() peekaboo <<- TRUE), 24 portable = FALSE, 25 parent_env = parenv 26 ) 27 a <- AC$new() 28 rm(a) 29 gc() 30 expect_true(parenv$peekaboo) 31}) 32 33 34test_that("Finalizers have the right environment, portable", { 35 parenv <- new.env() 36 parenv$pub <- parenv$priv <- FALSE 37 AC <- R6Class( 38 "AC", 39 public = list( 40 finalize = function() { pub <<- self$mypub; priv <<- private$mypriv }, 41 mypub = TRUE 42 ), 43 private = list( 44 mypriv = TRUE 45 ), 46 portable = TRUE, 47 parent_env = parenv 48 ) 49 a <- AC$new() 50 rm(a) 51 gc() 52 expect_true(parenv$pub) 53 expect_true(parenv$priv) 54}) 55 56 57test_that("Finalizers have the right environment, non-portable #1", { 58 parenv <- new.env() 59 parenv$pub <- parenv$priv <- FALSE 60 AC <- R6Class( 61 "AC", 62 public = list( 63 finalize = function() { pub <<- self$mypub; priv <<- private$mypriv }, 64 mypub = TRUE 65 ), 66 private = list( 67 mypriv = TRUE 68 ), 69 portable = FALSE, 70 parent_env = parenv 71 ) 72 a <- AC$new() 73 rm(a) 74 gc() 75 expect_true(parenv$pub) 76 expect_true(parenv$priv) 77}) 78 79 80test_that("Finalizers have the right environment, non-portable #2", { 81 parenv <- new.env() 82 parenv$pub <- parenv$priv <- FALSE 83 AC <- R6Class( 84 "AC", 85 public = list( 86 finalize = function() { pub <<- mypub; priv <<- mypriv }, 87 mypub = TRUE 88 ), 89 private = list( 90 mypriv = TRUE 91 ), 92 portable = FALSE, 93 parent_env = parenv 94 ) 95 a <- AC$new() 96 rm(a) 97 gc() 98 expect_true(parenv$pub) 99 expect_true(parenv$priv) 100}) 101 102 103test_that("Finalizers are inherited, portable", { 104 105 AC <- R6Class( 106 "AC", 107 public = list( 108 finalize = function() print("An AC was just deleted") 109 ) 110 ) 111 112 BC <- R6Class( 113 "BC", 114 inherit = AC 115 ) 116 117 B <- BC$new() 118 expect_output({ rm(B); gc() }, "An AC was just deleted") 119}) 120 121 122test_that("Children can override finalizers, portable", { 123 124 AC <- R6Class( 125 "AC", 126 public = list( 127 finalize = function() cat("An AC was just deleted") 128 ) 129 ) 130 131 BC <- R6Class( 132 "BC", 133 inherit = AC, 134 public = list( 135 finalize = function() cat("A BC was just deleted") 136 ) 137 ) 138 139 B <- BC$new() 140 ## The anchors make sure that there is no extra output here 141 expect_output({ rm(B); gc() }, "^A BC was just deleted$") 142}) 143 144 145test_that("Children can call finalizers in the parent, portable", { 146 147 AC <- R6Class( 148 "AC", 149 public = list( 150 finalize = function() cat("An AC was just deleted\n") 151 ) 152 ) 153 154 BC <- R6Class( 155 "BC", 156 inherit = AC, 157 public = list( 158 finalize = function() { 159 super$finalize() 160 cat("A BC was just deleted\n") 161 } 162 ) 163 ) 164 165 B <- BC$new() 166 expect_output( 167 { rm(B); gc() }, 168 "An AC was just deleted.*A BC was just deleted" 169 ) 170}) 171 172 173test_that("Finalizers and two levels of inheritance, portable", { 174 AC <- R6Class( 175 "AC", 176 public = list( 177 finalize = function() cat("An AC was just deleted\n") 178 ) 179 ) 180 181 BC <- R6Class( 182 "BC", 183 inherit = AC, 184 public = list( 185 finalize = function() { 186 super$finalize() 187 cat("A BC was just deleted\n") 188 } 189 ) 190 ) 191 192 CC <- R6Class( 193 "CC", 194 inherit = BC, 195 public = list( 196 finalize = function() { 197 super$finalize() 198 cat("A CC was just deleted\n") 199 } 200 ) 201 ) 202 203 C <- CC$new() 204 expect_output( 205 { rm(C); gc() }, 206 "An AC was just deleted.*A BC was just deleted.*A CC was just deleted" 207 ) 208}) 209 210 211test_that("Finalizers are inherited, non-portable", { 212 213 AC <- R6Class( 214 "AC", 215 public = list( 216 finalize = function() print("An AC was just deleted") 217 ), 218 portable = FALSE 219 ) 220 221 BC <- R6Class( 222 "BC", 223 inherit = AC, 224 portable = FALSE 225 ) 226 227 B <- BC$new() 228 expect_output({ rm(B); gc() }, "An AC was just deleted") 229}) 230 231 232test_that("Children can override finalizers, non-portable", { 233 234 AC <- R6Class( 235 "AC", 236 public = list( 237 finalize = function() cat("An AC was just deleted") 238 ), 239 portable = FALSE 240 ) 241 242 BC <- R6Class( 243 "BC", 244 inherit = AC, 245 public = list( 246 finalize = function() cat("A BC was just deleted") 247 ), 248 portable = FALSE 249 ) 250 251 B <- BC$new() 252 ## The anchors make sure that there is no extra output here 253 expect_output({ rm(B); gc() }, "^A BC was just deleted$") 254}) 255 256 257test_that("Children can call finalizers in the parent, non-portable", { 258 259 AC <- R6Class( 260 "AC", 261 public = list( 262 finalize = function() cat("An AC was just deleted\n") 263 ), 264 portable = FALSE 265 ) 266 267 BC <- R6Class( 268 "BC", 269 inherit = AC, 270 public = list( 271 finalize = function() { 272 super$finalize() 273 cat("A BC was just deleted\n") 274 } 275 ), 276 portable = FALSE 277 ) 278 279 B <- BC$new() 280 expect_output( 281 { rm(B); gc() }, 282 "An AC was just deleted.*A BC was just deleted" 283 ) 284}) 285 286 287test_that("Finalizers and two levels of inheritance, portable", { 288 AC <- R6Class( 289 "AC", 290 public = list( 291 finalize = function() cat("An AC was just deleted\n") 292 ) 293 ) 294 295 BC <- R6Class( 296 "BC", 297 inherit = AC, 298 public = list( 299 finalize = function() { 300 super$finalize() 301 cat("A BC was just deleted\n") 302 } 303 ) 304 ) 305 306 CC <- R6Class( 307 "CC", 308 inherit = BC, 309 public = list( 310 finalize = function() { 311 super$finalize() 312 cat("A CC was just deleted\n") 313 } 314 ) 315 ) 316 317 C <- CC$new() 318 expect_output( 319 { rm(C); gc() }, 320 "An AC was just deleted.*A BC was just deleted.*A CC was just deleted" 321 ) 322}) 323 324test_that("Finalizers and two levels of inheritance, non-portable", { 325 AC <- R6Class( 326 "AC", 327 public = list( 328 finalize = function() cat("An AC was just deleted\n") 329 ), 330 portable = FALSE 331 ) 332 333 BC <- R6Class( 334 "BC", 335 inherit = AC, 336 public = list( 337 finalize = function() { 338 super$finalize() 339 cat("A BC was just deleted\n") 340 } 341 ), 342 portable = FALSE 343 ) 344 345 CC <- R6Class( 346 "CC", 347 inherit = BC, 348 public = list( 349 finalize = function() { 350 super$finalize() 351 cat("A CC was just deleted\n") 352 } 353 ), 354 portable = FALSE 355 ) 356 357 C <- CC$new() 358 expect_output( 359 { rm(C); gc() }, 360 "An AC was just deleted.*A BC was just deleted.*A CC was just deleted" 361 ) 362}) 363 364 365# Issue #121 366test_that("Finalizer method does not prevent GC of objects passed to initialize", { 367 a_gc <- 0 368 A <- R6Class( 369 "A", 370 public = list( 371 initialize = function(x) { 372 force(x) # Need to eval x 373 }, 374 finalize = function(e) { 375 a_gc <<- a_gc + 1 376 } 377 ) 378 ) 379 380 x_gc <- 0 381 x <- new.env(parent = emptyenv()) 382 reg.finalizer(x, function(e) { x_gc <<- x_gc + 1 }) 383 384 # Pass x to A's initialize method 385 a <- A$new(x) 386 387 rm(x) 388 gc() 389 expect_identical(x_gc, 1) # This is the key test: x should be GC'd 390 391 rm(a) 392 gc() 393 expect_identical(a_gc, 1) 394 395 396 # Same test, but with clone 397 a_gc <- 0 398 x_gc <- 0 399 x <- new.env(parent = emptyenv()) 400 reg.finalizer(x, function(e) { x_gc <<- x_gc + 1 }) 401 402 # Pass x to A's initialize method 403 a <- A$new(x) 404 b <- a$clone() 405 406 rm(x) 407 gc() 408 expect_identical(x_gc, 1) # This is the key test: x should be GC'd 409 410 rm(a) 411 gc() 412 expect_identical(a_gc, 1) 413 rm(b) 414 gc() 415 expect_identical(a_gc, 2) 416 417 expect_identical(x_gc, 1) # Make sure x's finalizer hasn't somehow run again 418}) 419 420 421test_that("Private finalizers work", { 422 sum <- 0 423 C1 <- R6Class("C1", 424 public = list( 425 x = 1 426 ), 427 private = list( 428 finalize = function() sum <<- sum + self$x 429 ) 430 ) 431 432 a <- C1$new() 433 rm(a) 434 gc() 435 expect_identical(sum, 1) 436}) 437