Re: Object index patch (was: Class::DBI 1.00 (almost))

[prev] [thread] [next] [Date index for 2005/06/22]

--=-fQM5KMvtKSdKWgcBrEsm
Content-Type: text/plain
Content-Transfer-Encoding: 7bit

Here's an updated version of the patch which documents the key-
generation method and standardizes the language on "object index" rather
than "live objects."  There is no modified functionality from the last
version I sent.

- Perrin

--=-fQM5KMvtKSdKWgcBrEsm
Content-Disposition: attachment; filename=cdbi999.patch
Content-Type: text/x-patch; name=cdbi999.patch; charset=UTF-8
Content-Transfer-Encoding: 7bit

Only in .: blib
diff -ur /home/perrin/Desktop/Class-DBI-0.999/lib/Class/DBI.pm ./lib/Class/DBI.pm
--- /home/perrin/Desktop/Class-DBI-0.999/lib/Class/DBI.pm	2005-06-18 09:26:00.000000000 -0400
+++ ./lib/Class/DBI.pm	2005-06-22 00:05:06.000000000 -0400
@@ -20,17 +20,16 @@
 use List::Util;
 use UNIVERSAL::moniker;
 
-use vars qw($Weaken_Is_Available);
+our $Use_Object_Index = 1;
+our %Object_Index;
+our $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
@@ -471,37 +470,80 @@
 }
 
 #----------------------------------------------------------------------
-# 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.
+	my ($obj, $key);
+	if ($Use_Object_Index) {
+		$key = $class->object_index_key($data || {});
+		$obj = $class->fetch_from_object_index($key);
+	}
+	if (!defined $obj) {
+	    $obj = $class->_fresh_init($data);
+		if ($Use_Object_Index) {
+			$class->store_in_object_index($obj, $key);
+		}
+	}
+	return $obj;
 }
 
 sub _fresh_init {
-	my ($class, $key, $data) = @_;
+	my ($class, $data) = @_;
 	my $obj = bless {}, $class;
 	$obj->_attribute_store(%$data);
+	return $obj;
+}
+
+#----------------------------------------------------------------------
+# Object Index (using weak refs if available)
+#----------------------------------------------------------------------
 
-	# 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;
+my $_store_in_object_index_count = 0;
+
+sub use_object_index {
+    my ($class, $value) = @_;
+    if ($class ne __PACKAGE__) {
+		$class->_croak('use_object_index is a global setting and can only' .
+			' be called on Class::DBI directly.');
 	}
-	return $obj;
+    if (defined $value) {
+		$Use_Object_Index = $value;
+    }
+    return $Use_Object_Index;
+}
+
+sub fetch_from_object_index {
+	my ($class, $key) = @_;
+	return ($Object_Index{$class}{$key});
 }
 
-sub _live_object_key {
+sub store_in_object_index {
+	my ($class, $obj, $key) = @_;
+	return unless $key and $Weaken_Is_Available;
+	weaken($Object_Index{$class}{$key} = $obj);
+	# time to clean up your room?
+	$class->purge_dead_from_object_index
+		if ++$_store_in_object_index_count % $class->purge_object_index_every == 0;
+}
+
+sub _object_index {
+	my ($self) = @_;
+	my $class  = ref($self) || $self;
+	return \%Object_Index if $class eq "Class::DBI";
+	return $Object_Index{$class};
+}
+
+sub object_index_key {
 	my ($me, $data) = @_;
+	# Return key to use for this object in the object index.
+	# Key string must uniquely and permenantly identify the object.
+	# Return empty string if object doesn't have full indentity yet.
 	my $class   = ref($me) || $me;
 	my @primary = $class->primary_columns;
 
@@ -513,17 +555,23 @@
 }
 
 sub purge_dead_from_object_index {
-	delete @Live_Objects{ grep !defined $Live_Objects{$_}, keys %Live_Objects };
+	while ( my ($class, $lo) = each %Object_Index ) {
+		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->_as_hash });
-	delete $Live_Objects{$obj_key};
+	my $class   = ref $self or return;
+	my $obj_key = $class->object_index_key({ $self->_as_hash });
+	delete $Object_Index{$class}{$obj_key};
 }
 
 sub clear_object_index {
-	%Live_Objects = ();
+	my $lo = shift->_object_index(@_)
+		or return;
+	%$lo = ();
 }
 
 #----------------------------------------------------------------------
@@ -569,6 +617,12 @@
 	my @discard_columns = grep !exists $primary_columns{$_}, keys %$real;
 	$self->call_trigger('create', discard_columns => \@discard_columns);   # XXX
 
+	# now that we have a complete primary key, add this to the object index
+	if ($Use_Object_Index) {
+		my $key = $class->object_index_key({ $self->_as_hash });
+		$class->store_in_object_index($self, $key);
+	}
+	
 	# Empty everything back out again!
 	$self->_attribute_delete(@discard_columns);
 	$self->call_trigger('after_create');
@@ -2796,12 +2850,13 @@
 Now $artist1, $artist2, and $artist3 all point to the same object. If you
 update a property on one of them, all of them will reflect the update.
 
-This is implemented using a simple object lookup index for all live
-objects in memory. It is not a traditional cache - when your objects
+This is implemented using a simple object lookup index for all objects 
+in memory. It is not a traditional cache - when your objects
 go out of scope, they will be destroyed normally, and a future retrieve
