[Catalyst-commits] r8050 - in trunk/Class-DBI-Sweet: .
lib/Class/DBI t/cdbi-t t/cdbi-t-ocache t/cdbi-t-rescache
phred at dev.catalyst.perl.org
phred at dev.catalyst.perl.org
Sun Jun 29 21:23:03 BST 2008
Author: phred
Date: 2008-06-29 21:23:03 +0100 (Sun, 29 Jun 2008)
New Revision: 8050
Added:
trunk/Class-DBI-Sweet/t/cdbi-t-ocache/97-pod.t
trunk/Class-DBI-Sweet/t/cdbi-t-rescache/97-pod.t
trunk/Class-DBI-Sweet/t/cdbi-t/97-pod.t
Modified:
trunk/Class-DBI-Sweet/Changes
trunk/Class-DBI-Sweet/lib/Class/DBI/Sweet.pm
trunk/Class-DBI-Sweet/t/cdbi-t-ocache/11-triggers.t
trunk/Class-DBI-Sweet/t/cdbi-t-ocache/23-cascade.t
trunk/Class-DBI-Sweet/t/cdbi-t/11-triggers.t
trunk/Class-DBI-Sweet/t/cdbi-t/23-cascade.t
Log:
Merge changes for 0.09 to official repository.
Modified: trunk/Class-DBI-Sweet/Changes
===================================================================
--- trunk/Class-DBI-Sweet/Changes 2008-06-29 12:21:49 UTC (rev 8049)
+++ trunk/Class-DBI-Sweet/Changes 2008-06-29 20:23:03 UTC (rev 8050)
@@ -1,7 +1,22 @@
Revision history for Perl extension Class::DBI::Sweet
-0.08 Tue Dec 12 00:41:00 2005
+0.10
+ - merge 0.09 changes with trunk [phred]
+
+0.09 Sun Dec 23 23:51:36 PST 2007
+ - fix spelling error which resulted in broken POD link, Jonas B. Nielsen
+ - check for Cache::MemoryCache and skip tests if not present, Rhesa Rozendaal
+ - fix 'bizzare copy of HASH in leave' issue, David Morgan, Randal Schwartz
+
+ - mutiple trigger registration in one add_trigger() call is deprecated,
+ update test 11 to reflect that, Bill Moseley <moseley at hank.org>
+
+ - indent subroutines and perltidy for easy reading
+ - new maintainer Fred Moyer <pred at redhotpenguin.com>
+
+0.08 Tue Dec 14 12:13:00 2005
- I mean, v3.0.12 ;-)
+ - Also, /ge
0.07 Mon Dec 12 10:37:00 2005
- Updated to work properly with Class::DBI v3.1.2
Modified: trunk/Class-DBI-Sweet/lib/Class/DBI/Sweet.pm
===================================================================
--- trunk/Class-DBI-Sweet/lib/Class/DBI/Sweet.pm 2008-06-29 12:21:49 UTC (rev 8049)
+++ trunk/Class-DBI-Sweet/lib/Class/DBI/Sweet.pm 2008-06-29 20:23:03 UTC (rev 8050)
@@ -2,18 +2,18 @@
use strict;
use base 'Class::DBI';
-use Class::DBI::Iterator; # For the resultset cache
+use Class::DBI::Iterator; # For the resultset cache
use Data::Page;
use DBI;
use List::Util;
use Carp qw/croak/;
-BEGIN { # Use Time::HiRes' time() if possible
- eval "use Time::HiRes";
- unless ($@) {
- import Time::HiRes qw/time/;
- }
+BEGIN { # Use Time::HiRes' time() if possible
+ eval "use Time::HiRes";
+ unless ($@) {
+ import Time::HiRes qw/time/;
+ }
}
if ( $^O eq 'MSWin32' ) {
@@ -23,9 +23,9 @@
eval "require Data::UUID;";
}
-our $UUID_Is_Available = ($@ ? 0 : 1);
+our $UUID_Is_Available = ( $@ ? 0 : 1 );
-our $VERSION = '0.08';
+our $VERSION = '0.10';
#----------------------------------------------------------------------
# RETRIEVING
@@ -49,63 +49,67 @@
SQL
__PACKAGE__->mk_classdata( default_search_attributes => {} );
-__PACKAGE__->mk_classdata( profiling_data => { } );
-__PACKAGE__->mk_classdata( _live_resultset_cache => { } );
+__PACKAGE__->mk_classdata( profiling_data => {} );
+__PACKAGE__->mk_classdata( _live_resultset_cache => {} );
sub retrieve_next {
- my $self = shift;
+ my $self = shift;
my $class = ref $self
- || croak("retrieve_next cannot be called as a class method");
+ || croak("retrieve_next cannot be called as a class method");
my ( $criteria, $attributes ) = $class->_search_args(@_);
- $attributes = { %{$attributes} }; # Local copy to fiddle with
+ $attributes = { %{$attributes} }; # Local copy to fiddle with
- my $o_by = $attributes->{order_by} || ($self->columns('Primary'))[0];
- my $is_desc=$o_by =~ s/ +DESC//; # If it's previous we'll add it back
+ my $o_by = $attributes->{order_by} || ( $self->columns('Primary') )[0];
+ my $is_desc = $o_by =~ s/ +DESC//; # If it's previous we'll add it back
- my $o_val = ($o_by =~ m/(.*)\.(.*)/
- ? $self->$1->$2
- : $self->$o_by);
+ my $o_val = (
+ $o_by =~ m/(.*)\.(.*)/
+ ? $self->$1->$2
+ : $self->$o_by
+ );
- $criteria->{$o_by} = { ($is_desc ? '<' : '>') => $o_val };
+ $criteria->{$o_by} = { ( $is_desc ? '<' : '>' ) => $o_val };
$attributes->{rows} ||= 1;
return wantarray()
- ? @{[$class->_do_search( $criteria, $attributes )]}
- : $class->_do_search( $criteria, $attributes );
+ ? @{ [ $class->_do_search( $criteria, $attributes ) ] }
+ : $class->_do_search( $criteria, $attributes );
}
sub retrieve_previous {
- my $self = shift;
+ my $self = shift;
my $class = ref $self
- || croak("retrieve_previous cannot be called as a class method");
+ || croak("retrieve_previous cannot be called as a class method");
my ( $criteria, $attributes ) = $class->_search_args(@_);
- $attributes = { %{$attributes} }; # Local copy to fiddle with
+ $attributes = { %{$attributes} }; # Local copy to fiddle with
- my $o_by = $attributes->{order_by} || ($self->columns('Primary'))[0];
- my $is_desc=$o_by =~ s/ +DESC//; # If it's previous we'll add it back
+ my $o_by = $attributes->{order_by} || ( $self->columns('Primary') )[0];
+ my $is_desc = $o_by =~ s/ +DESC//; # If it's previous we'll add it back
- my $o_val = ($o_by =~ m/(.*)\.(.*)/
- ? $self->$1->$2
- : $self->$o_by);
+ my $o_val = (
+ $o_by =~ m/(.*)\.(.*)/
+ ? $self->$1->$2
+ : $self->$o_by
+ );
$criteria->{$o_by} = { ( $is_desc ? '>' : '<' ) => $o_val };
- $attributes->{order_by} = ${o_by} . ($is_desc ? "" : " DESC");
+ $attributes->{order_by} = ${o_by} . ( $is_desc ? "" : " DESC" );
$attributes->{rows} ||= 1;
return wantarray()
- ? @{[$class->_do_search( $criteria, $attributes )]}
- : $class->_do_search( $criteria, $attributes );
+ ? @{ [ $class->_do_search( $criteria, $attributes ) ] }
+ : $class->_do_search( $criteria, $attributes );
}
sub count {
my $proto = shift;
my $class = ref($proto) || $proto;
- unless ( @_ ) {
+ unless (@_) {
return $class->count_all;
}
@@ -117,13 +121,13 @@
# no need for LIMIT/OFFSET and ORDER BY in COUNT(*)
delete @{$count}{qw( rows offset order_by )};
- my ( $sql_parts, $classes, $columns, $values )
- = $proto->_search( $criteria, $count );
+ my ( $sql_parts, $classes, $columns, $values ) =
+ $proto->_search( $criteria, $count );
- my $sql_method = 'sql_' . ($attributes->{sql_method} || 'Join_Retrieve');
+ my $sql_method = 'sql_' . ( $attributes->{sql_method} || 'Join_Retrieve' );
$sql_method .= '_Count';
- my $sth = $class->$sql_method( @{%$sql_parts}{qw/ from where /} );
+ my $sth = $class->$sql_method( @{$sql_parts}{qw/ from where /} );
$class->_bind_param( $sth, $columns );
@@ -140,16 +144,13 @@
$attributes->{rows} ||= 10;
$attributes->{page} ||= 1;
- $attributes->{_pager} = ''; # Flag that we need a pager. How ugly!
+ $attributes->{_pager} = ''; # Flag that we need a pager. How ugly!
# No point doing a count(*) if fetching all anyway
unless ( $attributes->{disable_sql_paging} ) {
- my $page = Data::Page->new(
- $class->count( $criteria, $attributes ),
- $attributes->{rows},
- $attributes->{page},
- );
+ my $page = Data::Page->new( $class->count( $criteria, $attributes ),
+ $attributes->{rows}, $attributes->{page}, );
$attributes->{offset} = $page->skipped;
$attributes->{_pager} = $page;
@@ -165,11 +166,11 @@
my $proto = shift;
my $class = ref($proto) || $proto;
- unless ( @_ || keys %{ $class->default_search_attributes }) {
+ unless ( @_ || keys %{ $class->default_search_attributes } ) {
return $class->SUPER::retrieve_all;
}
- return $class->search( {}, ( @_ > 1 ) ? { @_ } : (shift || ()) );
+ return $class->search( {}, ( @_ > 1 ) ? {@_} : ( shift || () ) );
}
sub search {
@@ -195,32 +196,31 @@
sub _do_search {
my ( $class, $criteria, $attributes ) = @_;
- foreach my $pre (@{$attributes->{prefetch} || []}) {
- unless ($class->meta_info(has_a => $pre)
- or $class->meta_info(might_have => $pre)) {
+ foreach my $pre ( @{ $attributes->{prefetch} || [] } ) {
+ unless ( $class->meta_info( has_a => $pre )
+ or $class->meta_info( might_have => $pre ) )
+ {
croak "$pre is not a has_a or might_have rel on $class";
}
}
- my ( $sql_parts, $classes, $columns, $values )
- = $class->_search( $criteria, $attributes );
+ my ( $sql_parts, $classes, $columns, $values ) =
+ $class->_search( $criteria, $attributes );
my $cache_key;
- if ( $class->cache && $attributes->{use_resultset_cache}) {
+ if ( $class->cache && $attributes->{use_resultset_cache} ) {
- my $sql = join '', @{%$sql_parts}{qw/ where from order_by limit /};
+ my $sql = join '', @{$sql_parts}{qw/ where from order_by limit /};
- $cache_key = $class->_resultset_cache_key($sql, $values,
- $attributes->{prefetch});
+ $cache_key =
+ $class->_resultset_cache_key( $sql, $values,
+ $attributes->{prefetch} );
my $cache_entry;
- my ( $latest_stale ) = sort { $b <=> $a }
- grep defined,
- map { $class->cache->get($_) }
- grep defined,
- map { $_->_staleness_cache_key }
- values %{$classes};
+ my ($latest_stale) = sort { $b <=> $a }
+ grep defined, map { $class->cache->get($_) }
+ grep defined, map { $_->_staleness_cache_key } values %{$classes};
if ($cache_key) {
@@ -230,7 +230,8 @@
delete $class->_live_resultset_cache->{$cache_key};
undef $cache_entry;
- } else {
+ }
+ else {
# So reset doesn't screw the original copy
# (which might still be in scope and in use)
@@ -239,23 +240,26 @@
{
%$cache_entry,
- iterator =>
- bless({ %{ $cache_entry->{iterator} } },
- ref $cache_entry->{iterator})
+ iterator => bless(
+ { %{ $cache_entry->{iterator} } },
+ ref $cache_entry->{iterator}
+ )
};
$cache_entry->{iterator}->reset;
}
}
- if ( !(defined $cache_entry) and
- $cache_entry = $class->cache->get($cache_key) ) {
+ if ( !( defined $cache_entry )
+ and $cache_entry = $class->cache->get($cache_key) )
+ {
if ( $cache_entry->{created} <= ( $latest_stale || 0 ) ) {
$class->cache->remove($cache_key);
- undef $cache_entry;
- } else {
+ undef $cache_entry;
+ }
+ else {
$class->_live_resultset_cache->{$cache_key} = $cache_entry;
}
@@ -265,91 +269,98 @@
if ($cache_entry) {
- push(@{$class->profiling_data->{resultset_cache}},
- [ 'HIT', $cache_key ]) if $attributes->{profile_cache};
- my $iterator = $class->_slice_iter(
- $attributes, $cache_entry->{iterator} );
+ push (
+ @{ $class->profiling_data->{resultset_cache} },
+ [ 'HIT', $cache_key ]
+ )
+ if $attributes->{profile_cache};
+ my $iterator =
+ $class->_slice_iter( $attributes, $cache_entry->{iterator} );
return map $class->construct($_), $iterator->data if wantarray;
return $iterator;
}
- push(@{$class->profiling_data->{resultset_cache}},
- [ 'MISS', $cache_key ]) if $attributes->{profile_cache};
+ push (
+ @{ $class->profiling_data->{resultset_cache} },
+ [ 'MISS', $cache_key ]
+ )
+ if $attributes->{profile_cache};
}
- my $pre_fields = ''; # Used in SELECT
- my $pre_names = ''; # for use in GROUP BY
+ my $pre_fields = ''; # Used in SELECT
+ my $pre_names = ''; # for use in GROUP BY
- if ($attributes->{prefetch}) {
- $pre_fields .= ", '".join(' ', @{$attributes->{prefetch}})
- ."' AS sweet__joins";
+ if ( $attributes->{prefetch} ) {
+ $pre_fields .= ", '"
+ . join ( ' ', @{ $attributes->{prefetch} } )
+ . "' AS sweet__joins";
my $jnum = 0;
- foreach my $pre (@{$attributes->{prefetch}}) {
+ foreach my $pre ( @{ $attributes->{prefetch} } ) {
$jnum++;
my $f_class = $classes->{$pre};
- foreach my $col ($f_class->columns('Essential')) {
- $pre_names .= ", ${pre}.${col}";
+ foreach my $col ( $f_class->columns('Essential') ) {
+ $pre_names .= ", ${pre}.${col}";
$pre_fields .= ", ${pre}.${col} AS sweet__${jnum}_${col}";
}
}
}
- $sql_parts->{prefetch_cols} = $pre_fields;
+ $sql_parts->{prefetch_cols} = $pre_fields;
$sql_parts->{prefetch_names} = $pre_names;
- my $sql_method = 'sql_' . ($attributes->{sql_method} || 'Join_Retrieve');
+ my $sql_method = 'sql_' . ( $attributes->{sql_method} || 'Join_Retrieve' );
my $statement_order = $attributes->{statement_order}
- || [qw/ prefetch_cols from sql / ];
+ || [qw/ prefetch_cols from sql /];
my @sql_parts;
- for my $part ( @$statement_order ) {
+ for my $part (@$statement_order) {
+
# For backward compatibility
if ( $part eq 'sql' ) {
- push @sql_parts, join ' ', @{%$sql_parts}{qw/ where order_by limit/};
+ push @sql_parts, join ' ',
+ @{$sql_parts}{qw/ where order_by limit/};
next;
}
- if ( exists $sql_parts->{ $part } ) {
- push @sql_parts, $sql_parts->{ $part };
+ if ( exists $sql_parts->{$part} ) {
+ push @sql_parts, $sql_parts->{$part};
next;
}
die "'statement_order' setting of [$part] is invalid";
}
- my $sth = $class->$sql_method( @sql_parts );
+ my $sth = $class->$sql_method(@sql_parts);
$class->_bind_param( $sth, $columns );
my $iterator = $class->sth_to_objects( $sth, $values );
- if ($class->cache && $attributes->{use_resultset_cache}) {
+ if ( $class->cache && $attributes->{use_resultset_cache} ) {
my $cache_entry = {
- created => time(),
- iterator => bless( { %{ $iterator } }, ref $iterator)
+ created => time(),
+ iterator => bless( { %{$iterator} }, ref $iterator )
};
$class->cache->set( $cache_key, $cache_entry );
$class->_live_resultset_cache->{$cache_key} = $cache_entry;
}
- $iterator = $class->_slice_iter($attributes, $iterator);
+ $iterator = $class->_slice_iter( $attributes, $iterator );
return map $class->construct($_), $iterator->data if wantarray;
return $iterator;
}
sub _slice_iter {
- my ( $class, $attributes, $iterator) = @_;
+ my ( $class, $attributes, $iterator ) = @_;
# Create pager if doesn't already exist
- if ( exists $attributes->{_pager} && ! $attributes->{_pager} ) {
+ if ( exists $attributes->{_pager} && !$attributes->{_pager} ) {
- $attributes->{_pager} = Data::Page->new(
- $iterator->count,
- $attributes->{rows},
- $attributes->{page},
- );
+ $attributes->{_pager} =
+ Data::Page->new( $iterator->count, $attributes->{rows},
+ $attributes->{page}, );
$attributes->{offset} = $attributes->{_pager}->skipped;
}
@@ -357,7 +368,6 @@
# If RDBM is not ROWS/OFFSET supported, slice iterator
if ( $attributes->{rows} && $iterator->count > $attributes->{rows} ) {
-
my $rows = $attributes->{rows};
my $offset = $attributes->{offset} || 0;
@@ -380,68 +390,61 @@
$params{cdbi_me_alias} = 'me';
# Overide bindtype, we need all columns and values for deflating
- my $abstract
- = Class::DBI::Sweet::SQL::Abstract->new( %params,
- bindtype => 'columns' );
+ my $abstract =
+ Class::DBI::Sweet::SQL::Abstract->new( %params, bindtype => 'columns' );
+ my ( $sql, $from, $classes, @bind ) =
+ $abstract->where( $criteria, '', $attributes->{prefetch} );
-
- my ( $sql, $from, $classes, @bind )
- = $abstract->where( $criteria, '', $attributes->{prefetch} );
-
my ( @columns, @values, %cache );
foreach my $bind (@bind) {
- push( @columns, $bind->[0] );
- push( @values, @{$bind}[1..$#$bind] );
+ push ( @columns, $bind->[0] );
+ push ( @values, @{$bind}[ 1 .. $#$bind ] );
}
-
- unless ( $sql =~ /^\s*WHERE/i ) { # huh? This is either WHERE.. or empty string.
- $sql = "WHERE 1=1 $sql"
+ unless ( $sql =~ /^\s*WHERE/i )
+ { # huh? This is either WHERE.. or empty string.
+ $sql = "WHERE 1=1 $sql";
}
$sql =~ s/^\s*(WHERE)\s*//i;
-
my %sql_parts = (
- where => $sql,
- from => $from,
- limit => '',
- order_by => '',
+ where => $sql,
+ from => $from,
+ limit => '',
+ order_by => '',
);
$sql_parts{order_by} = $abstract->_order_by( $attributes->{order_by} )
- if $attributes->{order_by};
+ if $attributes->{order_by};
+ if ( $attributes->{rows} && !$attributes->{disable_sql_paging} ) {
-
- if ( $attributes->{rows} && !$attributes->{disable_sql_paging}) {
-
my $rows = $attributes->{rows};
my $offset = $attributes->{offset} || 0;
my $driver = lc $class->db_Main->{Driver}->{Name};
if ( $driver =~ /^(maxdb|mysql|mysqlpp)$/ ) {
$sql_parts{limit} = ' LIMIT ?, ?';
- push( @columns, '__OFFSET', '__ROWS' );
- push( @values, $offset, $rows );
+ push ( @columns, '__OFFSET', '__ROWS' );
+ push ( @values, $offset, $rows );
}
elsif ( $driver =~ /^(pg|pgpp|sqlite|sqlite2)$/ ) {
$sql_parts{limit} = ' LIMIT ? OFFSET ?';
- push( @columns, '__ROWS', '__OFFSET' );
- push( @values, $rows, $offset );
+ push ( @columns, '__ROWS', '__OFFSET' );
+ push ( @values, $rows, $offset );
}
elsif ( $driver =~ /^(interbase)$/ ) {
$sql_parts{limit} = ' ROWS ? TO ?';
- push( @columns, '__ROWS', '__OFFSET' );
- push( @values, $rows, $offset + $rows );
+ push ( @columns, '__ROWS', '__OFFSET' );
+ push ( @values, $rows, $offset + $rows );
}
}
-
return ( \%sql_parts, $classes, \@columns, \@values );
}
@@ -450,9 +453,9 @@
my ( $criteria, $attributes );
- if ( @_ == 2
- && ref( $_[0] ) =~ /^(ARRAY|HASH)$/
- && ref( $_[1] ) eq 'HASH' )
+ if ( @_ == 2
+ && ref( $_[0] ) =~ /^(ARRAY|HASH)$/
+ && ref( $_[1] ) eq 'HASH' )
{
$criteria = $_[0];
$attributes = $_[1];
@@ -462,11 +465,10 @@
$attributes = {};
}
else {
- $attributes = @_ % 2 ? pop(@_) : {};
- $criteria = {@_};
+ $attributes = @_ % 2 ? pop (@_) : {};
+ $criteria = {@_};
}
-
# Need to pass things in $attributes, so don't create a new hash
for my $key ( keys %{ $proto->default_search_attributes } ) {
$attributes->{$key} ||= $proto->default_search_attributes->{$key};
@@ -511,15 +513,15 @@
}
sub _resultset_cache_key {
- my ($class, $sql, $values, $prefetch) = @_;
+ my ( $class, $sql, $values, $prefetch ) = @_;
$class = ref $class if ref $class;
- my @pre = map { "=${_}"; } @{$prefetch || []};
+ my @pre = map { "=${_}"; } @{ $prefetch || [] };
my $it = $class->iterator_class;
- return join "|", $class, "=${sql}", "=${it}", @pre, @{$values || []};
+ return join "|", $class, "=${sql}", "=${it}", @pre, @{ $values || [] };
}
sub _staleness_cache_key {
@@ -535,50 +537,52 @@
my $data = $_[0] || {};
- unless ($class->cache || $data->{'sweet__joins'}) {
+ unless ( $class->cache || $data->{'sweet__joins'} ) {
return $class->SUPER::_init(@_);
}
- my $key = $class->cache_key($data);
+ my $key = $class->cache_key($data);
my $object;
if ( $class->cache and $key and $object = $class->cache->get($key) ) {
- push(@{$class->profiling_data->{object_cache}},
- [ 'HIT', $key ])
- if ($class->default_search_attributes->{profile_cache});
+ push ( @{ $class->profiling_data->{object_cache} }, [ 'HIT', $key ] )
+ if ( $class->default_search_attributes->{profile_cache} );
# ensure that objects from the cache get inflated properly
- if ( (caller(1))[3] eq "Class::DBI::_simple_bless" ) {
+ if ( ( caller(1) )[3] eq "Class::DBI::_simple_bless" ) {
$object->call_trigger('select');
}
return $object;
}
- push(@{$class->profiling_data->{object_cache}},
- [ 'MISS', $key ])
- if ($class->default_search_attributes->{profile_cache});
+ push ( @{ $class->profiling_data->{object_cache} }, [ 'MISS', $key ] )
+ if ( $class->default_search_attributes->{profile_cache} );
$object = bless {}, $class;
- if (my $joins = $data->{'sweet__joins'}) {
+ if ( my $joins = $data->{'sweet__joins'} ) {
my $meta = $class->meta_info;
my $jnum = 0;
- foreach my $join (split(/ /, $joins)) {
- my ($rel, $f_class);
+ foreach my $join ( split ( / /, $joins ) ) {
+ my ( $rel, $f_class );
$jnum++;
- if ($rel = $meta->{has_a}{$join}) {
+ if ( $rel = $meta->{has_a}{$join} ) {
$f_class = $rel->foreign_class;
- my %attrs = map { ($_ => $data->{"sweet__${jnum}_${_}"}) }
- $f_class->columns('Essential');
- $data->{$join} = $f_class->construct(\%attrs);
- } elsif ($rel = $meta->{might_have}{$join}) {
+ my %attrs =
+ map { ( $_ => $data->{"sweet__${jnum}_${_}"} ) }
+ $f_class->columns('Essential');
+ $data->{$join} = $f_class->construct( \%attrs );
+ }
+ elsif ( $rel = $meta->{might_have}{$join} ) {
$f_class = $rel->foreign_class;
- my %attrs = map { ($_ => $data->{"sweet__${jnum}_${_}"}) }
- $f_class->columns('Essential');
- $object->{"_${join}_object"} = $f_class->construct(\%attrs);
- } else {
+ my %attrs =
+ map { ( $_ => $data->{"sweet__${jnum}_${_}"} ) }
+ $f_class->columns('Essential');
+ $object->{"_${join}_object"} = $f_class->construct( \%attrs );
+ }
+ else {
croak("Unable to find relationship ${join} on ${class}");
}
}
@@ -603,15 +607,17 @@
if ( my $object = $class->cache->get($key) ) {
$object->call_trigger('select');
- push(@{$class->profiling_data->{object_cache}},
- [ 'HIT', $key ])
- if ($class->default_search_attributes->{profile_cache});
+ push (
+ @{ $class->profiling_data->{object_cache} },
+ [ 'HIT', $key ]
+ )
+ if ( $class->default_search_attributes->{profile_cache} );
return $object;
}
- push(@{$class->profiling_data->{object_cache}},
- [ 'MISS', $key ])
- if ($class->default_search_attributes->{profile_cache});
+ push ( @{ $class->profiling_data->{object_cache} },
+ [ 'MISS', $key ] )
+ if ( $class->default_search_attributes->{profile_cache} );
}
}
@@ -676,7 +682,6 @@
return $self->SUPER::_next_in_sequence;
}
-
#----------------------------------------------------------------------
# MORE MAGIC
#----------------------------------------------------------------------
@@ -687,15 +692,15 @@
use Carp qw/croak/;
sub where {
- my ($self, $where, $order, $must_join) = @_;
+ my ( $self, $where, $order, $must_join ) = @_;
my $me = $self->{cdbi_me_alias};
$self->{cdbi_table_aliases} = { $me => $self->{cdbi_class} };
- $self->{cdbi_join_info} = { };
- $self->{cdbi_column_cache} = { };
+ $self->{cdbi_join_info} = {};
+ $self->{cdbi_column_cache} = {};
- foreach my $join (@{$must_join || []}) {
- $self->_resolve_join($me => $join);
+ foreach my $join ( @{ $must_join || [] } ) {
+ $self->_resolve_join( $me => $join );
}
my $sql = '';
@@ -707,19 +712,19 @@
$sql .= $self->_sqlcase(' where ') . $wh if $wh;
}
- $sql =~ s/(\S+)( IS(?: NOT)? NULL)/$self->_default_tables($1).$2/e;
+ $sql =~ s/(\S+)( IS(?: NOT)? NULL)/$self->_default_tables($1).$2/ge;
- my $joins = delete $self->{cdbi_join_info};
+ my $joins = delete $self->{cdbi_join_info};
my $tables = delete $self->{cdbi_table_aliases};
- my $from = $self->{cdbi_class}->table." ${me}";
+ my $from = $self->{cdbi_class}->table . " ${me}";
- foreach my $join (keys %{$joins}) {
- my $table = $tables->{$join}->table;
- $from .= ", ${table} ${join}";
- my ($l_alias, $l_key, $f_key) =
- @{$joins->{$join}}{qw/l_alias l_key f_key/};
- $sql .= " AND ${l_alias}.${l_key} = ${join}.${f_key}";
+ foreach my $join ( keys %{$joins} ) {
+ my $table = $tables->{$join}->table;
+ $from .= ", ${table} ${join}";
+ my ( $l_alias, $l_key, $f_key ) =
+ @{ $joins->{$join} }{qw/l_alias l_key f_key/};
+ $sql .= " AND ${l_alias}.${l_key} = ${join}.${f_key}";
}
# order by?
@@ -729,40 +734,39 @@
delete $self->{cdbi_column_cache};
- return wantarray ? ($sql, $from, $tables, @ret) : $sql;
+ return wantarray ? ( $sql, $from, $tables, @ret ) : $sql;
}
sub _convert {
- my ($self, $to_convert) = @_;
+ my ( $self, $to_convert ) = @_;
return $self->SUPER::_convert($to_convert) if $to_convert eq '?';
return $self->SUPER::_convert( $self->_default_tables($to_convert) );
}
sub _default_tables {
- my ($self, $to_convert) = @_;
+ my ( $self, $to_convert ) = @_;
my $alias = $self->{cdbi_me_alias};
- my @alias = split(/\./, $to_convert);
+ my @alias = split ( /\./, $to_convert );
- my $field = pop(@alias);
+ my $field = pop (@alias);
foreach my $f_alias (@alias) {
- $self->_resolve_join($alias => $f_alias)
- unless $self->{cdbi_table_aliases}{$f_alias};
+ $self->_resolve_join( $alias => $f_alias )
+ unless $self->{cdbi_table_aliases}{$f_alias};
$alias = $f_alias;
}
- if (my $meta = $self->{cdbi_class}->meta_info(
- has_many => $field )) {
+ if ( my $meta = $self->{cdbi_class}->meta_info( has_many => $field ) ) {
my $f_alias = $field;
- $self->_resolve_join($alias => $f_alias)
- unless $self->{cdbi_table_aliases}{$f_alias};
+ $self->_resolve_join( $alias => $f_alias )
+ unless $self->{cdbi_table_aliases}{$f_alias};
- $field = (($meta->foreign_class->columns('Primary'))[0]);
+ $field = ( ( $meta->foreign_class->columns('Primary') )[0] );
$alias = $f_alias;
}
@@ -770,29 +774,35 @@
}
sub _resolve_join {
- my ($self, $l_alias, $f_alias) = @_;
+ my ( $self, $l_alias, $f_alias ) = @_;
my $l_class = $self->{cdbi_table_aliases}->{$l_alias};
- my $meta = $l_class->meta_info;
- my ($rel, $f_class);
- if ($rel = $meta->{has_a}{$f_alias}) {
+ my $meta = $l_class->meta_info;
+ my ( $rel, $f_class );
+ if ( $rel = $meta->{has_a}{$f_alias} ) {
$f_class = $rel->foreign_class;
$self->{cdbi_join_info}{$f_alias} = {
l_alias => $l_alias,
- l_key => $f_alias,
- f_key => ($f_class->columns('Primary'))[0] };
- } elsif ($rel = $meta->{has_many}{$f_alias}) {
+ l_key => $f_alias,
+ f_key => ( $f_class->columns('Primary') )[0]
+ };
+ }
+ elsif ( $rel = $meta->{has_many}{$f_alias} ) {
$f_class = $rel->foreign_class;
$self->{cdbi_join_info}{$f_alias} = {
l_alias => $l_alias,
- l_key => ($l_class->columns('Primary'))[0],
- f_key => $rel->args->{foreign_key} };
- } elsif ($rel = $meta->{might_have}{$f_alias}) {
+ l_key => ( $l_class->columns('Primary') )[0],
+ f_key => $rel->args->{foreign_key}
+ };
+ }
+ elsif ( $rel = $meta->{might_have}{$f_alias} ) {
$f_class = $rel->foreign_class;
$self->{cdbi_join_info}{$f_alias} = {
l_alias => $l_alias,
- l_key => ($l_class->columns('Primary'))[0],
- f_key => ($f_class->columns('Primary'))[0] };
- } else {
+ l_key => ( $l_class->columns('Primary') )[0],
+ f_key => ( $f_class->columns('Primary') )[0]
+ };
+ }
+ else {
croak("Unable to find join info for ${f_alias} from ${l_class}");
}
@@ -800,9 +810,9 @@
}
sub _bindtype {
- my ($self, $var, $val, @rest) = @_;
+ my ( $self, $var, $val, @rest ) = @_;
$var = $self->_default_tables($var);
- my ($alias, $col) = split(/\./, $var);
+ my ( $alias, $col ) = split ( /\./, $var );
my $f_class = $self->{cdbi_table_aliases}{$alias};
my $column = $self->{cdbi_column_cache}{$alias}{$col};
@@ -810,21 +820,20 @@
unless ($column) {
$column = $f_class->find_column($col)
- || ( List::Util::first { $_->accessor eq $col }
- $f_class->columns )
- || croak("$col is not a column of ${f_class}");
+ || ( List::Util::first { $_->accessor eq $col } $f_class->columns )
+ || croak("$col is not a column of ${f_class}");
$self->{cdbi_column_cache}{$alias}{$col} = $column;
}
- if (ref $val eq $f_class) {
+ if ( ref $val eq $f_class ) {
my $accessor = $column->accessor;
$val = $val->$accessor;
}
$val = $f_class->_deflated_column( $column, $val );
- return $self->SUPER::_bindtype($var, $val, @rest);
+ return $self->SUPER::_bindtype( $var, $val, @rest );
}
1;
@@ -941,11 +950,6 @@
cache functions in a sweet package. It integrates these functions with
C<Class::DBI> in a convenient and efficient way.
-Note that Class::DBI::Sweet is no longer actively developed or maintained,
-since the developers have now moved on to working on L<DBIx::Class>, which
-provides native support for more complex joins, full multi-column primary and
-foreign key support, and is substantially faster and easier to extend.
-
=head1 RETRIEVING OBJECTS
All retrieving methods can take the same criteria and attributes. Criteria is
@@ -963,7 +967,7 @@
=item case, cmp, convert, and logic
-These attributes are passed to L<SQL::Abstact>'s constuctor and alter the
+These attributes are passed to L<SQL::Abstract>'s constuctor and alter the
behavior of the criteria.
{ cmp => 'like' }
@@ -1274,6 +1278,12 @@
__PACKAGE__->sequence('uuid');
+=head1 MAINTAINERS
+
+Fred Moyer <fred at redhotpenguin.com>
+
+See Changes for additional attributions
+
=head1 AUTHORS
Christian Hansen <ch at ngmedia.com>
@@ -1285,7 +1295,7 @@
=head1 THANKS TO
Danijel Milicevic, Jesse Sheidlower, Marcus Ramberg, Sebastian Riedel,
-Viljo Marrandi
+Viljo Marrandi, Bill Moseley
=head1 SUPPORT
Modified: trunk/Class-DBI-Sweet/t/cdbi-t/11-triggers.t
===================================================================
--- trunk/Class-DBI-Sweet/t/cdbi-t/11-triggers.t 2008-06-29 12:21:49 UTC (rev 8049)
+++ trunk/Class-DBI-Sweet/t/cdbi-t/11-triggers.t 2008-06-29 20:23:03 UTC (rev 8050)
@@ -22,9 +22,17 @@
Film->add_trigger(
before_create => \&default_rating,
+);
+Film->add_trigger(
after_create => \&create_trigger2,
+);
+Film->add_trigger(
after_delete => \&delete_trigger,
+);
+Film->add_trigger(
before_update => \&pre_up_trigger,
+);
+Film->add_trigger(
after_update => \&pst_up_trigger,
);
Modified: trunk/Class-DBI-Sweet/t/cdbi-t/23-cascade.t
===================================================================
--- trunk/Class-DBI-Sweet/t/cdbi-t/23-cascade.t 2008-06-29 12:21:49 UTC (rev 8049)
+++ trunk/Class-DBI-Sweet/t/cdbi-t/23-cascade.t 2008-06-29 20:23:03 UTC (rev 8050)
@@ -13,7 +13,7 @@
{ # Cascade Strategies
Director->has_many(nasties => Film => { cascade => 'Fail' });
- my $dir = Director->create({ name => "Nasty Noddy" });
+ my $dir = Director->insert({ name => "Nasty Noddy" });
my $kk = $dir->add_to_nasties({ Title => 'Killer Killers' });
is $kk->director, $dir, "Director set OK";
is $dir->nasties, 1, "We have one nasty";
Added: trunk/Class-DBI-Sweet/t/cdbi-t/97-pod.t
===================================================================
--- trunk/Class-DBI-Sweet/t/cdbi-t/97-pod.t (rev 0)
+++ trunk/Class-DBI-Sweet/t/cdbi-t/97-pod.t 2008-06-29 20:23:03 UTC (rev 8050)
@@ -0,0 +1,6 @@
+use Test::More;
+use strict;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+eval "use Test::Pod::Coverage 1.00";
+all_pod_files_ok();
Modified: trunk/Class-DBI-Sweet/t/cdbi-t-ocache/11-triggers.t
===================================================================
--- trunk/Class-DBI-Sweet/t/cdbi-t-ocache/11-triggers.t 2008-06-29 12:21:49 UTC (rev 8049)
+++ trunk/Class-DBI-Sweet/t/cdbi-t-ocache/11-triggers.t 2008-06-29 20:23:03 UTC (rev 8050)
@@ -28,9 +28,17 @@
Film->add_trigger(
before_create => \&default_rating,
+);
+Film->add_trigger(
after_create => \&create_trigger2,
+);
+Film->add_trigger(
after_delete => \&delete_trigger,
+);
+Film->add_trigger(
before_update => \&pre_up_trigger,
+);
+Film->add_trigger(
after_update => \&pst_up_trigger,
);
Modified: trunk/Class-DBI-Sweet/t/cdbi-t-ocache/23-cascade.t
===================================================================
--- trunk/Class-DBI-Sweet/t/cdbi-t-ocache/23-cascade.t 2008-06-29 12:21:49 UTC (rev 8049)
+++ trunk/Class-DBI-Sweet/t/cdbi-t-ocache/23-cascade.t 2008-06-29 20:23:03 UTC (rev 8050)
@@ -19,7 +19,7 @@
{ # Cascade Strategies
Director->has_many(nasties => Film => { cascade => 'Fail' });
- my $dir = Director->create({ name => "Nasty Noddy" });
+ my $dir = Director->insert({ name => "Nasty Noddy" });
my $kk = $dir->add_to_nasties({ Title => 'Killer Killers' });
is $kk->director, $dir, "Director set OK";
is $dir->nasties, 1, "We have one nasty";
Added: trunk/Class-DBI-Sweet/t/cdbi-t-ocache/97-pod.t
===================================================================
--- trunk/Class-DBI-Sweet/t/cdbi-t-ocache/97-pod.t (rev 0)
+++ trunk/Class-DBI-Sweet/t/cdbi-t-ocache/97-pod.t 2008-06-29 20:23:03 UTC (rev 8050)
@@ -0,0 +1,13 @@
+use Test::More;
+use Class::DBI::Sweet;
+eval "use Cache::MemoryCache";
+plan skip_all => 'Cache::MemoryCache needed to test POD.' if $@;
+
+Class::DBI::Sweet->default_search_attributes({ use_resultset_cache => 0 });
+Class::DBI::Sweet->cache(Cache::MemoryCache->new(
+ { namespace => "SweetTest", default_expires_in => 60 } ) );
+use strict;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+eval "use Test::Pod::Coverage 1.00";
+all_pod_files_ok();
Added: trunk/Class-DBI-Sweet/t/cdbi-t-rescache/97-pod.t
===================================================================
--- trunk/Class-DBI-Sweet/t/cdbi-t-rescache/97-pod.t (rev 0)
+++ trunk/Class-DBI-Sweet/t/cdbi-t-rescache/97-pod.t 2008-06-29 20:23:03 UTC (rev 8050)
@@ -0,0 +1,13 @@
+use Test::More;
+use Class::DBI::Sweet;
+eval "use Cache::MemoryCache";
+plan skip_all => 'Cache::MemoryCache needed to test POD.' if $@;
+
+Class::DBI::Sweet->default_search_attributes({ use_resultset_cache => 1 });
+Class::DBI::Sweet->cache(Cache::MemoryCache->new(
+ { namespace => "SweetTest", default_expires_in => 60 } ) );
+use strict;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+eval "use Test::Pod::Coverage 1.00";
+all_pod_files_ok();
More information about the Catalyst-commits
mailing list