use strict;
use warnings;
-use base qw/DBIx::Class::CDBICompat::Convenience
- DBIx::Class::CDBICompat::Triggers
+use base qw/DBIx::Class::CDBICompat::Triggers
DBIx::Class::CDBICompat::GetSet
DBIx::Class::CDBICompat::LiveObjectIndex
DBIx::Class::CDBICompat::AttributeAPI
DBIx::Class::CDBICompat::Stringify
- DBIx::Class::CDBICompat::ObjIndexStubs
DBIx::Class::CDBICompat::DestroyWarning
DBIx::Class::CDBICompat::Constructor
DBIx::Class::CDBICompat::AccessorMapping
DBIx::Class::CDBICompat::ColumnGroups
DBIx::Class::CDBICompat::ImaDBI/;
+ #DBIx::Class::CDBICompat::ObjIndexStubs
1;
=head1 NAME
+++ /dev/null
-package DBIx::Class::CDBICompat::Convenience;
-
-use strict;
-use warnings;
-
-sub find_or_create {
- my $class = shift;
- my $hash = ref $_[0] eq "HASH" ? shift: {@_};
- my ($exists) = $class->search($hash);
- return defined($exists) ? $exists : $class->create($hash);
-}
-
-sub retrieve_all {
- my ($class) = @_;
- return $class->retrieve_from_sql( '1' );
-}
-
-1;
sub has_many {
my ($class, $rel, $f_class, $f_key, $args) = @_;
- #die "No such column ${col}" unless $class->_columns->{$col};
+
+ my $self_key;
+
+ if (ref $f_class eq 'ARRAY') {
+ ($f_class, $self_key) = @$f_class;
+ }
+
+ if (!$self_key || $self_key eq 'id') {
+ my ($pri, $too_many) = keys %{ $class->_primaries };
+ die "has_many only works with a single primary key; ${class} has more"
+ if $too_many;
+ $self_key = $pri;
+ }
+
eval "require $f_class";
- my ($pri, $too_many) = keys %{ $class->_primaries };
- die "has_many only works with a single primary key; ${class} has more"
- if $too_many;
+
if (ref $f_key eq 'HASH') { $args = $f_key; undef $f_key; };
+
#unless ($f_key) { Not selective enough. Removed pending fix.
# ($f_rel) = grep { $_->{class} && $_->{class} eq $class }
# $f_class->_relationships;
#}
+
unless ($f_key) {
#warn join(', ', %{ $f_class->_columns });
$class =~ /([^\:]+)$/;
#warn $1;
$f_key = lc $1 if $f_class->_columns->{lc $1};
}
+
die "Unable to resolve foreign key for has_many from ${class} to ${f_class}"
unless $f_key;
die "No such column ${f_key} on foreign class ${f_class}"
unless $f_class->_columns->{$f_key};
$class->add_relationship($rel, $f_class,
- { "foreign.${f_key}" => "self.${pri}" },
+ { "foreign.${f_key}" => "self.${self_key}" },
{ _type => 'has_many', %{$args || {}} } );
{
no strict 'refs';
my @hm = grep { $rels{$_}{attrs}{_type}
&& $rels{$_}{attrs}{_type} eq 'has_many' } keys %rels;
foreach my $has_many (@hm) {
- $_->delete for $self->search_related($has_many);
+ unless ($rels{$has_many}->{attrs}{no_cascade_delete}) {
+ $_->delete for $self->search_related($has_many)
+ }
}
return $ret;
}
sub _dbi_connect {
my ($class, @info) = @_;
- return DBI->connect_cached(@info);
+ return DBI->connect(@info);
}
sub connection {
use warnings;
use Tie::IxHash;
-use base qw/Class::Data::Inheritable DBIx::Class::SQL/;
+use base qw/Class::Data::Inheritable/;
__PACKAGE__->mk_classdata('_primaries' => {});
sub _sql_to_sth {
my ($class, $sql) = @_;
- return $class->_get_dbh->prepare_cached($sql);
+ return $class->_get_dbh->prepare($sql);
}
sub _get_sth {
use strict;
use warnings;
-use base qw/Class::Data::Inheritable DBIx::Class::SQL/;
+use DBIx::Class::Cursor;
+
+use base qw/Class::Data::Inheritable/;
__PACKAGE__->mk_classdata('_columns' => {});
__PACKAGE__->mk_classdata('table_alias'); # FIXME: Doesn't actually do anything yet!
+__PACKAGE__->mk_classdata('_cursor_class' => 'DBIx::Class::Cursor');
+
=head1 NAME
DBIx::Class::Table - Basic table methods
sub sth_to_objects {
my ($class, $sth, $args, $cols) = @_;
my @cols = ((ref $cols eq 'ARRAY') ? @$cols : @{$sth->{NAME_lc}} );
- $sth->execute(@$args);
- my @found;
- while (my @row = $sth->fetchrow_array) {
- push(@found, $class->_row_to_object(\@cols, \@row));
- }
- $sth->finish;
- return @found;
+ my $cursor_class = $class->_cursor_class;
+ eval "use $cursor_class;";
+ my $cursor = $cursor_class->new($class, $sth, $args, \@cols);
+ return (wantarray ? $cursor->all : $cursor);
}
sub _row_to_object { # WARNING: Destructive to @$row
shift->_table_name(@_);
}
+sub find_or_create {
+ my $class = shift;
+ my $hash = ref $_[0] eq "HASH" ? shift: {@_};
+ my ($exists) = $class->search($hash);
+ return defined($exists) ? $exists : $class->create($hash);
+}
+
+sub retrieve_all {
+ my ($class) = @_;
+ return $class->retrieve_from_sql( '1' );
+}
+
1;
=back
# Iterators
#----------------------------------------------------------------------
-SKIP: {
- skip "Compat layer doesn't have iterator support yet", 33;
+my $it_class = 'DBIx::Class::Cursor';
sub test_normal_iterator {
my $it = $film->actors;
- isa_ok $it, "Class::DBI::Iterator";
+ isa_ok $it, $it_class;
is $it->count, 3, " - with 3 elements";
my $i = 0;
while (my $film = $it->next) {
{
Film->has_many(actor_ids => [ Actor => 'id' ]);
my $it = $film->actor_ids;
- isa_ok $it, "Class::DBI::Iterator";
+ isa_ok $it, $it_class;
is $it->count, 3, " - with 3 elements";
my $i = 0;
while (my $film_id = $it->next) {
# make sure nothing gets clobbered;
test_normal_iterator;
+SKIP: {
+ skip "dbic iterators don't support slice yet", 12;
+
+
{
my @acts = $film->actors->slice(1, 2);
is @acts, 2, "Slice gives 2 actor";
--- /dev/null
+use strict;
+use Test::More;
+
+BEGIN {
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 33);
+}
+
+use lib 't/testlib';
+use Film;
+
+my $it_class = "DBIx::Class::Cursor";
+
+my @film = (
+ Film->create({ Title => 'Film 1' }),
+ Film->create({ Title => 'Film 2' }),
+ Film->create({ Title => 'Film 3' }),
+ Film->create({ Title => 'Film 4' }),
+ Film->create({ Title => 'Film 5' }),
+ Film->create({ Title => 'Film 6' }),
+);
+
+{
+ my $it1 = Film->retrieve_all;
+ isa_ok $it1, $it_class;
+
+ my $it2 = Film->retrieve_all;
+ isa_ok $it2, $it_class;
+
+ while (my $from1 = $it1->next) {
+ my $from2 = $it2->next;
+ is $from1->id, $from2->id, "Both iterators get $from1";
+ }
+}
+
+{
+ my $it = Film->retrieve_all;
+ is $it->first->title, "Film 1", "Film 1 first";
+ is $it->next->title, "Film 2", "Film 2 next";
+ is $it->first->title, "Film 1", "First goes back to 1";
+ is $it->next->title, "Film 2", "With 2 still next";
+ $it->reset;
+ is $it->next->title, "Film 1", "Reset brings us to film 1 again";
+ is $it->next->title, "Film 2", "And 2 is still next";
+}
+
+SKIP: {
+ skip "Iterator doesn't yet have slice support", 19;
+
+{
+ my $it = Film->retrieve_all;
+ my @slice = $it->slice(2,4);
+ is @slice, 3, "correct slice size (array)";
+ is $slice[0]->title, "Film 3", "Film 3 first";
+ is $slice[2]->title, "Film 5", "Film 5 last";
+}
+
+{
+ my $it = Film->retrieve_all;
+ my $slice = $it->slice(2,4);
+ isa_ok $slice, $it_class, "slice as iterator";
+ is $slice->count, 3,"correct slice size (array)";
+ is $slice->first->title, "Film 3", "Film 3 first";
+ is $slice->next->title, "Film 4", "Film 4 next";
+ is $slice->first->title, "Film 3", "First goes back to 3";
+ is $slice->next->title, "Film 4", "With 4 still next";
+ $slice->reset;
+ is $slice->next->title, "Film 3", "Reset brings us to film 3 again";
+ is $slice->next->title, "Film 4", "And 4 is still next";
+
+ # check if the original iterator still works
+ is $it->count, 6, "back to the original iterator, is of right size";
+ is $it->first->title, "Film 1", "Film 1 first";
+ is $it->next->title, "Film 2", "Film 2 next";
+ is $it->first->title, "Film 1", "First goes back to 1";
+ is $it->next->title, "Film 2", "With 2 still next";
+ is $it->next->title, "Film 3", "Film 3 is still in original Iterator";
+ $it->reset;
+ is $it->next->title, "Film 1", "Reset brings us to film 1 again";
+ is $it->next->title, "Film 2", "And 2 is still next";
+}
+
+} # End SKIP
projects / dbsrgits/DBIx-Class.git / commitdiff