Re: mod_perl and global %Live_Objects not being initialized

[prev] [thread] [next] [Date index for 2004/11/19]

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 get lots of these errors from the test suite: dbih_setup_fbav:
> > invalid number of fields: 0, NUM_OF_FIELDS attribute probably not set
> > right at .../DBIx/ContextualFetch.pm line 88.
> 
> Oooh. Interesting.
> 
> > That execute()s fine but it seems the driver doesn't think it's
> > a SELECT-like statement and so hasn't setup the NUM_OF_FIELDS attribute.
> > I'm using DBD::SQLite 0.25. Looks like the test code doesn't check
> > the DBD::SQLite version. Should it? Do I need to upgrade?
> 
> Not sure. I haven't come across this.
> 
> I'm on 0.31, so I'm quite far behind as well.

Upgrading to DBD::SQLite 0.31 fixes it.

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 {