Re: mod_perl and global %Live_Objects not being initialized

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

--jI8keyz6grp/JLjh
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline

On Tue, Nov 16, 2004 at 05:44:37PM +0000, Tim Bunce wrote:
> 
> The rest of the patch was about making retrieve() use the object index.
> I've attached the patches.

[Sigh] Attached.

Tim.

--jI8keyz6grp/JLjh
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="Class-DBI-0.96-live_object_key.patch"

Only in Class-DBI-0.96-live_object_key: Makefile
Only in Class-DBI-0.96-live_object_key: blib
diff -u -r Class-DBI-0.96.orig/lib/Class/DBI.pm Class-DBI-0.96-live_object_key/lib/Class/DBI.pm
--- Class-DBI-0.96.orig/lib/Class/DBI.pm	Fri Apr 30 08:22:12 2004
+++ Class-DBI-0.96-live_object_key/lib/Class/DBI.pm	Fri Jun 25 11:08:50 2004
@@ -509,19 +509,23 @@
 my %Live_Objects;
 my $Init_Count = 0;
 
+sub _live_object_key {
+	my ($class, $data) = @_;
+	my @primary_columns = $class->primary_columns;
+
+	# no key unless all PK columns are defined
+	return "" unless @primary_columns == grep defined $data->{$_}, @primary_columns;
+
+	# create single unique key for this object
+	return join "\030", ref($class)||$class, map { $_ . "\032" . $data->{$_} }
+		       sort @primary_columns;
+}
+
 sub _init {
 	my $class = shift;
 	my $data = shift || {};
 	my $obj;
-	my $obj_key = "";
-
-	my @primary_columns = $class->primary_columns;
-	if (@primary_columns == grep defined, @{$data}{@primary_columns}) {
-
-		# create single unique key for this object
-		$obj_key = join "|", $class, map { $_ . '=' . $data->{$_} }
-			sort @primary_columns;
-	}
+	my $obj_key = $class->_live_object_key($data);
 
 	unless (defined($obj = $Live_Objects{$obj_key})) {
 
@@ -548,11 +552,7 @@
 
 sub remove_from_object_index {
 	my $self            = shift;
-	my @primary_columns = $self->primary_columns;
-	my %data;
-	@data{@primary_columns} = $self->get(@primary_columns);
-	my $obj_key = join "|", ref $self, map $_ . '=' . $data{$_},
-		sort @primary_columns;
+	my $obj_key = $self->_live_object_key($self);
 	delete $Live_Objects{$obj_key};
 }
 
Only in Class-DBI-0.96-live_object_key: pm_to_blib

--jI8keyz6grp/JLjh
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="Class-DBI-0.96-search-from-cache.patch"

Only in Class-DBI-0.96-live_object_key: Makefile
Only in Class-DBI-0.96: Makefile.old
Only in Class-DBI-0.96-live_object_key: blib
diff -u -r Class-DBI-0.96-live_object_key/lib/Class/DBI/Relationship.pm Class-DBI-0.96/lib/Class/DBI/Relationship.pm
--- Class-DBI-0.96-live_object_key/lib/Class/DBI/Relationship.pm	Sun Apr 25 16:33:36 2004
+++ Class-DBI-0.96/lib/Class/DBI/Relationship.pm	Thu Jun 24 11:24:34 2004
@@ -20,6 +20,7 @@
 	my $proto = shift;
 	my $name  = shift;
 	my ($class, $accessor, $foreign_class, $args) = $proto->remap_arguments(@_);
+	$class->clear_object_index;
 	return $proto->new({
 			name          => $name,
 			class         => $class,
diff -u -r Class-DBI-0.96-live_object_key/lib/Class/DBI.pm Class-DBI-0.96/lib/Class/DBI.pm
--- Class-DBI-0.96-live_object_key/lib/Class/DBI.pm	Fri Jun 25 11:08:50 2004
+++ Class-DBI-0.96/lib/Class/DBI.pm	Fri Jun 25 11:07:54 2004
@@ -661,23 +661,29 @@
 }
 
 sub retrieve {
-	my $class           = shift;
+	my $class = shift;
+	my @args  = @_;
 	my @primary_columns = $class->primary_columns
 		or return $class->_croak(
 		"Can't retrieve unless primary columns are defined");
-	my %key_value;
-	if (@_ == 1 && @primary_columns == 1) {
-		my $id = shift;
-		return unless defined $id;
-		return $class->_croak("Can't retrieve a reference") if ref($id);
-		$key_value{ $primary_columns[0] } = $id;
-	} else {
-		%key_value = @_;
-		$class->_croak(
-			"$class->retrieve(@_) parameters don't include values for all primary key columns (@primary_columns)"
-			)
-			if keys %key_value < @primary_columns;
+
+	if (@args == 1 && @primary_columns == 1) {
+		my $id = shift @args;
+		return $class->_croak("Can't retrieve a reference")
+			if ref $id and !UNIVERSAL::isa($id => 'Class::DBI');
+		@args = ($primary_columns[0] => $id)
+	}
+
+	my %key_value = @args;
+	while (my ($col, $val) = splice @args, 0, 2) { # as per _do_search:
+		my $column = $class->find_column($col)
+			|| (List::Util::first { $_->accessor eq $col } $class->columns)
+			|| $class->_croak("$col is not a column of $class");
+		$key_value{$column} = $val; # search() deflate for us
 	}
+	$class->_croak("$class->retrieve(@_) parameters don't include defined values for all primary key columns (@primary_columns)")
+		unless @primary_columns == grep defined, @key_value{@primary_columns};
+
 	my @rows = $class->search(%key_value);
 	$class->_carp("$class->retrieve(@_) selected " . @rows . " rows")
 		if @rows > 1;
@@ -737,6 +743,7 @@
 sub delete {
 	my $self = shift;
 	return $self->_search_delete(@_) if not ref $self;
+	$self->remove_from_object_index;
 	$self->call_trigger('before_delete');
 
 	eval { $self->sql_DeleteMe->execute($self->id) };
@@ -1075,23 +1082,43 @@
 	my $class = ref $proto || $proto;
 
 	@args = %{ $args[0] } if ref $args[0] eq "HASH";
-	my (@cols, @vals);
 	my $search_opts = @args % 2 ? pop @args : {};
+	my %search_for;
 	while (my ($col, $val) = splice @args, 0, 2) {
 		my $column = $class->find_column($col)
 			|| (List::Util::first { $_->accessor eq $col } $class->columns)
 			|| $class->_croak("$col is not a column of $class");
-		push @cols, $column;
-		push @vals, $class->_deflated_column($column, $val);
+		$search_for{$column} = $class->_deflated_column($column, $val);
 	}
 
-	my $frag = join " AND ",
-		map defined($vals[$_]) ? "$cols[$_] $search_type ?" : "$cols[$_] IS NULL",
-		0 .. $#cols;
+	# if we're searching using "=" and we have all the PK fields
+	# then we can bypass the db search if the object is already cached
+	# and all the searched-for field values match. If any don't match,
+	# or don't exist in the cached object, then we fall through and db search.
+	if ($search_type eq "=" and my $obj_key = $class->_live_object_key(\%search_for)) {
+		my $obj = $Live_Objects{$obj_key};
+		# do we have a cached object that also matches the search criteria?
+		# for now we use the cached object only if the PK was the only search criteria
+		# (wouldn't be hard to add more through check of %search_for values)
+		my @primary_columns = $class->primary_columns;
+		return $obj if defined $obj and keys %search_for == @primary_columns;
+	}
+
+	my (@qual, @bind);
+	for my $column (sort keys %search_for) { # canonical order (for prepare_cached)
+	    if (defined(my $value = $search_for{$column})) {
+		push @qual, "$column $search_type ?";
+		push @bind, $value;
+	    }
+	    else {
+		# perhaps _carp if $search_type ne "="
+		push @qual, "$column IS NULL";
+	    }
+	}
+	my $frag = join " AND ", @qual;
 	$frag .= " ORDER BY $search_opts->{order_by}"
 		if $search_opts->{order_by};
-	return $class->sth_to_objects($class->sql_Retrieve($frag),
-		[ grep defined, @vals ]);
+	return $class->sth_to_objects($class->sql_Retrieve($frag), \@bind);
 
 }
 
Only in Class-DBI-0.96-live_object_key: pm_to_blib
Only in Class-DBI-0.96: x

--jI8keyz6grp/JLjh--