/usr/share/perl5/UR/Context/AutoUnloadPool.pm is in libur-perl 0.440-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 | package UR::Context::AutoUnloadPool;
use strict;
use warnings;
require UR;
our $VERSION = "0.44"; # UR $VERSION
use Scalar::Util qw();
# These are plain Perl objects that get garbage collected in the normal way,
# not UR::Objects
our @CARP_NOT = qw( UR::Context );
sub create {
my $class = shift;
my $self = bless { pool => {} }, $class;
$self->_attach_observer();
return $self;
}
sub delete {
my $self = shift;
delete $self->{pool};
$self->_detach_observer();
}
sub _attach_observer {
my $self = shift;
Scalar::Util::weaken($self);
my $o = UR::Object->add_observer(
aspect => 'load',
callback => sub {
my $loaded = shift;
return if ! $loaded->is_prunable();
$self->_object_was_loaded($loaded);
}
);
$self->{observer} = $o;
}
sub _detach_observer {
my $self = shift;
delete($self->{observer})->delete();
}
sub _is_printing_debug {
$ENV{UR_DEBUG_OBJECT_PRUNING} || $ENV{'UR_DEBUG_OBJECT_RELEASE'};
}
sub _object_was_loaded {
my($self, $o) = @_;
if (_is_printing_debug()) {
my($class, $id) = ($o->class, $o->id);
print STDERR Carp::shortmess("MEM AUTORELEASE $class id $id loaded in pool $self\n");
}
$self->{pool}->{$o->class}->{$o->id} = undef;
}
sub _unload_objects {
my $self = shift;
return unless $self->{pool};
print STDERR Carp::shortmess("MEM AUTORELEASE pool $self draining\n") if _is_printing_debug();
my @unload_exceptions;
foreach my $class_name ( keys %{$self->{pool}} ) {
print STDERR "MEM AUTORELEASE class $class_name: " if _is_printing_debug();
my $is_subsequent_obj;
my $objs_for_class = $UR::Context::all_objects_loaded->{$class_name};
next unless $objs_for_class;
foreach ( @$objs_for_class{ keys %{$self->{pool}->{$class_name}}} ) {
next unless $_;
print STDERR ($is_subsequent_obj++ ? ", " : ''), $_->id,"\n" if _is_printing_debug();
unless (eval { $_->unload(); 1; } ) {
push @unload_exceptions, $@;
}
}
print STDERR "\n" if _is_printing_debug();
}
delete $self->{pool};
die join("\n", 'The following exceptions happened while unloading:', @unload_exceptions) if @unload_exceptions;
}
sub DESTROY {
local $@;
my $self = shift;
return unless ($self->{pool});
$self->_detach_observer();
$self->_unload_objects();
}
1;
=pod
=head1 NAME
UR::Context::AutoUnloadPool - Automatically unload objects when scope ends
=head1 SYNOPSIS
my $not_unloaded = Some::Class->get(...);
do {
my $guard = UR::Context::AutoUnloadPool->create();
my $object = Some::Class->get(...); # load an object from the database
... # load more things
}; # $guard goes out of scope - unloads objects
=head1 DESCRIPTION
UR Objects retrieved from the database normally live in the object cache for
the life of the program. When a UR::Context::AutoUnloadPool is instantiated,
it tracks every object loaded during its life. The Pool's destructor calls
unload() on those objects.
Changed objects and objects loaded before before the Pool is created will not
get unloaded.
=head1 METHODS
=over 4
=item create
my $guard = UR::Context::AutoUnloadPool->create();
Creates a Pool object. All UR Objects loaded from the database during this
object's lifetime will get unloaded when the Pool goes out of scope.
=item delete
$guard->delete();
Invalidates the Pool object. No objects are unloaded. When the Pool later
goes out of scope, no objects will be unloaded.
=back
=head1 SEE ALSO
UR::Object, UR::Context
=cut
|