Facilities for dealing with leaks to LiveObjects

    - clear_leaks flag which prevents stale data from polluting
      subsequent lookups() (doesn't actually reclaim memory)

    - leak_tracker hook for dealing with or reporting such leaks

lib/KiokuDB/LiveObjects.pm

@@ -15,6 +15,17 @@ use KiokuDB::LiveObjects::TXNScope;
 
 use namespace::clean -except => 'meta';
 
+has clear_leaks => (
+    isa => "Bool",
+    is  => "rw",
+);
+
+has leak_tracker => (
+    isa => "CodeRef|Object",
+    is  => "rw",
+    clearer => "clear_leak_tracker",
+);
+
 has _objects => (
     isa => "HashRef",
     is  => "ro",
@@ -99,6 +110,53 @@ has current_scope => (
     weak_ref => 1,
 );
 
+has _known_scopes => (
+    isa => "Set::Object",
+    is  => "ro",
+    default => sub { Set::Object::Weak->new },
+);
+
+sub detach_scope {
+    my ( $self, $scope ) = @_;
+
+    my $current_scope = $self->current_scope;
+    if ( defined($current_scope) and refaddr($current_scope) == refaddr($scope) ) {
+        if ( my $parent = $scope->parent ) {
+            $self->_set_current_scope($parent);
+        } else {
+            $self->_clear_current_scope;
+        }
+    }
+}
+
+sub remove_scope {
+    my ( $self, $scope ) = @_;
+
+    $self->detach_scope($scope);
+
+    $scope->clear;
+
+    my $known = $self->_known_scopes;
+
+    $known->remove($scope);
+
+    if ( $known->size == 0 ) {
+        if ( my @objects = $self->live_objects ) {
+            if ( $self->clear_leaks ) {
+                $self->clear;
+            }
+
+            if ( my $tracker = $self->leak_tracker ) {
+                if ( ref($tracker) eq 'CODE' ) {
+                    $tracker->(@objects);
+                } else {
+                    $tracker->leaked_objects(@objects);
+                }
+            }
+        }
+    }
+}
+
 has txn_scope => (
     isa => "KiokuDB::LiveObjects::TXNScope",
     is  => "ro",
@@ -119,6 +177,8 @@ sub new_scope {
 
     $self->_set_current_scope($child);
 
+    $self->_known_scopes->insert($child);
+
     return $child;
 }
 
@@ -260,6 +320,16 @@ sub remove {
     }
 }
 
+sub register_entry {
+    my ( $self, $entry, $object ) = @_;
+}
+
+sub register_id {
+    my ( $self, $id, $object ) = @_;
+
+
+}
+
 sub insert {
     my ( $self, @pairs ) = @_;
 
@@ -358,6 +428,9 @@ sub clear {
 
     %{ $self->_entry_ids } = ();
     %{ $self->_entry_objects } = ();
+
+    $self->_clear_current_scope;
+    $self->_known_scopes->clear;
 }
 
 __PACKAGE__->meta->make_immutable;
@@ -389,6 +462,44 @@ KiokuDB::LiveObjects - Live object set tracking
 This object keeps track of the set of live objects, their associated IDs, and
 the storage entries.
 
+=head1 ATTRIBUTES
+
+=over 4
+
+=item clear_leaks
+
+Boolean. Defaults to false.
+
+If true, when the last known scope is removed but some objects are still live
+they will be removed from the live object set.
+
+Note that this does B<NOT> prevent leaks (memory cannot be reclaimed), it
+merely prevents stale objects from staying loaded.
+
+=item leak_tracker
+
+This is a coderef or object.
+
+If any objects ar eleaked (see C<clear_leaks>) then the this can be used to
+report them, or to break the circular structure.
+
+When an object is provided the C<leaked_objects> method is called. The coderef
+is simply invoked with the objects as arguments.
+
+Triggered after C<clear_leaks> causes C<clear> to be called.
+
+For example, to break cycles you can use L<Data::Structure::Util>'s
+C<circular_off> function:
+
+    use Data::Structure::Util qw(circular_off);
+
+    $dir->live_objects->leak_tracker(sub {
+        my @leaked_objects = @_;
+        circular_off($_) for @leaked_objects;
+    });
+
+=back
+
 =head1 METHODS
 
 =over 4
@@ -482,6 +593,20 @@ Called by L<KiokuDB::LiveObjects::TXNScope/rollback>.
 
 Removes entries from the live object set.
 
+=item remove_scope $scope
+
+Removes a scope from the set of known scopes.
+
+Also calls C<detach_scope>, and calls C<KiokuDB::LiveObjects::Scope/clear> on
+the scope itself.
+
+=item detach_scope $scope
+
+Detaches C<$scope> if it's the current scope.
+
+This prevents C<push> from being called on this scope object implicitly
+anymore.
+
 =back
 
 =cut

lib/KiokuDB/LiveObjects/Scope.pm

@@ -6,21 +6,17 @@ use Moose;
 use namespace::clean -except => 'meta';
 
 has objects => (
+    traits => [qw(Array)],
     isa => "ArrayRef",
-    is  => "ro",
     default => sub { [] },
+    clearer => "_clear_objects",
+    handles => {
+        push => "push",
+        objects => "elements",
+        clear => "clear",
+    },
 );
 
-sub push {
-    my ( $self, @objs ) = @_;
-    push @{ $self->objects }, @objs;
-}
-
-sub clear {
-    my $self = shift;
-    @{ $self->objects } = ();
-}
-
 has parent => (
     isa => __PACKAGE__,
     is  => "ro",
@@ -29,7 +25,7 @@ has parent => (
 has live_objects => (
     isa => "KiokuDB::LiveObjects",
     is  => "ro",
-    required => 1,
+    clearer => "_clear_live_objects",
 );
 
 sub DEMOLISH {
@@ -41,16 +37,24 @@ sub DEMOLISH {
     # problems can arise from an object outliving the scope it was loaded in:
     # { my $outer = lookup(...); { my $inner = lookup(...); $outer->foo($inner) } }
 
+    $self->remove;
+}
+
+sub detach {
+    my $self = shift;
+
     if ( my $l = $self->live_objects ) {
-        if ( my $parent = $self->parent ) {
-            $l->_set_current_scope($parent);
-        } else {
-            $l->_clear_current_scope();
-        }
+        $l->detach_scope($self);
     }
+}
+
+sub remove {
+    my $self = shift;
 
-    # FIXME in debug mode detect if @{ $self->objects } = (), but said objects
-    # survive the cleanup and warn about them
+    if ( my $l = $self->live_objects ) { # can be false under global destruction
+        $l->remove_scope($self);
+        $self->_clear_live_objects;
+    }
 }
 
 __PACKAGE__->meta->make_immutable;
@@ -93,6 +97,17 @@ Adds objects or entries, increasing their reference count.
 
 Clears the objects from the scope object.
 
+=item detach
+
+Marks this scope as no longer the "current" live object scope, if it is the current one.
+
+This allows keeping branching of scopes, which can be useful under long running
+applications.
+
+=item remove
+
+Effectively kills the scope by clearing it and removing it from the live object set.
+
 =back
 
 =cut

t/live_objs.t

@@ -16,6 +16,8 @@ use ok 'KiokuDB::Entry';
 
     has bar => ( is => "rw", weak_ref => 1 );
 
+    has strong_ref => ( is => "rw" );
+
     package KiokuDB_Test_Bar;
     use Moose;
 
@@ -240,5 +242,107 @@ use ok 'KiokuDB::Entry';
     );
 }
 
+{
+    my $l = KiokuDB::LiveObjects->new;
+
+    {
+        my $s = $l->new_scope;
+
+        my $foo = KiokuDB_Test_Foo->new;
+
+        $l->insert( foo => $foo );
+
+        is_deeply( [ $l->live_objects ], [ $foo ], "live object set" );
+
+        is_deeply( [ $s->objects ], [ $foo ], "scope objects" );
+
+        $s->detach;
+
+        is( $l->current_scope, undef, "scope detached:" );
+
+        is_deeply( [ $l->live_objects ], [ $foo ], "live object set" );
+
+        is_deeply( [ $s->objects ], [ $foo ], "scope objects" );
+
+        my $s2 = $l->new_scope;
+
+        my $bar = KiokuDB_Test_Bar->new;
+
+        $l->insert( bar => $bar );
+
+        is_deeply( [ sort $l->live_objects ], [ sort $foo, $bar ], "live object set" );
+
+        is_deeply( [ $s->objects ], [ $foo ], "scope objects" );
+
+        is_deeply( [ $s2->objects ], [ $bar ], "second scope objects" );
+
+        $s->remove;
+        undef $foo;
+
+        is_deeply( [ $l->live_objects ], [ $bar ], "disjoint scope death" );
+
+        is_deeply( [ $s2->objects ], [ $bar ], "second scope objects" );
+    }
+
+    is_deeply(
+        [ $l->live_objects ],
+        [ ],
+        "live object set is now empty"
+    );
+}
+
+{
+    my $leak_tracker_called;
+
+    my $l = KiokuDB::LiveObjects->new(
+        clear_leaks => 1,
+        leak_tracker => sub {
+            $leak_tracker_called++;
+            $_->strong_ref(undef) for @_;
+        }
+    );
+
+    my $foo = KiokuDB_Test_Foo->new;
+    my $bar = KiokuDB_Test_Foo->new;
+
+    $foo->strong_ref($bar);
+    $bar->strong_ref($foo);
+
+    weaken $foo;
+    weaken $bar;
+
+    ok( defined($foo), "circular refs keep structure alive" );
+
+    {
+        my $s = $l->new_scope;
+
+        {
+            my $s2 = $l->new_scope;
+
+            $l->insert( foo => $foo );
+
+            is_deeply( [ $l->live_objects ], [ $foo ], "live object set" );
+
+            is_deeply( [ $s2->objects ], [ $foo ], "scope objects" );
+        }
+
+        is_deeply( [ $s->objects ], [ ], "no scope objects" );
+
+        my @live = $l->live_objects;
+        is( scalar(@live), 1, "circular ref still live" );
+    }
+
+    is( $l->current_scope, undef, "no current scope" );
+
+    is_deeply(
+        [ $l->live_objects ],
+        [ ],
+        "live object set is now empty"
+    );
+
+    ok( $leak_tracker_called, "leak tracker called" );
+
+    is( $foo, undef, "structure has been manually cleared" );
+}
 
 done_testing;