-will instantiate an entirely new object.
+will instantiate an entirely new object.  (Although see below for information
+on how to change this behavior in your subclasses.)
 
-The ability to perform this magic for you replies on your perl having
+The ability to perform this magic for you relies on your perl having
 access to the Scalar::Util::weaken function. Although this is part of
 the core perl distribution, some vendors do not compile support for it.
 To find out if your perl has support for it, you can run this on the
@@ -2810,19 +2865,27 @@
 	perl -e 'use Scalar::Util qw(weaken)'
 
 If you get an error message about weak references not being implemented,
-Class::DBI will not maintain this lookup index, but give you a separate
-instances for each retrieve.
+Class::DBI will skip the index and fall back to giving you a separate
+instance each time you call retrieve.
 
 A few new tools are offered for adjusting the behavior of the object
 index. These are still somewhat experimental and may change in a
 future release.
 
+=head2 use_object_index
+
+	Class::DBI->use_object_index(0);
+
+This class method is a switch to globally turn the object index feature 
+on or off.  It affects all Class::DBI classes, and can only be called on 
+C<Class::DBI> itself, as a reminder of the global effect.
+
 =head2 remove_from_object_index
 
 	$artist->remove_from_object_index();
 
-This is an object method for removing a single object from the live
-objects index. You can use this if you want to have multiple distinct
+This is an object method for removing a single object from the object 
+index. You can use this if you want to have multiple distinct
 copies of the same object in memory.
 
 =head2 clear_object_index
@@ -2845,6 +2908,32 @@
 
 (Eventually this may handled in the DESTROY method instead.)
 
+You may also change the behavior of the object index through overriding 
+methods in your subclass.  In this way, you can replace the normal weak-
+reference index with an actual cache, or disable the index on a per-class 
+basis.  The methods to override are as follows:
+
+=head2 fetch_from_object_index($key)
+
+This class method is called to retrieve an object from the object index. 
+It gets passed a key and should return the object in the index associated 
+with that key, if any.
+
+=head2 store_in_object_index($object, $key)
+
+Also a class method, this one gets passed an object to store and a key to 
+associated it with.
+
+In addition, you may override the method that generates the key used to 
+uniquely identify objects, although this should not typically be necessary. 
+
+=head2 object_index_key
+
+This class method accepts a reference to a hash of column names and values 
+and returns a scalar that uniquely and permanently identifies the object. 
+If the object's primary key is not fully supplied in the hash of data, this 
+method should return undef.
+
 As a final note, keep in mind that you can still have multiple distinct
 copies of an object in memory if you have multiple perl interpreters
 running. CGI, mod_perl, and many other common usage situations run
Only in ./lib/Class: DBI.pm~
Only in ./lib/Class: DBI.pm.orig
Only in ./lib/Class: DBI.pm.rej
Only in .: Makefile
Only in .: pm_to_blib
diff -ur /home/perrin/Desktop/Class-DBI-0.999/t/02-Film.t ./t/02-Film.t
--- /home/perrin/Desktop/Class-DBI-0.999/t/02-Film.t	2005-06-18 05:53:10.000000000 -0400
+++ ./t/02-Film.t	2005-06-22 00:10:19.000000000 -0400
@@ -4,7 +4,7 @@
 
 BEGIN {
 	eval "use DBD::SQLite";
-	plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 93);
+	plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 97);
 }
 
 INIT {
@@ -344,7 +344,7 @@
 }
 
 SKIP: {
-	skip "Scalar::Util::weaken not available", 3
+	skip "Scalar::Util::weaken not available", 7
 		if !$Class::DBI::Weaken_Is_Available;
 
 	# my bad taste is your bad taste
@@ -362,4 +362,31 @@
 	my $btaste4 = Film->retrieve('Bad Taste');
 	isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste4),
 		"Clearing cache and retrieving again gives new object";
+
+	Class::DBI->use_object_index(0);
+	my $btaste5 = Film->retrieve('Bad Taste');
+	isnt Scalar::Util::refaddr($btaste4), Scalar::Util::refaddr($btaste5),
+		"use_object_index(0) disables index";
+	Class::DBI->use_object_index(1);
+	
+	# define subclass that overrides fetch_live_object()
+	package Film::Subclass;
+	use base 'Film';
+	sub fetch_from_object_index {}
+	sub store_in_object_index {}
+	
+	package main;
+	my $btaste6 = Film::Subclass->retrieve('Bad Taste');
+	my $btaste7 = Film::Subclass->retrieve('Bad Taste');
+	isnt Scalar::Util::refaddr($btaste6), Scalar::Util::refaddr($btaste7),
+		"overriding object methods affects subclass";
+	
+	my $btaste8 = Film->retrieve('Bad Taste');
+	is Scalar::Util::refaddr($btaste4), Scalar::Util::refaddr($btaste8),
+		"other classes are unaffected by override";
+
+	my $doomed = Film->create({ title => 'Doomed' });
+	$doomed->delete;
+	eval { my $revive = Film->create({ title => 'Doomed' }); };
+	ok (!$@, "no error recreating deleted object while still in scope");
 }
Only in ./t: 02-Film.t~
Only in ./t: 02-Film.t.orig
Only in ./t: 02-Film.t.rej

--=-fQM5KMvtKSdKWgcBrEsm--