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