From: Matt S Trout Date: Fri, 27 Jul 2007 05:14:35 +0000 (+0000) Subject: initial merge of Schwern's CDBICompat work, with many thanks X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e60dc79fcd4d6318e83584b826526e65048b86a9;p=dbsrgits%2FDBIx-Class-Historic.git initial merge of Schwern's CDBICompat work, with many thanks --- diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm index 874c4c7..5ced100 100644 --- a/lib/DBIx/Class/CDBICompat.pm +++ b/lib/DBIx/Class/CDBICompat.pm @@ -15,7 +15,6 @@ __PACKAGE__->load_own_components(qw/ Constraints Triggers ReadOnly - GetSet LiveObjectIndex AttributeAPI Stringify @@ -26,13 +25,18 @@ __PACKAGE__->load_own_components(qw/ HasA HasMany MightHave + Copy LazyLoading AutoUpdate TempColumns + GetSet Retrieve Pager ColumnGroups - ImaDBI/); + AbstractSearch + ImaDBI + Iterator +/); #DBIx::Class::ObjIndexStubs 1; @@ -74,6 +78,10 @@ provided it looks something like this: =item AccessorMapping +=item AbstractSearch + +Compatibility with Class::DBI::AbstractSearch. + =item AttributeAPI =item AutoUpdate diff --git a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm index c012586..1792a13 100644 --- a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm +++ b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm @@ -6,18 +6,17 @@ use warnings; sub mk_group_accessors { my ($class, $group, @cols) = @_; - unless ($class->can('accessor_name') || $class->can('mutator_name')) { + unless ($class->_can_accessor_name_for || $class->_can_mutator_name_for) { return $class->next::method($group => @cols); } foreach my $col (@cols) { - my $ro_meth = ($class->can('accessor_name') - ? $class->accessor_name($col) - : $col); - my $wo_meth = ($class->can('mutator_name') - ? $class->mutator_name($col) - : $col); - #warn "$col $ro_meth $wo_meth"; - if ($ro_meth eq $wo_meth) { + my $ro_meth = $class->_try_accessor_name_for($col); + my $wo_meth = $class->_try_mutator_name_for($col); + + # warn "class: $class / col: $col / ro: $ro_meth / wo: $wo_meth\n"; + if ($ro_meth eq $wo_meth or # they're the same + $wo_meth eq $col) # or only the accessor is custom + { $class->next::method($group => [ $ro_meth => $col ]); } else { $class->mk_group_ro_accessors($group => [ $ro_meth => $col ]); @@ -26,16 +25,46 @@ sub mk_group_accessors { } } +# CDBI 3.0.7 decided to change "accessor_name" and "mutator_name" to +# "accessor_name_for" and "mutator_name_for". This is recent enough +# that we should support both. CDBI does. +sub _can_accessor_name_for { + my $class = shift; + return $class->can("accessor_name") || $class->can("accessor_name_for"); +} + +sub _can_mutator_name_for { + my $class = shift; + return $class->can("mutator_name") || $class->can("mutator_name_for"); +} + +sub _try_accessor_name_for { + my($class, $column) = @_; + + my $method = $class->_can_accessor_name_for; + return $column unless $method; + return $class->$method($column); +} + +sub _try_mutator_name_for { + my($class, $column) = @_; + + my $method = $class->_can_mutator_name_for; + return $column unless $method; + return $class->$method($column); +} + + sub new { my ($class, $attrs, @rest) = @_; $class->throw_exception( "create needs a hashref" ) unless ref $attrs eq 'HASH'; foreach my $col ($class->columns) { - if ($class->can('accessor_name')) { - my $acc = $class->accessor_name($col); + if ($class->_can_accessor_name_for) { + my $acc = $class->_try_accessor_name_for($col); $attrs->{$col} = delete $attrs->{$acc} if exists $attrs->{$acc}; } - if ($class->can('mutator_name')) { - my $mut = $class->mutator_name($col); + if ($class->_can_mutator_name_for) { + my $mut = $class->_try_mutator_name_for($col); $attrs->{$col} = delete $attrs->{$mut} if exists $attrs->{$mut}; } } diff --git a/lib/DBIx/Class/CDBICompat/ColumnCase.pm b/lib/DBIx/Class/CDBICompat/ColumnCase.pm index 9be24ff..0f847db 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnCase.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnCase.pm @@ -79,18 +79,70 @@ sub _build_query { return \%new_query; } + +# CDBI will never overwrite an accessor, but it only uses one +# accessor for all column types. DBIC uses many different +# accessor types so, for example, if you declare a column() +# and then a has_a() for that same column it must overwrite. +# +# To make this work CDBICompat has decide if an accessor +# method was put there by itself and only then overwrite. +{ + my %our_accessors; + + sub _has_custom_accessor { + my($class, $name) = @_; + + no strict 'refs'; + my $existing_accessor = *{$class .'::'. $name}{CODE}; + return $existing_accessor && !$our_accessors{$existing_accessor}; + } + + sub _deploy_accessor { + my($class, $name, $accessor) = @_; + + return if $class->_has_custom_accessor($name); + + for my $name ($name, lc $name) { + no strict 'refs'; + no warnings 'redefine'; + *{$class .'::'. $name} = $accessor; + } + + $our_accessors{$accessor}++; + + return 1; + } +} + sub _mk_group_accessors { my ($class, $type, $group, @fields) = @_; - #warn join(', ', map { ref $_ ? (@$_) : ($_) } @fields); - my @extra; - foreach (@fields) { - my ($acc, $field) = ref $_ ? @$_ : ($_, $_); - #warn "$acc ".lc($acc)." $field"; - next if defined &{"${class}::${acc}"}; - push(@extra, [ lc $acc => $field ]); + + # So we don't have to do lots of lookups inside the loop. + my $maker = $class->can($type) unless ref $type; + + # warn "$class $type $group\n"; + foreach my $field (@fields) { + if( $field eq 'DESTROY' ) { + carp("Having a data accessor named DESTROY in ". + "'$class' is unwise."); + } + + my $name = $field; + + ($name, $field) = @$field if ref $field; + + my $accessor = $class->$maker($group, $field); + my $alias = "_${name}_accessor"; + + # warn " $field $alias\n"; + { + no strict 'refs'; + + $class->_deploy_accessor($name, $accessor); + $class->_deploy_accessor($alias, $accessor); + } } - return $class->next::method($type, $group, - @fields, @extra); } sub new { diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm index 98e6508..829f589 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm @@ -12,6 +12,8 @@ sub columns { my $proto = shift; my $class = ref $proto || $proto; my $group = shift || "All"; + $class->_init_result_source_instance(); + $class->_add_column_group($group => @_) if @_; return $class->all_columns if $group eq "All"; return $class->primary_column if $group eq "Primary"; diff --git a/lib/DBIx/Class/CDBICompat/GetSet.pm b/lib/DBIx/Class/CDBICompat/GetSet.pm index 6b98e79..a11baeb 100644 --- a/lib/DBIx/Class/CDBICompat/GetSet.pm +++ b/lib/DBIx/Class/CDBICompat/GetSet.pm @@ -16,7 +16,13 @@ sub get { } sub set { - return shift->set_column(@_); + my($self, %data) = @_; + + # set_columns() is going to do a string comparison before setting. + # This breaks on DateTime objects (whose comparison is arguably broken) + # so we stringify anything first. + $data{$_} = "$data{$_}" for keys %data; + return shift->set_columns(\%data); } 1; diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm index 880eb9d..0a143fa 100644 --- a/lib/DBIx/Class/CDBICompat/ImaDBI.pm +++ b/lib/DBIx/Class/CDBICompat/ImaDBI.pm @@ -8,7 +8,7 @@ use DBIx::ContextualFetch; use base qw/DBIx::Class/; __PACKAGE__->mk_classdata('_transform_sql_handler_order' - => [ qw/TABLE ESSENTIAL JOIN/ ] ); + => [ qw/TABLE ESSENTIAL JOIN IDENTIFIER/ ] ); __PACKAGE__->mk_classdata('_transform_sql_handlers' => { @@ -24,8 +24,14 @@ __PACKAGE__->mk_classdata('_transform_sql_handlers' => 'ESSENTIAL' => sub { my ($self, $class, $data) = @_; - return join(' ', $class->columns('Essential')) unless $data; - return join(' ', $self->{_classes}{$data}->columns('Essential')); + $class = $data ? $self->{_classes}{$data} : $class; + return join(', ', $class->columns('Essential')); + }, + 'IDENTIFIER' => + sub { + my ($self, $class, $data) = @_; + $class = $data ? $self->{_classes}{$data} : $class; + return join ' AND ', map "$_ = ?", $class->primary_columns; }, 'JOIN' => sub { diff --git a/lib/DBIx/Class/CDBICompat/LazyLoading.pm b/lib/DBIx/Class/CDBICompat/LazyLoading.pm index b7d3633..add9390 100644 --- a/lib/DBIx/Class/CDBICompat/LazyLoading.pm +++ b/lib/DBIx/Class/CDBICompat/LazyLoading.pm @@ -22,6 +22,28 @@ sub get_column { $self->next::method(@_[1..$#_]); } +# CDBI does not explicitly declare auto increment columns, so +# we just clear out our primary columns before copying. +sub copy { + my($self, $changes) = @_; + + for my $col ($self->primary_columns) { + $changes->{$col} = undef unless exists $changes->{$col}; + } + + return $self->next::method($changes); +} + +sub discard_changes { + my($self) = shift; + + delete $self->{_column_data}{$_} for $self->is_changed; + delete $self->{_dirty_columns}; + delete $self->{_relationship_data}; + + return $self; +} + sub _ident_cond { my ($class) = @_; return join(" AND ", map { "$_ = ?" } $class->primary_columns); diff --git a/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm b/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm index fb8a77e..11238dc 100644 --- a/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm +++ b/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm @@ -67,16 +67,4 @@ sub inflate_result { return $new; } -sub discard_changes { - my ($self) = @_; - if (my $key = $self->ID) { - $self->remove_from_object_index; - my $ret = $self->next::method; - $self->live_object_index->{$key} = $self if $self->in_storage; - return $ret; - } else { - return $self->next::method; - } -} - 1; diff --git a/lib/DBIx/Class/CDBICompat/Retrieve.pm b/lib/DBIx/Class/CDBICompat/Retrieve.pm index 1186ae4..4c36887 100644 --- a/lib/DBIx/Class/CDBICompat/Retrieve.pm +++ b/lib/DBIx/Class/CDBICompat/Retrieve.pm @@ -47,12 +47,35 @@ sub _build_query { sub retrieve_from_sql { my ($class, $cond, @rest) = @_; + $cond =~ s/^\s*WHERE//i; - $class->search_literal($cond, @rest); + + if( $cond =~ s/\bLIMIT (\d+)\s*$//i ) { + push @rest, { rows => $1 }; + } + + return $class->search_literal($cond, @rest); +} + +sub construct { + my $class = shift; + my $obj = $class->resultset_instance->new_result(@_); + $obj->in_storage(1); + + return $obj; } sub retrieve_all { shift->search } sub count_all { shift->count } - # Contributed by Numa. No test for this though. + +sub maximum_value_of { + my($class, $col) = @_; + return $class->resultset_instance->get_column($col)->max; +} + +sub minimum_value_of { + my($class, $col) = @_; + return $class->resultset_instance->get_column($col)->min; +} 1; diff --git a/lib/DBIx/Class/CDBICompat/TempColumns.pm b/lib/DBIx/Class/CDBICompat/TempColumns.pm index 95be2a8..d025bb8 100644 --- a/lib/DBIx/Class/CDBICompat/TempColumns.pm +++ b/lib/DBIx/Class/CDBICompat/TempColumns.pm @@ -22,17 +22,26 @@ sub _add_column_group { sub new { my ($class, $attrs, @rest) = @_; - my %temp; - foreach my $key (keys %$attrs) { - $temp{$key} = delete $attrs->{$key} if $class->_temp_columns->{$key}; - } + + my $temp = $class->_extract_temp_data($attrs); + my $new = $class->next::method($attrs, @rest); - foreach my $key (keys %temp) { - $new->set_temp($key, $temp{$key}); - } + + $new->set_temp($_, $temp->{$_}) for keys %$temp; + return $new; } +sub _extract_temp_data { + my($self, $data) = @_; + + my %temp; + foreach my $key (keys %$data) { + $temp{$key} = delete $data->{$key} if $self->_temp_columns->{$key}; + } + + return \%temp; +} sub find_column { my ($class, $col, @rest) = @_; @@ -40,6 +49,16 @@ sub find_column { return $class->next::method($col, @rest); } +sub set { + my($self, %data) = @_; + + my $temp_data = $self->_extract_temp_data(\%data); + + $self->set_temp($_, $temp_data->{$_}) for keys %$temp_data; + + return $self->next::method(%data); +} + sub get_temp { my ($self, $column) = @_; $self->throw_exception( "Can't fetch data as class method" ) unless ref $self; diff --git a/lib/DBIx/Class/CDBICompat/Triggers.pm b/lib/DBIx/Class/CDBICompat/Triggers.pm index 2c4ff30..3f6aef7 100644 --- a/lib/DBIx/Class/CDBICompat/Triggers.pm +++ b/lib/DBIx/Class/CDBICompat/Triggers.pm @@ -7,6 +7,9 @@ use Class::Trigger; sub insert { my $self = shift; + + return $self->create(@_) unless ref $self; + $self->call_trigger('before_create'); $self->next::method(@_); $self->call_trigger('after_create'); diff --git a/lib/DBIx/Class/DB.pm b/lib/DBIx/Class/DB.pm index e502278..6297850 100644 --- a/lib/DBIx/Class/DB.pm +++ b/lib/DBIx/Class/DB.pm @@ -161,7 +161,7 @@ sub result_source_instance { return $class->_result_source_instance(@_) if @_; my $source = $class->_result_source_instance; - return {} unless Scalar::Util::blessed($source); + return unless Scalar::Util::blessed($source); if ($source->result_class ne $class) { # Remove old source instance so we dont get deep recursion diff --git a/lib/DBIx/Class/Manual/Cookbook.pod b/lib/DBIx/Class/Manual/Cookbook.pod index 1bc0c8a..70e645c 100644 --- a/lib/DBIx/Class/Manual/Cookbook.pod +++ b/lib/DBIx/Class/Manual/Cookbook.pod @@ -600,7 +600,7 @@ It's as simple as overriding the C method. Note the use of C. sub new { - my ( $class, $attrs ) = @_; + my ( $self, $attrs ) = @_; $attrs->{foo} = 'bar' unless defined $attrs->{foo}; diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index b20eb16..76183de 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -36,7 +36,7 @@ sub add_relationship_accessor { $class->inflate_column($rel, { inflate => sub { my ($val, $self) = @_; - return $self->find_or_create_related($rel, {}, {}); + return $self->find_or_new_related($rel, {}, {}); }, deflate => sub { my ($val, $self) = @_; diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index 1fbcf52..09dfbbf 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -288,7 +288,8 @@ L on it. sub find_or_new_related { my $self = shift; - return $self->find_related(@_) || $self->new_related(@_); + my $obj = $self->find_related(@_); + return defined $obj ? $obj : $self->new_related(@_); } =head2 find_or_create_related diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 75ba410..4f9bb92 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -3,8 +3,8 @@ package DBIx::Class::ResultSet; use strict; use warnings; use overload - '0+' => \&count, - 'bool' => sub { 1; }, + '0+' => "count", + 'bool' => "_bool", fallback => 1; use Carp::Clan qw/^DBIx::Class/; use Data::Page; @@ -50,6 +50,10 @@ In the examples below, the following table classes are used: __PACKAGE__->belongs_to(artist => 'MyApp::Schema::Artist'); 1; +=head1 OVERLOADING + +If a resultset is used as a number it returns the C. However, if it is used as a boolean it is always true. So if you want to check if a result set has any results use C. C will always be true. + =head1 METHODS =head2 new @@ -976,6 +980,10 @@ sub _count { # Separated out so pager can get the full count return $count; } +sub _bool { + return 1; +} + =head2 count_literal =over 4 diff --git a/lib/DBIx/Class/ResultSourceProxy/Table.pm b/lib/DBIx/Class/ResultSourceProxy/Table.pm index ce78cb8..474c330 100644 --- a/lib/DBIx/Class/ResultSourceProxy/Table.pm +++ b/lib/DBIx/Class/ResultSourceProxy/Table.pm @@ -12,6 +12,42 @@ __PACKAGE__->mk_classdata(table_class => 'DBIx::Class::ResultSource::Table'); __PACKAGE__->mk_classdata('table_alias'); # FIXME: Doesn't actually do # anything yet! +sub _init_result_source_instance { + my $class = shift; + + $class->mk_classdata('result_source_instance') + unless $class->can('result_source_instance'); + + my $table = $class->result_source_instance; + my $class_has_table_instance = ($table and $table->result_class eq $class); + return $table if $class_has_table_instance; + + if( $table ) { + $table = $class->table_class->new({ + %$table, + result_class => $class, + source_name => undef, + schema => undef + }); + } + else { + $table = $class->table_class->new({ + name => undef, + result_class => $class, + source_name => undef, + }); + } + + $class->result_source_instance($table); + + if ($class->can('schema_instance')) { + $class =~ m/([^:]+)$/; + $class->schema_instance->register_class($class, $class); + } + + return $table; +} + =head1 NAME DBIx::Class::ResultSourceProxy::Table - provides a classdata table @@ -47,7 +83,7 @@ sub table { unless (ref $table) { $table = $class->table_class->new({ $class->can('result_source_instance') ? - %{$class->result_source_instance} : (), + %{$class->result_source_instance||{}} : (), name => $table, result_class => $class, source_name => undef, diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 7195bba..341ab29 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -48,7 +48,9 @@ sub new { my ($class, $attrs) = @_; $class = ref $class if ref $class; - my $new = { _column_data => {} }; + my $new = { + _column_data => {}, + }; bless $new, $class; if (my $handle = delete $attrs->{-source_handle}) { @@ -486,6 +488,10 @@ sub set_column { my $ret = $self->store_column(@_); $self->{_dirty_columns}{$column} = 1 if (defined $old ^ defined $ret) || (defined $old && $old ne $ret); + + # XXX clear out the relation cache for this column + delete $self->{related_resultsets}{$column}; + return $ret; } diff --git a/lib/DBIx/Class/Serialize/Storable.pm b/lib/DBIx/Class/Serialize/Storable.pm index 7ccd2b0..5795293 100644 --- a/lib/DBIx/Class/Serialize/Storable.pm +++ b/lib/DBIx/Class/Serialize/Storable.pm @@ -4,15 +4,20 @@ use warnings; use Storable; sub STORABLE_freeze { - my ($self,$cloning) = @_; + my ($self, $cloning) = @_; my $to_serialize = { %$self }; + delete $to_serialize->{result_source}; - return (Storable::freeze($to_serialize)); + delete $to_serialize->{related_resultsets}; + delete $to_serialize->{_inflated_column}; + + return('', $to_serialize); } sub STORABLE_thaw { - my ($self,$cloning,$serialized) = @_; - %$self = %{ Storable::thaw($serialized) }; + my ($self, $cloning, $junk, $obj) = @_; + + %$self = %{ $obj }; $self->result_source($self->result_source_instance) if $self->can('result_source_instance'); } diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index f676ec1..af2431e 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -1027,6 +1027,9 @@ sub _select { } else { $self->throw_exception("rows attribute must be positive if present") if (defined($attrs->{rows}) && !($attrs->{rows} > 0)); + + # MySQL actually recommends this approach. I cringe. + $attrs->{rows} = 2**48 if not defined $attrs->{rows} and defined $attrs->{offset}; push @args, $attrs->{rows}, $attrs->{offset}; } return $self->_execute(@args); diff --git a/lib/SQL/Translator/Parser/DBIx/Class.pm b/lib/SQL/Translator/Parser/DBIx/Class.pm index e3f0860..fd5762a 100644 --- a/lib/SQL/Translator/Parser/DBIx/Class.pm +++ b/lib/SQL/Translator/Parser/DBIx/Class.pm @@ -43,8 +43,6 @@ sub parse { # print Dumper($dbixschema->registered_classes); - #foreach my $tableclass ($dbixschema->registered_classes) - my %seen_tables; my @monikers = $dbixschema->sources; diff --git a/t/18inserterror.t b/t/18inserterror.t index 043cec5..005209a 100644 --- a/t/18inserterror.t +++ b/t/18inserterror.t @@ -7,19 +7,23 @@ BEGIN { eval "use DBD::SQLite"; plan $@ ? ( skip_all => 'needs DBD::SQLite for testing' ) - : ( tests => 3 ); + : ( tests => 4 ); } use lib qw(t/lib); use_ok( 'DBICTest' ); - use_ok( 'DBICTest::Schema' ); +my $schema = DBICTest->init_schema; { my $warnings; local $SIG{__WARN__} = sub { $warnings .= $_[0] }; - eval { DBICTest::CD->create({ title => 'vacation in antarctica' }) }; + eval { + $schema->resultset('CD') + ->create({ title => 'vacation in antarctica' }) + }; + like $@, qr/NULL/; # as opposed to some other error ok( $warnings !~ /uninitialized value/, "No warning from Storage" ); } diff --git a/t/75limit.t b/t/75limit.t index 0fc7e3a..881668d 100644 --- a/t/75limit.t +++ b/t/75limit.t @@ -9,8 +9,8 @@ my $schema = DBICTest->init_schema(); BEGIN { eval "use DBD::SQLite"; - plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 9); -} + plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 10); +} # test LIMIT my $it = $schema->resultset("CD")->search( {}, @@ -51,6 +51,15 @@ is( $it->next, undef, "software next past end of resultset ok" ); ); is( $cds[0]->title, "Spoonful of bees", "software offset ok" ); + +@cds = $schema->resultset("CD")->search( {}, + { + offset => 2, + order_by => 'year' } +); +is( $cds[0]->title, "Spoonful of bees", "offset with no limit" ); + + # based on a failing criteria submitted by waswas # requires SQL::Abstract >= 1.20 $it = $schema->resultset("CD")->search( diff --git a/t/84serialize.t b/t/84serialize.t index a8cedf0..8940021 100644 --- a/t/84serialize.t +++ b/t/84serialize.t @@ -4,13 +4,33 @@ use warnings; use Test::More; use lib qw(t/lib); use DBICTest; -use Storable; +use Storable qw(dclone freeze thaw); my $schema = DBICTest->init_schema(); -plan tests => 1; +my %stores = ( + dclone => sub { return dclone($_[0]) }, + "freeze/thaw" => sub { return thaw(freeze($_[0])) }, +); -my $artist = $schema->resultset('Artist')->find(1); -my $copy = eval { Storable::dclone($artist) }; -is_deeply($copy, $artist, 'serialize row object works'); +plan tests => (5 * keys %stores); +for my $name (keys %stores) { + my $store = $stores{$name}; + + my $artist = $schema->resultset('Artist')->find(1); + my $copy = eval { $store->($artist) }; + is_deeply($copy, $artist, "serialize row object works: $name"); + + # Test that an object with a related_resultset can be serialized. + my @cds = $artist->related_resultset("cds"); + ok $artist->{related_resultsets}, 'has key: related_resultsets'; + + $copy = eval { $store->($artist) }; + for my $key (keys %$artist) { + next if $key eq 'related_resultsets'; + next if $key eq '_inflated_column'; + is_deeply($copy->{$key}, $artist->{$key}, + qq[serialize with related_resultset "$key"]); + } +} diff --git a/t/cdbi-abstract/search_where.t b/t/cdbi-abstract/search_where.t new file mode 100644 index 0000000..3161299 --- /dev/null +++ b/t/cdbi-abstract/search_where.t @@ -0,0 +1,67 @@ +#!/usr/bin/perl -w + +use Test::More; + +use strict; +use warnings; + +BEGIN { + eval "use DBIx::Class::CDBICompat;"; + if ($@) { + plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"); + next; + } + eval "use DBD::SQLite"; + plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 9); +} + +INIT { + use lib 't/testlib'; + use Film; +} + + +Film->create({ Title => $_, Rating => "PG" }) for ("Superman", "Super Fuzz"); +Film->create({ Title => "Batman", Rating => "PG13" }); + +my $superman = Film->search_where( Title => "Superman" ); +is $superman->next->Title, "Superman", "search_where() as iterator"; +is $superman->next, undef; + +my @all = Film->search_where({}, { order_by => "Title ASC" }); +is_deeply ["Batman", "Super Fuzz", "Superman"], + [map $_->Title, @all], + "order_by ASC"; + +@all = Film->search_where({}, { order_by => "Title DESC" }); +is_deeply ["Superman", "Super Fuzz", "Batman"], + [map $_->Title, @all], + "order_by DESC"; + +@all = Film->search_where({ Rating => "PG" }, { limit => 1, order_by => "Title ASC" }); +is_deeply ["Super Fuzz"], + [map $_->Title, @all], + "where, limit"; + +@all = Film->search_where({}, { limit => 2, order_by => "Title ASC" }); +is_deeply ["Batman", "Super Fuzz"], + [map $_->Title, @all], + "limit"; + +@all = Film->search_where({}, { offset => 1, order_by => "Title ASC" }); +is_deeply ["Super Fuzz", "Superman"], + [map $_->Title, @all], + "offset"; + +@all = Film->search_where({}, { limit => 1, offset => 1, order_by => "Title ASC" }); +is_deeply ["Super Fuzz"], + [map $_->Title, @all], + "limit + offset"; + +@all = Film->search_where({}, { limit => 2, offset => 1, + limit_dialect => "Top", order_by => "Title ASC" + }); +is_deeply ["Super Fuzz", "Superman"], + [map $_->Title, @all], + "limit_dialect ignored"; + diff --git a/t/cdbi-t/01-columns.t b/t/cdbi-t/01-columns.t index 658c500..7b3b1c0 100644 --- a/t/cdbi-t/01-columns.t +++ b/t/cdbi-t/01-columns.t @@ -4,7 +4,7 @@ use Test::More; BEGIN { eval "use DBIx::Class::CDBICompat;"; - plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required') : (tests=> 24); + plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@") : (tests=> 24); } diff --git a/t/cdbi-t/02-Film.t b/t/cdbi-t/02-Film.t index d303f35..6a4d7f6 100644 --- a/t/cdbi-t/02-Film.t +++ b/t/cdbi-t/02-Film.t @@ -37,7 +37,7 @@ is(Film->__driver, "SQLite", "Driver set correctly"); ok $@, "Can't get title with no object"; } -eval { my $duh = Film->create; }; +eval { my $duh = Film->insert; }; like $@, qr/create needs a hashref/, "needs a hashref"; ok +Film->create_test_film; @@ -163,11 +163,11 @@ is($blrunner_dc->NumExplodingSheep, undef, 'Sheep correct'); } eval { - my $ishtar = Film->create({ Title => 'Ishtar', Director => 'Elaine May' }); + my $ishtar = Film->insert({ Title => 'Ishtar', Director => 'Elaine May' }); my $mandn = - Film->create({ Title => 'Mikey and Nicky', Director => 'Elaine May' }); + Film->insert({ Title => 'Mikey and Nicky', Director => 'Elaine May' }); my $new_leaf = - Film->create({ Title => 'A New Leaf', Director => 'Elaine May' }); + Film->insert({ Title => 'A New Leaf', Director => 'Elaine May' }); #use Data::Dumper; die Dumper(Film->search( Director => 'Elaine May' )); cmp_ok(Film->search(Director => 'Elaine May'), '==', 3, @@ -263,7 +263,7 @@ SKIP: { { # update deleted object my $rt = "Royal Tenenbaums"; - my $ten = Film->create({ title => $rt, Rating => "R" }); + my $ten = Film->insert({ title => $rt, Rating => "R" }); $ten->rating(18); Film->set_sql(drt => "DELETE FROM __TABLE__ WHERE title = ?"); Film->sql_drt->execute($rt); @@ -284,7 +284,7 @@ SKIP: { # Primary key of 0 { - my $zero = Film->create({ Title => 0, Rating => "U" }); + my $zero = Film->insert({ Title => 0, Rating => "U" }); ok defined $zero, "Create 0"; ok my $ret = Film->retrieve(0), "Retrieve 0"; is $ret->Title, 0, "Title OK"; @@ -344,7 +344,7 @@ if (0) { { { - ok my $byebye = DeletingFilm->create( + ok my $byebye = DeletingFilm->insert( { Title => 'Goodbye Norma Jean', Rating => 'PG', @@ -386,7 +386,7 @@ SKIP: { isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste4), "Clearing cache and retrieving again gives new object"; - $btaste=Film->create({ + $btaste=Film->insert({ Title => 'Bad Taste 2', Director => 'Peter Jackson', Rating => 'R', diff --git a/t/cdbi-t/06-hasa.t b/t/cdbi-t/06-hasa.t index 94757c3..56a1f86 100644 --- a/t/cdbi-t/06-hasa.t +++ b/t/cdbi-t/06-hasa.t @@ -4,7 +4,7 @@ use Test::More; BEGIN { eval "use DBIx::Class::CDBICompat;"; if ($@) { - plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required'); + plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"); next; } eval "use DBD::SQLite"; diff --git a/t/cdbi-t/14-might_have.t b/t/cdbi-t/14-might_have.t index 40b186e..febdd70 100644 --- a/t/cdbi-t/14-might_have.t +++ b/t/cdbi-t/14-might_have.t @@ -8,7 +8,7 @@ BEGIN { next; } eval "use DBD::SQLite"; - plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 18); + plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 22); } use lib 't/testlib'; @@ -67,4 +67,17 @@ Film->create_test_film; } - +{ + my $host = Film->create({ title => "Gwoemul" }); + $host->blurb("Monsters are real."); + my $info = $host->info; + is $info->blurb, "Monsters are real."; + + $host->discard_changes; + is $host->info->id, $info->id, + 'relationships still valid after discard_changes'; + + ok $host->info->delete; + $host->discard_changes; + ok !$host->info, 'relationships rechecked after discard_changes'; +} \ No newline at end of file diff --git a/t/cdbi-t/15-accessor.t b/t/cdbi-t/15-accessor.t index e683f7d..ad76ad1 100644 --- a/t/cdbi-t/15-accessor.t +++ b/t/cdbi-t/15-accessor.t @@ -4,11 +4,12 @@ use Test::More; BEGIN { eval "use DBIx::Class::CDBICompat;"; if ($@) { + diag $@; plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required'); next; } eval "use DBD::SQLite"; - plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 53); + plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 54); } INIT { @@ -17,7 +18,9 @@ INIT { use lib 't/testlib'; require Film; require Actor; + require Director; Actor->has_a(film => 'Film'); + Film->has_a(director => 'Director'); sub Class::DBI::sheep { ok 0; } } @@ -33,12 +36,19 @@ sub Film::accessor_name { return $col; } -sub Actor::accessor_name { +sub Actor::accessor_name_for { my ($class, $col) = @_; return "movie" if lc $col eq "film"; return $col; } +# This is a class with accessor_name_for() but no corresponding mutatori_name_for() +sub Director::accessor_name_for { + my($class, $col) = @_; + return "nutty_as_a_fruitcake" if lc $col eq "isinsane"; + return $col; +} + my $data = { Title => 'Bad Taste', Director => 'Peter Jackson', @@ -131,8 +141,20 @@ eval { } -SKIP: { # have non persistent accessor? - #skip "Compat layer doesn't handle TEMP columns yet", 11; + +# Make sure a class with an accessor_name() method has a similar mutator. +{ + my $aki = Director->create({ + name => "Aki Kaurismaki", + }); + + $aki->nutty_as_a_fruitcake(1); + is $aki->nutty_as_a_fruitcake, 1, + "a custom accessor without a custom mutator is setable"; + $aki->update; +} + +{ Film->columns(TEMP => qw/nonpersistent/); ok(Film->find_column('nonpersistent'), "nonpersistent is a column"); ok(!Film->has_real_column('nonpersistent'), " - but it's not real"); @@ -152,8 +174,7 @@ SKIP: { # have non persistent accessor? } } -SKIP: { # was bug with TEMP and no Essential - #skip "Compat layer doesn't have TEMP columns yet", 5; +{ is_deeply( Actor->columns('Essential'), Actor->columns('Primary'), @@ -166,8 +187,7 @@ SKIP: { # was bug with TEMP and no Essential isa_ok $pj => "Actor"; } -SKIP: { - #skip "Compat layer doesn't handle read-only objects yet", 10; +{ Film->autoupdate(1); my $naked = Film->create({ title => 'Naked' }); my $sandl = Film->create({ title => 'Secrets and Lies' }); diff --git a/t/cdbi-t/19-set_sql.t b/t/cdbi-t/19-set_sql.t index 36b66af..f725c89 100644 --- a/t/cdbi-t/19-set_sql.t +++ b/t/cdbi-t/19-set_sql.t @@ -8,7 +8,7 @@ BEGIN { next; } eval "use DBD::SQLite"; - plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 17); + plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 20); } use lib 't/testlib'; @@ -19,6 +19,11 @@ use Actor; my @cols = Film->columns('Essential'); is_deeply \@cols, ['title'], "1 Column in essential"; is +Film->transform_sql('__ESSENTIAL__'), 'title', '__ESSENTIAL__ expansion'; + + # This provides a more interesting test + Film->columns(Essential => qw(title rating)); + is +Film->transform_sql('__ESSENTIAL__'), 'title, rating', + 'multi-col __ESSENTIAL__ expansion'; } my $f1 = Film->create({ title => 'A', director => 'AA', rating => 'PG' }); @@ -68,6 +73,22 @@ Film->set_sql( }; { + Film->set_sql( + by_id => qq{ + SELECT __ESSENTIAL__ + FROM __TABLE__ + WHERE __IDENTIFIER__ + } + ); + + my $film = Film->retrieve_all->first; + my @found = Film->search_by_id($film->id); + is @found, 1; + is $found[0]->id, $film->id; +} + + +{ Actor->has_a(film => "Film"); Film->set_sql( namerate => qq{ @@ -109,4 +130,3 @@ Film->set_sql( is $apg[1]->title, "B", "and B"; } -#} # end SKIP block diff --git a/t/cdbi-t/21-iterator.t b/t/cdbi-t/21-iterator.t index 3c84f4c..d524423 100644 --- a/t/cdbi-t/21-iterator.t +++ b/t/cdbi-t/21-iterator.t @@ -4,11 +4,11 @@ use Test::More; BEGIN { eval "use DBIx::Class::CDBICompat;"; if ($@) { - plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required'); + plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"); next; } eval "use DBD::SQLite"; - plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 33); + plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 37); } use lib 't/testlib'; @@ -49,8 +49,6 @@ my @film = ( 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; @@ -85,4 +83,14 @@ SKIP: { is $it->next->title, "Film 2", "And 2 is still next"; } -} # End SKIP +{ + my $it = Film->retrieve_all; + is $it, $it->count, "iterator returns count as a scalar"; + ok $it, "iterator returns true when there are results"; +} + +{ + my $it = Film->search( Title => "something which does not exist" ); + is $it, 0; + ok !$it, "iterator returns false when no results"; +} diff --git a/t/cdbi-t/columns_dont_override_custom_accessors.t b/t/cdbi-t/columns_dont_override_custom_accessors.t new file mode 100644 index 0000000..4111b72 --- /dev/null +++ b/t/cdbi-t/columns_dont_override_custom_accessors.t @@ -0,0 +1,34 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +BEGIN { + eval "use DBIx::Class::CDBICompat;"; + plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@") + : (tests=> 5); +} + +{ + package Thing; + + use base 'DBIx::Class::Test::SQLite'; + + Thing->columns(TEMP => qw[foo bar]); + Thing->columns(All => qw[thing_id yarrow flower]); + sub foo { 42 } + sub yarrow { "hock" } +} + +is_deeply( [sort Thing->columns("TEMP")], + [sort qw(foo bar)], + "TEMP columns set" +); +my $thing = Thing->construct( + { thing_id => 23, foo => "this", bar => "that" } +); + +is( $thing->id, 23 ); +is( $thing->yarrow, "hock", 'custom accessor not overwritten by column' ); +is( $thing->foo, 42, 'custom routine not overwritten by temp column' ); +is( $thing->bar, "that", 'temp column accessor generated' ); diff --git a/t/cdbi-t/construct.t b/t/cdbi-t/construct.t new file mode 100644 index 0000000..59adef1 --- /dev/null +++ b/t/cdbi-t/construct.t @@ -0,0 +1,31 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +BEGIN { + eval "use DBIx::Class::CDBICompat;"; + plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@") + : (tests=> 4); +} + +INIT { + use lib 't/testlib'; + use Film; +} + +Film->insert({ + Title => "Breaking the Waves", + Director => 'Lars von Trier', + Rating => 'R' +}); + +my $film = Film->construct({ + Title => "Breaking the Waves", + Director => 'Lars von Trier', +}); + +isa_ok $film, "Film"; +is $film->title, "Breaking the Waves"; +is $film->director, "Lars von Trier"; +is $film->rating, "R", "constructed objects can get missing data from the db"; \ No newline at end of file diff --git a/t/cdbi-t/copy.t b/t/cdbi-t/copy.t new file mode 100644 index 0000000..cdcae15 --- /dev/null +++ b/t/cdbi-t/copy.t @@ -0,0 +1,43 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +BEGIN { + eval "use DBIx::Class::CDBICompat;"; + plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@") + : (tests=> 4); +} + +INIT { + use lib 't/testlib'; +} + +{ + package # hide from PAUSE + MyFilm; + + use base 'DBIx::Class::Test::SQLite'; + use strict; + + __PACKAGE__->set_table('Movies'); + __PACKAGE__->columns(All => qw(id title)); + + sub create_sql { + return qq{ + id INTEGER PRIMARY KEY AUTOINCREMENT, + title VARCHAR(255) + } + } +} + +my $film = MyFilm->create({ title => "For Your Eyes Only" }); +ok $film->id; + +my $new_film = $film->copy; +ok $new_film->id; +isnt $new_film->id, $film->id, "copy() gets new primary key"; + +$new_film = $film->copy(42); +is $new_film->id, 42, "copy() with new id"; + diff --git a/t/cdbi-t/discard_changes_in_DESTROY.t b/t/cdbi-t/discard_changes_in_DESTROY.t new file mode 100644 index 0000000..950d9bd --- /dev/null +++ b/t/cdbi-t/discard_changes_in_DESTROY.t @@ -0,0 +1,29 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +BEGIN { + eval "use DBIx::Class::CDBICompat;"; + plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@") + : (tests=> 1); +} + +INIT { + use lib 't/testlib'; + use Film; +} + +{ + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, @_; }; + { + # Test that this doesn't cause infinite recursion. + local *Film::DESTROY; + local *Film::DESTROY = sub { $_[0]->discard_changes }; + + my $film = Film->insert({ Title => "Eegah!" }); + $film->director("Arch Hall Sr."); + } + is_deeply \@warnings, []; +} \ No newline at end of file diff --git a/t/cdbi-t/hasa_without_loading.t b/t/cdbi-t/hasa_without_loading.t new file mode 100644 index 0000000..5b8cbdf --- /dev/null +++ b/t/cdbi-t/hasa_without_loading.t @@ -0,0 +1,23 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +BEGIN { + eval "use DBIx::Class::CDBICompat;"; + plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required') + : (tests=> 3); +} + +package Foo; + +use base qw(Class::DBI); + +eval { + Foo->table("foo"); + Foo->columns(Essential => qw(foo bar)); + Foo->has_a( bar => "This::Does::Not::Exist::Yet" ); +}; +::is $@, ''; +::is(Foo->table, "foo"); +::is_deeply [sort map lc, Foo->columns], [sort map lc, qw(foo bar)]; diff --git a/t/cdbi-t/max_min_value_of.t b/t/cdbi-t/max_min_value_of.t new file mode 100644 index 0000000..f4a0bda --- /dev/null +++ b/t/cdbi-t/max_min_value_of.t @@ -0,0 +1,34 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +#---------------------------------------------------------------------- +# Test database failures +#---------------------------------------------------------------------- + +BEGIN { + eval "use DBIx::Class::CDBICompat;"; + if ($@) { + plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required'); + next; + } + eval "use DBD::SQLite"; + plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 2); +} + +use lib 't/testlib'; +use Film; + +Film->create({ + title => "Bad Taste", + numexplodingsheep => 10, +}); + +Film->create({ + title => "Evil Alien Conquerers", + numexplodingsheep => 2, +}); + +is( Film->maximum_value_of("numexplodingsheep"), 10 ); +is( Film->minimum_value_of("numexplodingsheep"), 2 ); diff --git a/t/cdbi-t/multi_column_set.t b/t/cdbi-t/multi_column_set.t new file mode 100644 index 0000000..eb985e3 --- /dev/null +++ b/t/cdbi-t/multi_column_set.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +BEGIN { + eval "use DBIx::Class::CDBICompat;"; + plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@") + : (tests=> 3); +} + +{ + package Thing; + + use base 'DBIx::Class::Test::SQLite'; + + Thing->columns(TEMP => qw[foo bar baz]); + Thing->columns(All => qw[some real stuff]); +} + +my $thing = Thing->construct({ foo => 23, some => 42, baz => 99 }); +$thing->set( foo => "wibble", some => "woosh" ); +is $thing->foo, "wibble"; +is $thing->some, "woosh"; +is $thing->baz, 99; + +$thing->discard_changes; diff --git a/t/cdbi-t/retrieve_from_sql_with_limit.t b/t/cdbi-t/retrieve_from_sql_with_limit.t new file mode 100644 index 0000000..e0c452d --- /dev/null +++ b/t/cdbi-t/retrieve_from_sql_with_limit.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +BEGIN { + eval "use DBIx::Class::CDBICompat;"; + plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@") + : (tests=> 3); +} + +INIT { + use lib 't/testlib'; + use Film; +} + +for my $title ("Bad Taste", "Braindead", "Forgotten Silver") { + Film->insert({ Title => $title, Director => 'Peter Jackson' }); +} + +Film->insert({ Title => "Transformers", Director => "Michael Bay"}); + +{ + my @films = Film->retrieve_from_sql(qq[director = "Peter Jackson" LIMIT 2]); + is @films, 2, "retrieve_from_sql with LIMIT"; + is( $_->director, "Peter Jackson" ) for @films; +} diff --git a/t/cdbi-t/set_vs_DateTime.t b/t/cdbi-t/set_vs_DateTime.t new file mode 100644 index 0000000..84842bf --- /dev/null +++ b/t/cdbi-t/set_vs_DateTime.t @@ -0,0 +1,28 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +BEGIN { + eval "use DBIx::Class::CDBICompat;"; + plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@" + if $@; + plan skip_all => "DateTime required" unless eval { require DateTime }; + plan tests => 1; +} + +{ + package Thing; + + use base 'DBIx::Class::Test::SQLite'; + + Thing->columns(All => qw[thing_id this that date]); +} + +my $thing = Thing->construct({ thing_id => 23, date => "01-02-1994" }); +eval { + $thing->set( date => DateTime->now ); +}; +is $@, ''; + +$thing->discard_changes; diff --git a/t/deleting_many_to_many.t b/t/deleting_many_to_many.t new file mode 100644 index 0000000..5613721 --- /dev/null +++ b/t/deleting_many_to_many.t @@ -0,0 +1,23 @@ +#!/usr/bin/perl -w + +use strict; +use warnings; + +use Test::More; +use lib qw(t/lib); +use DBICTest; + +my $schema = DBICTest->init_schema(); + +plan tests => 5; + +my $cd = $schema->resultset("CD")->find(2); +ok $cd->liner_notes; +ok keys %{$cd->{_relationship_data}}, "_relationship_data populated"; + +$cd->discard_changes; +ok $cd->liner_notes, 'relationships still valid after discarding changes'; + +ok $cd->liner_notes->delete; +$cd->discard_changes; +ok !$cd->liner_notes, 'discard_changes resets relationship'; \ No newline at end of file diff --git a/t/relationship_after_update.t b/t/relationship_after_update.t new file mode 100644 index 0000000..aaf7300 --- /dev/null +++ b/t/relationship_after_update.t @@ -0,0 +1,30 @@ +#!/usr/bin/perl -w + +use strict; +use warnings; + +use Test::More; +use lib qw(t/lib); +use DBICTest; + +my $schema = DBICTest->init_schema(); + +plan tests => 2; + +my $bookmark = $schema->resultset("Bookmark")->find(1); +my $link = $bookmark->link; +my $link_id = $link->id; + +my $new_link = $schema->resultset("Link")->new({ + id => 42, + url => "http://monstersarereal.com", + title => "monstersarereal.com" +}); + +# Changing a relationship by id rather than by object would cause +# old related_resultsets to be used. +$bookmark->link($new_link->id); +is $bookmark->link->id, $new_link->id; + +$bookmark->update; +is $bookmark->link->id, $new_link->id; diff --git a/t/relationship_doesnt_exist.t b/t/relationship_doesnt_exist.t new file mode 100644 index 0000000..d440b52 --- /dev/null +++ b/t/relationship_doesnt_exist.t @@ -0,0 +1,30 @@ +#!/usr/bin/perl -w + +use strict; +use warnings; + +use Test::More; +use lib qw(t/lib); +use DBICTest; + +my $schema = DBICTest->init_schema(); + +plan tests => 3; + +my $bookmark = $schema->resultset("Bookmark")->find(1); +my $link = $bookmark->link; +my $link_id = $link->id; +ok $link->id; + +$link->delete; +is $schema->resultset("Link")->search(id => $link_id)->count, 0, + "link $link_id was deleted"; + +# Get a fresh object with nothing cached +$bookmark = $schema->resultset("Bookmark")->find($bookmark->id); + +# This would create a new link row if none existed +$bookmark->link; + +is $schema->resultset("Link")->search(id => $link_id)->count, 0, + 'accessor did not create a link object where there was none'; diff --git a/t/resultset_overload.t b/t/resultset_overload.t new file mode 100644 index 0000000..c5ecce8 --- /dev/null +++ b/t/resultset_overload.t @@ -0,0 +1,26 @@ +use strict; +use warnings; + +use Test::More; +use lib qw(t/lib); +use DBICTest; + +my $schema = DBICTest->init_schema(); + +plan tests => 6; + +{ + my $rs = $schema->resultset("CD")->search({}); + + ok $rs->count; + is $rs, $rs->count, "resultset as number with results"; + ok $rs, "resultset as boolean always true"; +} + +{ + my $rs = $schema->resultset("CD")->search({ title => "Does not exist" }); + + ok !$rs->count; + is $rs, $rs->count, "resultset as number without results"; + ok $rs, "resultset as boolean always true"; +} \ No newline at end of file