Re: Class::DBI 1.00 (almost)

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

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

Here's the patch.  This started with some changes from Tim, and then I
modified it to make subclassing easier and put in some contributed tests
and ideas from others on the list.

The only bit I feel unsure about is the addition to the _create()
method.  This handles the problem reported by Jason Galea that tables
with an autoincrement key were not getting put into the object index on
create().  I'd appreciate it if you could look at that part and see if
it seems like the right way to solve the issue.

Changelog for this patch:

- Add easy switch for turning off object index. (Perrin)
- Change object index to keep data for each class in separate hashes.
(Tim)
- Provide easy override hooks for changing object index behavior. (Tim,
Perrin)
- Fix object index bug where create() does not add objects with
autoincrement columns to the index. (Perrin)
- Documentation of new object index methods and overrides. (Perrin)
- Test for delete() removing the object from the index. (nazareth@eye-
of-newt.com)

Let me know if you have any questions about it.

- Perrin

--=-4XoLPAyfPaD4a1v1PMEO
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-18 21:48:51.000000000 -0400
@@ -20,17 +20,16 @@
 use List::Util;
 use UNIVERSAL::moniker;
 
-use vars qw($Weaken_Is_Available);
+our $Use_Object_Index = 1;
+our %Live_Objects;
+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->_live_object_key($data || {});
+		$obj = $class->live_object_fetch($key);
+	}
+	if (!defined $obj) {
+	    $obj = $class->_fresh_init($data);
+		if ($Use_Object_Index) {
+			$class->live_object_store($obj, $key);
+		}
+	}
+	return $obj;
 }
 
 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_object_store_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.');
+	}
+    if (defined $value) {
+		$Use_Object_Index = $value;
+    }
+    return $Use_Object_Index;
+}
+
+sub live_object_fetch {
+	my ($class, $key) = @_;
+	return ($Live_Objects{$class}{$key});
+}
+
+sub live_object_store {
+	my ($class, $obj, $key) = @_;
+	return unless $key and $Weaken_Is_Available;
+	weaken($Live_Objects{$class}{$key} = $obj);
+	# 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_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.
 	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 %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->_as_hash });
-	delete $Live_Objects{$obj_key};
+	my $class   = ref $self or return;
+	my $obj_key = $class->_live_object_key({ $self->_as_hash });
+	delete $Live_Objects{$class}{$obj_key};
 }
 
 sub clear_object_index {
-	%Live_Objects = ();
+	my $lo = shift->_live_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->_live_object_key({ $self->_as_hash });
+		$class->live_object_store($self, $key);
+	}
+	
 	# Empty everything back out again!
 	$self->_attribute_delete(@discard_columns);
 	$self->call_trigger('after_create');
@@ -2799,9 +2853,10 @@
 This is implemented using a simple object lookup index for all live
 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,13 +2865,21 @@
 	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();
@@ -2845,6 +2908,22 @@
 
 (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 live_object_fetch($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 live_object_store($object, $key)
+
+Also a class method, this one gets passed an object to store and a key to 
+associated it with.
+
 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-18 21:58:40.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 live_object_fetch {}
+	sub live_object_store {}
+	
+	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

--=-4XoLPAyfPaD4a1v1PMEO--