[Rt-commit] r5495 - in DBIx-SearchBuilder/trunk: . SearchBuilder
SearchBuilder/Record inc/Module/Install t
ruz at bestpractical.com
ruz at bestpractical.com
Fri Jun 30 08:19:10 EDT 2006
Author: ruz
Date: Fri Jun 30 08:19:05 2006
New Revision: 5495
Added:
DBIx-SearchBuilder/trunk/t/02records_cachable.t
Modified:
DBIx-SearchBuilder/trunk/ (props changed)
DBIx-SearchBuilder/trunk/Changes
DBIx-SearchBuilder/trunk/SearchBuilder/Record.pm
DBIx-SearchBuilder/trunk/SearchBuilder/Record/Cachable.pm
DBIx-SearchBuilder/trunk/inc/Module/Install.pm
DBIx-SearchBuilder/trunk/inc/Module/Install/AutoInstall.pm
DBIx-SearchBuilder/trunk/inc/Module/Install/Base.pm
DBIx-SearchBuilder/trunk/inc/Module/Install/Makefile.pm
DBIx-SearchBuilder/trunk/inc/Module/Install/Metadata.pm
DBIx-SearchBuilder/trunk/t/01records.t
DBIx-SearchBuilder/trunk/t/01searches.t
DBIx-SearchBuilder/trunk/t/02records_object.t
DBIx-SearchBuilder/trunk/t/02searches_joins.t
DBIx-SearchBuilder/trunk/t/11schema_records.t
DBIx-SearchBuilder/trunk/t/testmodels.pl
DBIx-SearchBuilder/trunk/t/utils.pl
Log:
sorry, a little bit messy change log, but svk fails
to do smerge -Il from my local branch... too
many conflicts
* LoadByCol now the same as LoadByCols
DBIx::SearchBuilder::Record::__Value
* no eval, control things via PrintError and RaiseError
* increment {fetched}{$field} before any actions,
if any error happens later in the method then most
probably subcequent calls to __Value would fail too
* use primary key hash instead of Id to check that we have PK
** return undef if any value of the pk fileds is undefined
** this adds support for compound PKs
* indent
::Record::Cachable
* don't call $self->_primary_RecordCache_key unless we need key,
$self->_store does call it
* get rid of proxy method, perl knows about inheritance
* add new lines to POD
* drop useless 'new' method from ::Record::Cachable
* return newly created cache from ::Cachable::_SetupCache
* minor refactoring of _*Cache methods
* don't create local copies of arguments
* pass throught arguments in __Delete
* return imidiatly from ::Cachable::_expire unless PK is defined
* don't even try to store things when PK is not defined (record not loaded)
Cachable::_gen_alternate_RecordCache_key
* hash keys couldn't be undefined
* use __undef for value only when value really undefined,
$value ||= '__undef' also override empty string or 0.
* when $value is hash we also should apply "__undef" logic
for $value->{value} part
* sort keys
* minor style changes
* drop unused Cachable::_fetch_RecordCache_key
::Cachable::_primary_RecordCache_key
* use $self->PrimaryKeys as source of PK
* return undef cache key if any value of PK
is not defined (record is not loaded)
::Cachable::_lookup_primary_RecordCache_key
* don't try to fetch anything from records cache, but return
alternate key back
::Cachable::_primary_RecordCache_key
* don't prefix key with table value, as we use one cache
per class this should be enought. This change is required
to make alt and primary cache keys interchangable.
** if someone think table name is required in key then
we should use it in both cache keys: alt and primary.
::Cachable::LoadByCols
* drop primary cache key earlier
* don't _fetch anything when we have no key
* add support for SB_TEST_CACHABLE env var. so we could
run tests using caching to prove that changes in caching
don't break anything
* add tests for cache
* update Changes
Modified: DBIx-SearchBuilder/trunk/Changes
==============================================================================
--- DBIx-SearchBuilder/trunk/Changes (original)
+++ DBIx-SearchBuilder/trunk/Changes Fri Jun 30 08:19:05 2006
@@ -1,5 +1,12 @@
Revision history for Perl extension DBIx::SearchBuilder.
+* cleanup ::Record::Cachable
+* use cache in:
+ $a->LoadByCols(...);
+ $b->LoadById( $a->id );
+* add cache tests
+
+
1.44
* DBIx::SearchBuilder::Handle::DatabaseVersion enhancements
Modified: DBIx-SearchBuilder/trunk/SearchBuilder/Record.pm
==============================================================================
--- DBIx-SearchBuilder/trunk/SearchBuilder/Record.pm (original)
+++ DBIx-SearchBuilder/trunk/SearchBuilder/Record.pm Fri Jun 30 08:19:05 2006
@@ -403,8 +403,7 @@
sub PrimaryKeys {
my $self = shift;
- my %hash = map { $_ => $self->{'values'}->{$_} } @{$self->_PrimaryKeys};
- return (%hash);
+ return map { $_ => $self->{'values'}->{$_} } @{$self->_PrimaryKeys};
}
@@ -700,25 +699,21 @@
sub __Value {
- my $self = shift;
- my $field = lc shift;
-
- $field = $self->_Accessible($field, "column") if $self->_Accessible($field, "column");
+ my $self = shift;
+ my $field = lc shift;
- if (!$self->{'fetched'}{$field} and my $id = $self->id() ) {
- my $pkey = $self->_PrimaryKey();
- my $QueryString = "SELECT $field FROM " . $self->Table . " WHERE $pkey = ?";
- my $sth = $self->_Handle->SimpleQuery( $QueryString, $id );
- my ($value) = eval { $sth->fetchrow_array() };
- warn $@ if $@;
+ $field = $self->_Accessible($field, "column") if $self->_Accessible($field, "column");
- $self->{'values'}{$field} = $value;
+ return $self->{'values'}{$field} if $self->{'fetched'}{$field};
$self->{'fetched'}{$field} = 1;
- }
-
- my $value = $self->{'values'}{$field};
- return $value;
+ my %pk = $self->PrimaryKeys;
+ return undef if grep !defined, values %pk;
+
+ my $query = "SELECT $field FROM ". $self->Table
+ ." WHERE ". join " AND ", map "$_ = ?", keys %pk;
+ my $sth = $self->_Handle->SimpleQuery( $query, values %pk ) or return undef;
+ return $self->{'values'}{$field} = ($sth->fetchrow_array)[0];
}
=head2 _Value
@@ -1053,9 +1048,8 @@
-sub Load {
+sub Load {
my $self = shift;
- # my ($package, $filename, $line) = caller;
return $self->LoadById(@_);
}
@@ -1068,14 +1062,9 @@
=cut
-
-
sub LoadByCol {
my $self = shift;
- my $col = shift;
- my $val = shift;
-
- return($self->LoadByCols($col => $val));
+ return $self->LoadByCols(@_);
}
@@ -1144,12 +1133,8 @@
sub LoadById {
- my $self = shift;
- my $id = shift;
-
- $id = 0 if (!defined($id));
- my $pkey = $self->_PrimaryKey();
- return ($self->LoadByCols($pkey => $id));
+ my ($self, $id) = @_;
+ return $self->LoadByCols( $self->_PrimaryKey, defined $id? $id: 0 );
}
Modified: DBIx-SearchBuilder/trunk/SearchBuilder/Record/Cachable.pm
==============================================================================
--- DBIx-SearchBuilder/trunk/SearchBuilder/Record/Cachable.pm (original)
+++ DBIx-SearchBuilder/trunk/SearchBuilder/Record/Cachable.pm Fri Jun 30 08:19:05 2006
@@ -23,9 +23,12 @@
=head1 DESCRIPTION
-This module subclasses the main DBIx::SearchBuilder::Record package to add a caching layer.
+This module subclasses the main L<DBIx::SearchBuilder::Record> package
+to add a caching layer.
-The public interface remains the same, except that records which have been loaded in the last few seconds may be reused by subsequent fetch or load methods without retrieving them from the database.
+The public interface remains the same, except that records which have
+been loaded in the last few seconds may be reused by subsequent fetch
+or load methods without retrieving them from the database.
=head1 METHODS
@@ -34,29 +37,17 @@
my %_CACHES = ();
-# Function: new
-# Type : class ctor
-# Args : see DBIx::SearchBuilder::Record::new
-# Lvalue : DBIx::SearchBuilder::Record::Cachable
-
-sub new () {
- my ( $class, @args ) = @_;
- my $self = $class->SUPER::new(@args);
-
- return ($self);
-}
-
sub _SetupCache {
- my $self = shift;
- my $cache = shift;
- $_CACHES{$cache} = Cache::Simple::TimedExpiry->new();
+ my ($self, $cache) = @_;
+ $_CACHES{$cache} = new Cache::Simple::TimedExpiry;
$_CACHES{$cache}->expire_after( $self->_CacheConfig->{'cache_for_sec'} );
+ return $_CACHES{$cache};
}
-=head2 FlushCache
+=head2 FlushCache
This class method flushes the _global_ DBIx::SearchBuilder::Record::Cachable
-cache. All caches are immediately expired.
+cache. All caches are immediately expired.
=cut
@@ -64,34 +55,28 @@
%_CACHES = ();
}
-
-sub _KeyCache {
- my $self = shift;
- my $cache = $self->_Handle->DSN . "-KEYS--" . ($self->{'_Class'} ||= ref($self));
- $self->_SetupCache($cache) unless exists ($_CACHES{$cache});
- return ($_CACHES{$cache});
-
-}
-
=head2 _FlushKeyCache
Blow away this record type's key cache
=cut
-
sub _FlushKeyCache {
my $self = shift;
- my $cache = $self->_Handle->DSN . "-KEYS--" . ($self->{'_Class'} ||= ref($self));
- $self->_SetupCache($cache);
+ my $cache = $self->_Handle->DSN . "-KEYS--" . ($self->{'_Class'} ||= ref $self);
+ return $self->_SetupCache($cache);
}
-sub _RecordCache {
+sub _KeyCache {
my $self = shift;
- my $cache = $self->_Handle->DSN . "--" . ($self->{'_Class'} ||= ref($self));
- $self->_SetupCache($cache) unless exists ($_CACHES{$cache});
- return ($_CACHES{$cache});
+ my $cache = $self->_Handle->DSN . "-KEYS--" . ($self->{'_Class'} ||= ref $self);
+ return $_CACHES{$cache}? $_CACHES{$cache}: $self->_SetupCache($cache);
+}
+sub _RecordCache {
+ my $self = shift;
+ my $cache = $self->_Handle->DSN . "--" . ($self->{'_Class'} ||= ref $self);
+ return $_CACHES{$cache}? $_CACHES{$cache}: $self->_SetupCache($cache);
}
# Function: LoadFromHash
@@ -106,12 +91,8 @@
$self->{'_SB_Record_Primary_RecordCache_key'} = undef;
my ( $rvalue, $msg ) = $self->SUPER::LoadFromHash(@_);
- my $cache_key = $self->_primary_RecordCache_key();
-
## Check the return value, if its good, cache it!
- if ($rvalue) {
- $self->_store();
- }
+ $self->_store if $rvalue;
return ( $rvalue, $msg );
}
@@ -124,26 +105,26 @@
sub LoadByCols {
my ( $self, %attr ) = @_;
- ## Generate the cache key
+ # Blow away the primary cache key since we're loading.
+ $self->{'_SB_Record_Primary_RecordCache_key'} = undef;
+
+ # generate the alternate cache key
my $alt_key = $self->_gen_alternate_RecordCache_key(%attr);
- if ( $self->_fetch( $self->_lookup_primary_RecordCache_key($alt_key) ) ) {
+ # get primary cache key
+ my $cache_key = $self->_lookup_primary_RecordCache_key($alt_key);
+ if ( $cache_key && $self->_fetch( $cache_key ) ) {
return ( 1, "Fetched from cache" );
}
- # Blow away the primary cache key since we're loading.
- $self->{'_SB_Record_Primary_RecordCache_key'} = undef;
-
- ## Fetch from the DB!
+ # Fetch from the DB!
my ( $rvalue, $msg ) = $self->SUPER::LoadByCols(%attr);
- ## Check the return value, if its good, cache it!
+ # Check the return value, if its good, cache it!
if ($rvalue) {
- ## Only cache the object if its okay to do so.
$self->_store();
+ # store alt_key as alias for pk
$self->_KeyCache->set( $alt_key, $self->_primary_RecordCache_key);
-
}
return ( $rvalue, $msg );
-
}
# Function: __Set
@@ -152,11 +133,11 @@
# Lvalue : ?
sub __Set () {
- my ( $self, %attr ) = @_;
+ my $self = shift;
- $self->_expire();
- return $self->SUPER::__Set(%attr);
+ $self->_expire;
+ return $self->SUPER::__Set( @_ );
}
# Function: Delete
@@ -165,11 +146,11 @@
# Lvalue : ?
sub __Delete () {
- my ($self) = @_;
+ my $self = shift;
- $self->_expire();
+ $self->_expire;
- return $self->SUPER::__Delete();
+ return $self->SUPER::__Delete( @_ );
}
@@ -181,10 +162,11 @@
sub _expire (\$) {
my $self = shift;
- $self->_RecordCache->set( $self->_primary_RecordCache_key , undef, time-1);
- # We should be doing something more surgical to clean out the key cache. but we do need to expire it
+ my $cache_key = $self->_primary_RecordCache_key or return;
+ $self->_RecordCache->set( $cache_key, undef, time-1 );
+ # We should be doing something more surgical to clean out the
+ # key cache. but we do need to expire it
$self->_FlushKeyCache;
-
}
# Function: _fetch
@@ -195,20 +177,12 @@
sub _fetch () {
my ( $self, $cache_key ) = @_;
- my $data = $self->_RecordCache->fetch($cache_key) or return;
-
+ my $data = $self->_RecordCache->fetch( $cache_key ) or return 0;
@{$self}{keys %$data} = values %$data; # deserialize
return 1;
-
}
-sub __Value {
- my $self = shift;
- my $field = shift;
- return ( $self->SUPER::__Value($field) );
-}
-
# Function: _store
# Type : private instance
# Args : string(cache_key)
@@ -217,19 +191,18 @@
sub _store (\$) {
my $self = shift;
- $self->_RecordCache->set( $self->_primary_RecordCache_key, $self->_serialize);
- return (1);
+ my $key = $self->_primary_RecordCache_key or return 0;
+ $self->_RecordCache->set( $key, $self->_serialize );
+ return 1;
}
sub _serialize {
my $self = shift;
- return (
- {
- values => $self->{'values'},
- table => $self->Table,
- fetched => $self->{'fetched'}
- }
- );
+ return {
+ values => $self->{'values'},
+ table => $self->Table,
+ fetched => $self->{'fetched'}
+ };
}
# Function: _gen_alternate_RecordCache_key
@@ -240,14 +213,15 @@
sub _gen_alternate_RecordCache_key {
my ( $self, %attr ) = @_;
- #return( Storable::nfreeze( %attr));
- my $cache_key;
- while ( my ( $key, $value ) = each %attr ) {
- $key ||= '__undef';
- $value ||= '__undef';
-
- if ( ref($value) eq "HASH" ) {
- $value = ( $value->{operator} || '=' ) . $value->{value};
+ my $cache_key = '';
+ foreach my $key ( sort keys %attr ) {
+ my $value = $attr{$key};
+ unless ( defined $value ) {
+ $value = '=__undef';
+ }
+ elsif ( ref($value) eq "HASH" ) {
+ $value = ( $value->{operator} || '=' )
+ . ( defined $value->{value}? $value->{value}: '__undef' );
}
else {
$value = "=" . $value;
@@ -258,17 +232,6 @@
return ($cache_key);
}
-# Function: _fetch_RecordCache_key
-# Type : private instance
-# Args : nil
-# Lvalue : 1
-
-sub _fetch_RecordCache_key {
- my ($self) = @_;
- my $cache_key = $self->_CacheConfig->{'cache_key'};
- return ($cache_key);
-}
-
# Function: _primary_RecordCache_key
# Type : private instance
# Args : none
@@ -279,46 +242,29 @@
sub _primary_RecordCache_key {
my ($self) = @_;
- return undef unless ( $self->Id );
-
- unless ( $self->{'_SB_Record_Primary_RecordCache_key'} ) {
-
- my $primary_RecordCache_key = $self->Table() . ':';
- my @attributes;
- foreach my $key ( @{ $self->_PrimaryKeys } ) {
- push @attributes, $key . '=' . $self->SUPER::__Value($key);
- }
-
- $primary_RecordCache_key .= join( ',', @attributes );
+ return $self->{'_SB_Record_Primary_RecordCache_key'}
+ if $self->{'_SB_Record_Primary_RecordCache_key'};
- $self->{'_SB_Record_Primary_RecordCache_key'} = $primary_RecordCache_key;
+ my $cache_key = '';
+ my %pk = $self->PrimaryKeys;
+ foreach my $key ( sort keys %pk ) {
+ my $value = $pk{$key};
+ return undef unless defined $value;
+ $cache_key .= $key . '=' . $value .',';
}
- return ( $self->{'_SB_Record_Primary_RecordCache_key'} );
-
+ chop $cache_key;
+ return $self->{'_SB_Record_Primary_RecordCache_key'} = $cache_key;
}
# Function: lookup_primary_RecordCache_key
# Type : private class
# Args : string(alternate cache id)
# Lvalue : string(cache id)
-sub _lookup_primary_RecordCache_key {
- my $self = shift;
- my $alternate_key = shift;
- return undef unless ($alternate_key);
-
- my $primary_key = $self->_KeyCache->fetch($alternate_key);
- if ($primary_key) {
- return ($primary_key);
- }
-
- # If the alternate key is really the primary one
- elsif ( $self->_RecordCache->fetch($alternate_key) ) {
- return ($alternate_key);
- }
- else { # empty!
- return (undef);
- }
+sub _lookup_primary_RecordCache_key {
+ my ($self, $key) = @_;
+ return undef unless $key;
+ return $self->_KeyCache->fetch($key) || $key;
}
=head2 _CacheConfig
@@ -334,7 +280,7 @@
=cut
sub _CacheConfig {
- {
+ return {
'cache_p' => 1,
'cache_for_sec' => 5,
};
@@ -354,5 +300,3 @@
L<DBIx::SearchBuilder>, L<DBIx::SearchBuilder::Record>
=cut
-
-
Modified: DBIx-SearchBuilder/trunk/inc/Module/Install.pm
==============================================================================
--- DBIx-SearchBuilder/trunk/inc/Module/Install.pm (original)
+++ DBIx-SearchBuilder/trunk/inc/Module/Install.pm Fri Jun 30 08:19:05 2006
@@ -1,4 +1,4 @@
-#line 1 "inc/Module/Install.pm - /usr/lib/perl5/site_perl/5.8.5/Module/Install.pm"
+#line 1
package Module::Install;
# For any maintainers:
Modified: DBIx-SearchBuilder/trunk/inc/Module/Install/AutoInstall.pm
==============================================================================
--- DBIx-SearchBuilder/trunk/inc/Module/Install/AutoInstall.pm (original)
+++ DBIx-SearchBuilder/trunk/inc/Module/Install/AutoInstall.pm Fri Jun 30 08:19:05 2006
@@ -1,6 +1,15 @@
-#line 1 "inc/Module/Install/AutoInstall.pm - /usr/lib/perl5/site_perl/5.8.5/Module/Install/AutoInstall.pm"
+#line 1
package Module::Install::AutoInstall;
-use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.62';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
sub AutoInstall { $_[0] }
@@ -18,45 +27,35 @@
my $self = shift;
return if $self->{done}++;
-# ExtUtils::AutoInstall Bootstrap Code, version 7.
-AUTO:{my$p='ExtUtils::AutoInstall';my$v=0.49;$p->VERSION||0>=$v
-or+eval"use $p $v;1"or+do{my$e=$ENV{PERL_EXTUTILS_AUTOINSTALL};
-(!defined($e)||$e!~m/--(?:default|skip|testonly)/and-t STDIN or
-eval"use ExtUtils::MakeMaker;WriteMakefile(PREREQ_PM=>{'$p',$v}
-);1"and exit)and print"==> $p $v required. Install it from CP".
-"AN? [Y/n] "and<STDIN>!~/^n/i and print"*** Installing $p\n"and
-do{if (eval '$>' and lc(`sudo -V`) =~ /version/){system('sudo',
-$^X,"-MCPANPLUS","-e","CPANPLUS::install $p");eval"use $p $v;1"
-||system('sudo', $^X, "-MCPAN", "-e", "CPAN::install $p")}eval{
-require CPANPLUS;CPANPLUS::install$p};eval"use $p $v;1"or eval{
-require CPAN;CPAN::install$p};eval"use $p $v;1"||die"*** Please
-manually install $p $v from cpan.org first...\n"}}}
-
# Flatten array of arrays into a single array
my @core = map @$_, map @$_, grep ref,
$self->build_requires, $self->requires;
- while ( @core and @_ > 1 and $_[0] =~ /^-\w+$/ ) {
- push @core, splice(@_, 0, 2);
- }
+ my @config = @_;
- ExtUtils::AutoInstall->import(
- (@core ? (-core => \@core) : ()), @_, $self->features
+ # We'll need Module::AutoInstall
+ $self->include('Module::AutoInstall');
+ require Module::AutoInstall;
+
+ Module::AutoInstall->import(
+ (@config ? (-config => \@config) : ()),
+ (@core ? (-core => \@core) : ()),
+ $self->features,
);
- $self->makemaker_args( ExtUtils::AutoInstall::_make_args() );
+ $self->makemaker_args( Module::AutoInstall::_make_args() );
my $class = ref($self);
$self->postamble(
"# --- $class section:\n" .
- ExtUtils::AutoInstall::postamble()
+ Module::AutoInstall::postamble()
);
}
sub auto_install_now {
my $self = shift;
- $self->auto_install;
- ExtUtils::AutoInstall::do_install();
+ $self->auto_install(@_);
+ Module::AutoInstall::do_install();
}
1;
Modified: DBIx-SearchBuilder/trunk/inc/Module/Install/Base.pm
==============================================================================
--- DBIx-SearchBuilder/trunk/inc/Module/Install/Base.pm (original)
+++ DBIx-SearchBuilder/trunk/inc/Module/Install/Base.pm Fri Jun 30 08:19:05 2006
@@ -1,4 +1,4 @@
-#line 1 "inc/Module/Install/Base.pm - /usr/lib/perl5/site_perl/5.8.5/Module/Install/Base.pm"
+#line 1
package Module::Install::Base;
$VERSION = '0.62';
Modified: DBIx-SearchBuilder/trunk/inc/Module/Install/Makefile.pm
==============================================================================
--- DBIx-SearchBuilder/trunk/inc/Module/Install/Makefile.pm (original)
+++ DBIx-SearchBuilder/trunk/inc/Module/Install/Makefile.pm Fri Jun 30 08:19:05 2006
@@ -1,4 +1,4 @@
-#line 1 "inc/Module/Install/Makefile.pm - /usr/lib/perl5/site_perl/5.8.5/Module/Install/Makefile.pm"
+#line 1
package Module::Install::Makefile;
use strict 'vars';
Modified: DBIx-SearchBuilder/trunk/inc/Module/Install/Metadata.pm
==============================================================================
--- DBIx-SearchBuilder/trunk/inc/Module/Install/Metadata.pm (original)
+++ DBIx-SearchBuilder/trunk/inc/Module/Install/Metadata.pm Fri Jun 30 08:19:05 2006
@@ -1,4 +1,4 @@
-#line 1 "inc/Module/Install/Metadata.pm - /usr/lib/perl5/site_perl/5.8.5/Module/Install/Metadata.pm"
+#line 1
package Module::Install::Metadata;
use strict 'vars';
Modified: DBIx-SearchBuilder/trunk/t/01records.t
==============================================================================
--- DBIx-SearchBuilder/trunk/t/01records.t (original)
+++ DBIx-SearchBuilder/trunk/t/01records.t Fri Jun 30 08:19:05 2006
@@ -206,7 +206,9 @@
package TestApp::Address;
-use base qw/DBIx::SearchBuilder::Record/;
+use base $ENV{SB_TEST_CACHABLE}?
+ qw/DBIx::SearchBuilder::Record::Cachable/:
+ qw/DBIx::SearchBuilder::Record/;
sub _Init {
my $self = shift;
Modified: DBIx-SearchBuilder/trunk/t/01searches.t
==============================================================================
--- DBIx-SearchBuilder/trunk/t/01searches.t (original)
+++ DBIx-SearchBuilder/trunk/t/01searches.t Fri Jun 30 08:19:05 2006
@@ -228,7 +228,9 @@
package TestApp::User;
-use base qw/DBIx::SearchBuilder::Record/;
+use base $ENV{SB_TEST_CACHABLE}?
+ qw/DBIx::SearchBuilder::Record::Cachable/:
+ qw/DBIx::SearchBuilder::Record/;
sub _Init {
my $self = shift;
Added: DBIx-SearchBuilder/trunk/t/02records_cachable.t
==============================================================================
--- (empty file)
+++ DBIx-SearchBuilder/trunk/t/02records_cachable.t Fri Jun 30 08:19:05 2006
@@ -0,0 +1,134 @@
+#!/usr/bin/perl -w
+
+
+use strict;
+use warnings;
+use File::Spec;
+use Test::More;
+BEGIN { require "t/utils.pl" }
+our (@AvailableDrivers);
+
+use constant TESTS_PER_DRIVER => 16;
+
+my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d ( @AvailableDrivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp::Address', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ my $ret = init_schema( 'TestApp::Address', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back");
+
+ my $rec = TestApp::Address->new($handle);
+ isa_ok($rec, 'DBIx::SearchBuilder::Record');
+
+ my ($id) = $rec->Create( Name => 'Jesse', Phone => '617 124 567');
+ ok($id,"Created record #$id");
+
+ ok($rec->Load($id), "Loaded the record");
+ is($rec->id, $id, "The record has its id");
+ is($rec->Name, 'Jesse', "The record's name is Jesse");
+
+ my $rec_cache = TestApp::Address->new($handle);
+ my ($status, $msg) = $rec_cache->LoadById($id);
+ ok($status, 'loaded record');
+ is($rec_cache->id, $id, 'the same record as we created');
+ is($msg, 'Fetched from cache', 'we fetched record from cache');
+
+ DBIx::SearchBuilder::Record::Cachable->FlushCache;
+
+ ok($rec->LoadByCols( Name => 'Jesse' ), "Loaded the record");
+ is($rec->id, $id, "The record has its id");
+ is($rec->Name, 'Jesse', "The record's name is Jesse");
+
+ $rec_cache = TestApp::Address->new($handle);
+ ($status, $msg) = $rec_cache->LoadById($id);
+ ok($status, 'loaded record');
+ is($rec_cache->id, $id, 'the same record as we created');
+ is($msg, 'Fetched from cache', 'we fetched record from cache');
+
+ cleanup_schema( 'TestApp::Address', $handle );
+}} # SKIP, foreach blocks
+
+1;
+
+
+
+package TestApp::Address;
+
+use base qw/DBIx::SearchBuilder::Record::Cachable/;
+
+sub _Init {
+ my $self = shift;
+ my $handle = shift;
+ $self->Table('Address');
+ $self->_Handle($handle);
+}
+
+sub _ClassAccessible {
+ return {
+ id =>
+ {read => 1, type => 'int(11)', default => ''},
+ Name =>
+ {read => 1, write => 1, type => 'varchar(14)', default => ''},
+ Phone =>
+ {read => 1, write => 1, type => 'varchar(18)', length => 18, default => ''},
+ EmployeeId =>
+ {read => 1, write => 1, type => 'int(8)', default => ''},
+
+ }
+}
+
+sub _CacheConfig {
+ return {
+ 'cache_for_sec' => 60,
+ };
+}
+
+sub schema_mysql {
+<<EOF;
+CREATE TEMPORARY TABLE Address (
+ id integer AUTO_INCREMENT,
+ Name varchar(36),
+ Phone varchar(18),
+ EmployeeId int(8),
+ PRIMARY KEY (id))
+EOF
+
+}
+
+sub schema_pg {
+<<EOF;
+CREATE TEMPORARY TABLE Address (
+ id serial PRIMARY KEY,
+ Name varchar,
+ Phone varchar,
+ EmployeeId integer
+)
+EOF
+
+}
+
+sub schema_sqlite {
+
+<<EOF;
+CREATE TABLE Address (
+ id integer primary key,
+ Name varchar(36),
+ Phone varchar(18),
+ EmployeeId int(8))
+EOF
+
+}
+
+1;
Modified: DBIx-SearchBuilder/trunk/t/02records_object.t
==============================================================================
--- DBIx-SearchBuilder/trunk/t/02records_object.t (original)
+++ DBIx-SearchBuilder/trunk/t/02records_object.t Fri Jun 30 08:19:05 2006
@@ -9,16 +9,7 @@
BEGIN { require "t/utils.pl" }
our (@AvailableDrivers);
-use Test::More;
-eval "use DBD::SQLite";
-if ($@) {
-plan skip_all => "DBD::SQLite required for testing database interaction"
-} else{
-plan tests => 9;
-}
-my $handle = get_handle('SQLite');
-connect_handle( $handle );
-isa_ok($handle->dbh, 'DBI::db');
+use constant TESTS_PER_DRIVER => 11;
my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER;
plan tests => $total;
@@ -115,7 +106,10 @@
package TestApp::Employee;
-use base qw/DBIx::SearchBuilder::Record/;
+use base $ENV{SB_TEST_CACHABLE}?
+ qw/DBIx::SearchBuilder::Record::Cachable/:
+ qw/DBIx::SearchBuilder::Record/;
+
use vars qw/$VERSION/;
$VERSION=0.01;
@@ -144,7 +138,9 @@
use vars qw/$VERSION/;
$VERSION=0.01;
-use base qw/DBIx::SearchBuilder::Record/;
+use base $ENV{SB_TEST_CACHABLE}?
+ qw/DBIx::SearchBuilder::Record::Cachable/:
+ qw/DBIx::SearchBuilder::Record/;
sub _Init {
my $self = shift;
Modified: DBIx-SearchBuilder/trunk/t/02searches_joins.t
==============================================================================
--- DBIx-SearchBuilder/trunk/t/02searches_joins.t (original)
+++ DBIx-SearchBuilder/trunk/t/02searches_joins.t Fri Jun 30 08:19:05 2006
@@ -153,7 +153,9 @@
package TestApp::User;
-use base qw/DBIx::SearchBuilder::Record/;
+use base $ENV{SB_TEST_CACHABLE}?
+ qw/DBIx::SearchBuilder::Record::Cachable/:
+ qw/DBIx::SearchBuilder::Record/;
sub _Init {
my $self = shift;
@@ -204,7 +206,9 @@
package TestApp::Group;
-use base qw/DBIx::SearchBuilder::Record/;
+use base $ENV{SB_TEST_CACHABLE}?
+ qw/DBIx::SearchBuilder::Record::Cachable/:
+ qw/DBIx::SearchBuilder::Record/;
sub _Init {
my $self = shift;
@@ -248,7 +252,9 @@
package TestApp::UsersToGroup;
-use base qw/DBIx::SearchBuilder::Record/;
+use base $ENV{SB_TEST_CACHABLE}?
+ qw/DBIx::SearchBuilder::Record::Cachable/:
+ qw/DBIx::SearchBuilder::Record/;
sub _Init {
my $self = shift;
Modified: DBIx-SearchBuilder/trunk/t/11schema_records.t
==============================================================================
--- DBIx-SearchBuilder/trunk/t/11schema_records.t (original)
+++ DBIx-SearchBuilder/trunk/t/11schema_records.t Fri Jun 30 08:19:05 2006
@@ -238,7 +238,9 @@
package TestApp::Employee;
-use base qw/DBIx::SearchBuilder::Record/;
+use base $ENV{SB_TEST_CACHABLE}?
+ qw/DBIx::SearchBuilder::Record::Cachable/:
+ qw/DBIx::SearchBuilder::Record/;
sub Table { 'Employees' }
@@ -260,7 +262,9 @@
package TestApp::Phone;
-use base qw/DBIx::SearchBuilder::Record/;
+use base $ENV{SB_TEST_CACHABLE}?
+ qw/DBIx::SearchBuilder::Record::Cachable/:
+ qw/DBIx::SearchBuilder::Record/;
sub Table { 'Phones' }
Modified: DBIx-SearchBuilder/trunk/t/testmodels.pl
==============================================================================
--- DBIx-SearchBuilder/trunk/t/testmodels.pl (original)
+++ DBIx-SearchBuilder/trunk/t/testmodels.pl Fri Jun 30 08:19:05 2006
@@ -1,6 +1,8 @@
package Sample::Address;
-use base qw/DBIx::SearchBuilder::Record/;
+use base $ENV{SB_TEST_CACHABLE}?
+ qw/DBIx::SearchBuilder::Record::Cachable/:
+ qw/DBIx::SearchBuilder::Record/;
# Class and instance method
@@ -18,7 +20,9 @@
package Sample::Employee;
-use base qw/DBIx::SearchBuilder::Record/;
+use base $ENV{SB_TEST_CACHABLE}?
+ qw/DBIx::SearchBuilder::Record::Cachable/:
+ qw/DBIx::SearchBuilder::Record/;
sub Table { "Employees" }
Modified: DBIx-SearchBuilder/trunk/t/utils.pl
==============================================================================
--- DBIx-SearchBuilder/trunk/t/utils.pl (original)
+++ DBIx-SearchBuilder/trunk/t/utils.pl Fri Jun 30 08:19:05 2006
@@ -21,7 +21,7 @@
Sybase
);
-our @AvailableDrivers = grep { eval "require DBD::". $_ } @SupportedDrivers;
+=head2 @AvailableDrivers
Array that lists only drivers from supported list
that user has installed.
@@ -50,21 +50,172 @@
return $handle;
}
+=head2 handle_to_driver
+
+Returns driver name which gets from C<$handle> object argument.
+
+=cut
+
+sub handle_to_driver
+{
+ my $driver = ref($_[0]);
+ $driver =~ s/^.*:://;
+ return $driver;
+}
+
+=head2 connect_handle
+
+Connects C<$handle> object to DB.
+
+=cut
+
sub connect_handle
{
- my $class = lc ref($_[0]);
- $class =~ s/^.*:://;
- my $call = "connect_$class";
+ my $call = "connect_". lc handle_to_driver( $_[0] );
+ return unless defined &$call;
+ goto &$call;
+}
+
+=head2 connect_handle_with_driver($handle, $driver)
+Connects C<$handle> using driver C<$driver>; can use this to test the
+magic that turns a C<DBIx::SearchBuilder::Handle> into a C<DBIx::SearchBuilder::Handle::Foo>
+on C<Connect>.
+
+=cut
+
+sub connect_handle_with_driver
+{
+ my $call = "connect_". lc $_[1];
return unless defined &$call;
+ @_ = $_[0];
goto &$call;
}
sub connect_sqlite
{
my $handle = shift;
- return $handle->Connect( Driver => 'SQLite', Database => File::Spec->catfile(File::Spec->tmpdir(), "sb-test.$$"));
+ return $handle->Connect(
+ Driver => 'SQLite',
+ Database => File::Spec->catfile(File::Spec->tmpdir(), "sb-test.$$")
+ );
+}
+
+sub connect_mysql
+{
+ my $handle = shift;
+ return $handle->Connect(
+ Driver => 'mysql',
+ Database => $ENV{'SB_TEST_MYSQL'},
+ User => $ENV{'SB_TEST_MYSQL_USER'} || 'root',
+ Password => $ENV{'SB_TEST_MYSQL_PASS'} || '',
+ );
}
+sub connect_pg
+{
+ my $handle = shift;
+ return $handle->Connect(
+ Driver => 'Pg',
+ Database => $ENV{'SB_TEST_PG'},
+ User => $ENV{'SB_TEST_PG_USER'} || 'postgres',
+ Password => $ENV{'SB_TEST_PG_PASS'} || '',
+ );
+}
+
+=head2 should_test
+
+Checks environment for C<SB_TEST_*> variables.
+Returns true if specified DB back-end should be tested.
+Takes one argument C<$driver> name.
+
+=cut
+
+sub should_test
+{
+ my $driver = shift;
+ return 1 if lc $driver eq 'sqlite';
+ my $env = 'SB_TEST_'. uc $driver;
+ return $ENV{$env};
+}
+
+=head2 had_schema
+
+Returns true if C<$class> has schema for C<$driver>.
+
+=cut
+
+sub has_schema
+{
+ my ($class, $driver) = @_;
+ my $method = 'schema_'. lc $driver;
+ return UNIVERSAL::can( $class, $method );
+}
+
+=head2 init_schema
+
+Takes C<$class> and C<$handle> and inits schema by calling
+C<schema_$driver> method of the C<$class>.
+Returns last C<DBI::st> on success or last return value of the
+SimpleQuery method on error.
+
+=cut
+
+sub init_schema
+{
+ my ($class, $handle) = @_;
+ my $call = "schema_". lc handle_to_driver( $handle );
+ my $schema = $class->$call();
+ $schema = ref( $schema )? $schema : [$schema];
+ my $ret;
+ foreach my $query( @$schema ) {
+ $ret = $handle->SimpleQuery( $query );
+ return $ret unless UNIVERSAL::isa( $ret, 'DBI::st' );
+ }
+ return $ret;
+}
+
+=head2 cleanup_schema
+
+Takes C<$class> and C<$handle> and cleanup schema by calling
+C<cleanup_schema_$driver> method of the C<$class> if method exists.
+Always returns undef.
+
+=cut
+
+sub cleanup_schema
+{
+ my ($class, $handle) = @_;
+ my $call = "cleanup_schema_". lc handle_to_driver( $handle );
+ return unless UNIVERSAL::can( $class, $call );
+ my $schema = $class->$call();
+ $schema = ref( $schema )? $schema : [$schema];
+ foreach my $query( @$schema ) {
+ eval { $handle->SimpleQuery( $query ) };
+ }
+}
+
+=head2 init_data
+
+=cut
+
+sub init_data
+{
+ my ($class, $handle) = @_;
+ my @data = $class->init_data();
+ my @columns = @{ shift @data };
+ my $count = 0;
+ foreach my $values ( @data ) {
+ my %args;
+ for( my $i = 0; $i < @columns; $i++ ) {
+ $args{ $columns[$i] } = $values->[$i];
+ }
+ my $rec = $class->new( $handle );
+ my $id = $rec->Create( %args );
+ die "Couldn't create record" unless $id;
+ $count++;
+ }
+ return $count;
+}
1;
More information about the Rt-commit
mailing list