Re: mod_perl and global %Live_Objects not being initialized

[prev] [thread] [next] [Date index for 2005/02/14]

I've not had time to persue this. Would anyone (Perrin?) like to
finish it up?

Tim.

On Fri, Nov 19, 2004 at 01:47:38PM +0000, Tim Bunce wrote:
> On Wed, Nov 17, 2004 at 04:52:06PM +0000, Tony Bowden wrote:
> > On Wed, Nov 17, 2004 at 03:42:11PM +0000, Tim Bunce wrote:
> 
> I've appended a draft patch. Let me know if you're happy with the
> general direction and I'll polish it up with docs and tests etc.
> 
> Key points are:
> 
> 1. The 'live object index' concept is better encapsulated now.
> 2. The %Live_Object hash is now two-level ($class as first level).
> 3. A class can ask for access to its live object index (for dumping/debugging)
> 4. The _live_object_fetch() method called by _init() can now
>    be overridden to implement a wider variety of policies,
>    including full caching, LRU, age-based etc etc.
> 
> Tim.
> 
> diff -u -r Class-DBI-0.96_50/lib/Class/DBI.pm Class-DBI-0.96_50-liveobj/lib/Class/DBI.pm
> --- Class-DBI-0.96_50/lib/Class/DBI.pm	Wed Nov 17 11:41:13 2004
> +++ Class-DBI-0.96_50-liveobj/lib/Class/DBI.pm	Fri Nov 19 13:26:51 2004
> @@ -23,14 +23,11 @@
>  use vars qw($Weaken_Is_Available);
>  
>  BEGIN {
> -	$Weaken_Is_Available = 1;
> -	eval {
> +	$Weaken_Is_Available = eval {
>  		require Scalar::Util;
>  		import Scalar::Util qw(weaken);
> +		1;
>  	};
> -	if ($@) {
> -		$Weaken_Is_Available = 0;
> -	}
>  }
>  
>  use overload
> @@ -499,37 +496,45 @@
>  }
>  
>  #----------------------------------------------------------------------
> -# Live Object Index (using weak refs if available)
> +# Object creation
>  #----------------------------------------------------------------------
>  
> -my %Live_Objects;
> -my $Init_Count = 0;
> -
>  sub _init {
> -	my $class = shift;
> -	my $data  = shift || {};
> -	my $key   = $class->_live_object_key($data);
> -	return $Live_Objects{$key} || $class->_fresh_init($key => $data);
> +	my ($class, $data) = @_;
> +	# give index/caching mechanism being used by this class the
> +	# responsibility to get the object so it can, for example,
> +	# use a) no index, b) standard weakref based index (the default),
> +	# c) non-weakref based "cache" (including LRU or age limited) etc.
> +	return $class->_live_object_fetch($data || {}, 1);
>  }
>  
>  sub _fresh_init {
> -	my ($class, $key, $data) = @_;
> +	my ($class, $data) = @_;
>  	my $obj = bless {}, $class;
>  	$obj->_attribute_store(%$data);
> -
> -	# don't store it unless all keys are present
> -	if ($key && $Weaken_Is_Available) {
> -		weaken($Live_Objects{$key} = $obj);
> -
> -		# time to clean up your room?
> -		$class->purge_dead_from_object_index
> -			if ++$Init_Count % $class->purge_object_index_every == 0;
> -	}
>  	return $obj;
>  }
>  
> +#----------------------------------------------------------------------
> +# Live Object Index (using weak refs if available)
> +#----------------------------------------------------------------------
> +
> +my %Live_Objects;
> +my $_live_object_store_count = 0;
> +
> +sub _live_object_index {
> +	my ($self) = @_;
> +	my $class  = ref($self) || $self;
> +	return \%Live_Objects if $class eq "Class::DBI";
> +	return $Live_Objects{$class};
> +}
> +
>  sub _live_object_key {
>  	my ($me, $data) = @_;
> +	# Return key to use for this object in the live object index.
> +	# Key string must uniquely and permenantly identify the object.
> +	# Return empty string if object doesn't have full indentity yet.
> +	# Subclass can use "sub _live_object_key { '' }" to disable.
>  	my $class   = ref($me) || $me;
>  	my @primary = $class->primary_columns;
>  
> @@ -540,18 +545,44 @@
>  	return join "\030", $class, map $_ . "\032" . $data->{$_}, sort @primary;
>  }
>  
> +sub _live_object_store {
> +	my ($self, $key) = @_;
> +	return unless $key && $Weaken_Is_Available;
> +	my $class = ref $self;
> +	weaken($Live_Objects{$class}{$key} = $self);
> +	# time to clean up your room?
> +	$class->purge_dead_from_object_index
> +		if ++$_live_object_store_count % $class->purge_object_index_every == 0;
> +}
> +
> +sub _live_object_fetch {
> +	my ($class, $data, $vivify) = @_;
> +	my $key = $class->_live_object_key($data);
> +	my $obj = $Live_Objects{$class}{$key};
> +	return $obj if $obj or !$vivify;
> +	$obj = $class->_fresh_init($data);
> +	$obj->_live_object_store($key);
> +	return $obj;
> +}
> +
>  sub purge_dead_from_object_index {
> -	delete @Live_Objects{ grep !defined $Live_Objects{$_}, keys %Live_Objects };
> +	while ( my ($class, $lo) = each %Live_Objects ) {
> +		my @dead_keys = grep {!defined $lo->{$_} } keys %$lo;
> +		delete @{$lo}{ @dead_keys };
> +	}
>  }
>  
>  sub remove_from_object_index {
>  	my $self    = shift;
> -	my $obj_key = $self->_live_object_key($self->{_DATA});
> -	delete $Live_Objects{$obj_key};
> +	my $class   = ref $self or return;
> +	my $obj_key = $class->_live_object_key($self->{_DATA});
> +	delete $Live_Objects{$class}{$obj_key};
>  }
>  
>  sub clear_object_index {
> -	%Live_Objects = ();
> +	my $lo = shift->_live_object_index(@_)
> +		or return;
> +	%$lo = ();
>  }
>  
>  sub _prepopulate_id {