Revision history for DBIx::Class
+ - multi-create using find_or_create rather than _related for post-insert
+ - fix get_inflated_columns to check has_column_loaded
- Add DBIC_MULTICREATE_DEBUG env var (undocumented, quasi-internal)
- Fix up multi-create to:
- correctly propagate columns loaded during multi-insert of rels
containing all statements to be executed
- Add as_query() for ResultSet and ResultSetColumn. This makes subqueries
possible. See the Cookbook for details. (robkinyon, michaelr)
+ - Massive rewrite of Ordered to properly handle position constraints and
+ to make it more matpath-friendly
0.08099_06 2009-01-23 07:30:00 (UTC)
- Allow a scalarref to be supplied to the 'from' resultset attribute
perl_version '5.006001';
all_from 'lib/DBIx/Class.pm';
-requires 'Data::Page' => 2.00;
-requires 'Scalar::Util' => 0;
-requires 'SQL::Abstract' => 1.24;
-requires 'SQL::Abstract::Limit' => 0.13;
-requires 'Class::C3' => 0.20;
-requires 'Class::C3::Componentised' => 0;
-requires 'Storable' => 0;
-requires 'Carp::Clan' => 0;
-requires 'DBI' => 1.40;
-requires 'Module::Find' => 0;
-requires 'Class::Inspector' => 0;
-requires 'Class::Accessor::Grouped' => 0.08002;
-requires 'JSON::Any' => 1.17;
-requires 'Scope::Guard' => 0.03;
-requires 'Path::Class' => 0;
-requires 'List::Util' => 1.19;
-requires 'Sub::Name' => 0.04;
-requires 'namespace::clean' => 0.09;
+requires 'Data::Page' => 2.00;
+requires 'Scalar::Util' => 0;
+requires 'SQL::Abstract' => 1.49;
+requires 'SQL::Abstract::Limit' => 0.13;
+requires 'Class::C3' => 0.20;
+requires 'Class::C3::Componentised' => 0;
+requires 'Storable' => 0;
+requires 'Carp::Clan' => 0;
+requires 'DBI' => 1.40;
+requires 'Module::Find' => 0;
+requires 'Class::Inspector' => 0;
+requires 'Class::Accessor::Grouped' => 0.08002;
+requires 'JSON::Any' => 1.17;
+requires 'Scope::Guard' => 0.03;
+requires 'Path::Class' => 0;
+requires 'List::Util' => 1.19;
+requires 'Sub::Name' => 0.04;
+requires 'namespace::clean' => 0.09;
# Perl 5.8.0 doesn't have utf8::is_utf8()
-requires 'Encode' => 0 if ($] <= 5.008000);
+requires 'Encode' => 0 if ($] <= 5.008000);
-configure_requires 'DBD::SQLite' => 1.14;
+configure_requires 'DBD::SQLite' => 1.14;
test_requires 'Test::Builder' => 0.33;
test_requires 'Test::Warn' => 0.11;
test_requires 'Test::Exception' => 0;
test_requires 'Test::Deep' => 0;
+recommends 'SQL::Translator' => 0.09004;
+
install_script 'script/dbicadmin';
tests_recursive 't';
# re-build README and require CDBI modules for testing if we're in a checkout
-my @force_build_requires_if_author = qw(
- DBIx::ContextualFetch
- Class::Trigger
- Time::Piece
- Clone
- Test::Pod::Coverage
- Test::Memory::Cycle
+my %force_requires_if_author = (
+ 'DBIx::ContextualFetch' => 0,
+ 'Class::Trigger' => 0,
+ 'Time::Piece' => 0,
+ 'Clone' => 0,
+ 'Test::Pod::Coverage' => 0,
+ 'Test::Memory::Cycle' => 0,
+ 'SQL::Translator' => 0.09004,
);
if ($Module::Install::AUTHOR) {
- foreach my $module (@force_build_requires_if_author) {
- build_requires $module;
+ foreach my $module (keys %force_requires_if_author) {
+ requires ($module => $force_requires_if_author{$module});
}
system('pod2text lib/DBIx/Class.pm > README');
wait();
alarm 0;
};
+ my $exception = $@;
+
my $sig = $? & 127;
- if ($@ || $sig == POSIX::SIGSEGV()) {
+
+# make sure process actually dies
+ $exception && kill POSIX::SIGKILL(), $pid;
+
+ if ($exception || $sig == POSIX::SIGSEGV() || $sig == POSIX::SIGABRT()
+ || $sig == 7) { # 7 == SIGBUS, haven't seen it but just in case
warn (<<EOE);
############################### WARNING #################################
# Need to do this _after_ WriteAll else it looses track of them
Meta->{values}{build_requires} = [ grep {
my $ok = 1;
- foreach my $module (@force_build_requires_if_author) {
+ foreach my $module (keys %force_requires_if_author) {
if ($_->[0] =~ /$module/) {
$ok = 0;
last;
-# vim: ts=8:sw=4:sts=4:et
package DBIx::Class::Ordered;
use strict;
use warnings;
__PACKAGE__->mk_classdata( 'grouping_column' );
+=head2 null_position_value
+
+ __PACKAGE__->null_position_value(undef);
+
+This method specifies a value of L</position_column> which B<would
+never be assigned to a row> during normal operation. When
+a row is moved, its position is set to this value temporarily, so
+that any unique constrainst can not be violated. This value defaults
+to 0, which should work for all cases except when your positions do
+indeed start from 0.
+
+=cut
+
+__PACKAGE__->mk_classdata( 'null_position_value' => 0 );
+
=head2 siblings
my $rs = $item->siblings();
my @siblings = $item->siblings();
-Returns either a resultset or an array of all other objects
-excluding the one you called it on.
+Returns an B<ordered> resultset of all other objects in the same
+group excluding the one you called it on.
-=cut
+The ordering is a backwards-compatibility artifact - if you need
+a resultset with no ordering applied use L</_siblings>
+=cut
sub siblings {
- my( $self ) = @_;
- my $position_column = $self->position_column;
- my $rs = $self->result_source->resultset->search(
- {
- $position_column => { '!=' => $self->get_column($position_column) },
- $self->_grouping_clause(),
- },
- { order_by => $self->position_column },
- );
- return $rs->all() if (wantarray());
- return $rs;
+ my $self = shift;
+ return $self->_siblings->search ({}, { order_by => $self->position_column } );
}
-=head2 first_sibling
+=head2 previous_siblings
- my $sibling = $item->first_sibling();
+ my $prev_rs = $item->previous_siblings();
+ my @prev_siblings = $item->previous_siblings();
-Returns the first sibling object, or 0 if the first sibling
-is this sibling.
+Returns a resultset of all objects in the same group
+positioned before the object on which this method was called.
=cut
-
-sub first_sibling {
- my( $self ) = @_;
- return 0 if ($self->get_column($self->position_column())==1);
-
- return ($self->result_source->resultset->search(
- {
- $self->position_column => 1,
- $self->_grouping_clause(),
- },
- )->all())[0];
+sub previous_siblings {
+ my $self = shift;
+ my $position_column = $self->position_column;
+ my $position = $self->get_column ($position_column);
+ return ( defined $position
+ ? $self->_siblings->search ({ $position_column => { '<', $position } })
+ : $self->_siblings
+ );
}
-=head2 last_sibling
+=head2 next_siblings
- my $sibling = $item->last_sibling();
+ my $next_rs = $item->next_siblings();
+ my @next_siblings = $item->next_siblings();
-Returns the last sibling, or 0 if the last sibling is this
-sibling.
+Returns a resultset of all objects in the same group
+positioned after the object on which this method was called.
=cut
-
-sub last_sibling {
- my( $self ) = @_;
- my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
- return 0 if ($self->get_column($self->position_column())==$count);
- return ($self->result_source->resultset->search(
- {
- $self->position_column => $count,
- $self->_grouping_clause(),
- },
- )->all())[0];
+sub next_siblings {
+ my $self = shift;
+ my $position_column = $self->position_column;
+ my $position = $self->get_column ($position_column);
+ return ( defined $position
+ ? $self->_siblings->search ({ $position_column => { '>', $position } })
+ : $self->_siblings
+ );
}
=head2 previous_sibling
my $sibling = $item->previous_sibling();
-Returns the sibling that resides one position back. Returns undef
+Returns the sibling that resides one position back. Returns 0
if the current object is the first one.
=cut
sub previous_sibling {
- my( $self ) = @_;
+ my $self = shift;
my $position_column = $self->position_column;
- my $position = $self->get_column( $position_column );
- return 0 if ($position==1);
- return ($self->result_source->resultset->search(
- {
- $position_column => $position - 1,
- $self->_grouping_clause(),
- }
- )->all())[0];
+
+ my $psib = $self->previous_siblings->search(
+ {},
+ { rows => 1, order_by => { '-desc' => $position_column } },
+ )->single;
+
+ return defined $psib ? $psib : 0;
+}
+
+=head2 first_sibling
+
+ my $sibling = $item->first_sibling();
+
+Returns the first sibling object, or 0 if the first sibling
+is this sibling.
+
+=cut
+
+sub first_sibling {
+ my $self = shift;
+ my $position_column = $self->position_column;
+
+ my $fsib = $self->previous_siblings->search(
+ {},
+ { rows => 1, order_by => { '-asc' => $position_column } },
+ )->single;
+
+ return defined $fsib ? $fsib : 0;
}
=head2 next_sibling
my $sibling = $item->next_sibling();
-Returns the sibling that resides one position forward. Returns undef
+Returns the sibling that resides one position forward. Returns 0
if the current object is the last one.
=cut
sub next_sibling {
- my( $self ) = @_;
+ my $self = shift;
+ my $position_column = $self->position_column;
+ my $nsib = $self->next_siblings->search(
+ {},
+ { rows => 1, order_by => { '-asc' => $position_column } },
+ )->single;
+
+ return defined $nsib ? $nsib : 0;
+}
+
+=head2 last_sibling
+
+ my $sibling = $item->last_sibling();
+
+Returns the last sibling, or 0 if the last sibling is this
+sibling.
+
+=cut
+
+sub last_sibling {
+ my $self = shift;
my $position_column = $self->position_column;
- my $position = $self->get_column( $position_column );
- my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
- return 0 if ($position==$count);
- return ($self->result_source->resultset->search(
- {
- $position_column => $position + 1,
- $self->_grouping_clause(),
- },
- )->all())[0];
+ my $lsib = $self->next_siblings->search(
+ {},
+ { rows => 1, order_by => { '-desc' => $position_column } },
+ )->single;
+
+ return defined $lsib ? $lsib : 0;
}
=head2 move_previous
=cut
sub move_previous {
- my( $self ) = @_;
- my $position = $self->get_column( $self->position_column() );
- return $self->move_to( $position - 1 );
+ my $self = shift;
+ return $self->move_to ($self->_position - 1);
}
=head2 move_next
=cut
sub move_next {
- my( $self ) = @_;
- my $position = $self->get_column( $self->position_column() );
- my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
- return 0 if ($position==$count);
- return $self->move_to( $position + 1 );
+ my $self = shift;
+ return 0 unless $self->next_siblings->count;
+ return $self->move_to ($self->_position + 1);
}
=head2 move_first
=cut
sub move_first {
- my( $self ) = @_;
- return $self->move_to( 1 );
+ return shift->move_to( 1 );
}
=head2 move_last
=cut
sub move_last {
- my( $self ) = @_;
- my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
- return $self->move_to( $count );
+ my $self = shift;
+ return $self->move_to( $self->_group_rs->count );
}
=head2 move_to
sub move_to {
my( $self, $to_position ) = @_;
- my $position_column = $self->position_column;
- my $from_position = $self->get_column( $position_column );
return 0 if ( $to_position < 1 );
- return 0 if ( $from_position==$to_position );
- my @between = (
- ( $from_position < $to_position )
- ? ( $from_position+1, $to_position )
- : ( $to_position, $from_position-1 )
- );
- my $rs = $self->result_source->resultset->search({
- $position_column => { -between => [ @between ] },
- $self->_grouping_clause(),
- });
- my $op = ($from_position>$to_position) ? '+' : '-';
- $rs->update({ $position_column => \"$position_column $op 1" }); #" Sorry, GEdit bug
- $self->{_ORDERED_INTERNAL_UPDATE} = 1;
- $self->update({ $position_column => $to_position });
- return 1;
-}
+ my $from_position = $self->_position;
+ return 0 if ( $from_position == $to_position );
+
+ my $position_column = $self->position_column;
+
+ # FIXME this needs to be wrapped in a transaction
+ {
+ my ($direction, @between);
+ if ( $from_position < $to_position ) {
+ $direction = -1;
+ @between = map { $self->_position_value ($_) } ( $from_position + 1, $to_position );
+ }
+ else {
+ $direction = 1;
+ @between = map { $self->_position_value ($_) } ( $to_position, $from_position - 1 );
+ }
+
+ my $new_pos_val = $self->_position_value ($to_position); # record this before the shift
+ $self->_ordered_internal_update({ $position_column => $self->null_position_value }); # take the row out of the picture for a bit
+ $self->_shift_siblings ($direction, @between);
+ $self->_ordered_internal_update({ $position_column => $new_pos_val });
+ return 1;
+ }
+}
=head2 move_to_group
sub move_to_group {
my( $self, $to_group, $to_position ) = @_;
+ $self->throw_exception ('move_to_group() expects a group specification')
+ unless defined $to_group;
+
# if we're given a string, turn it into a hashref
unless (ref $to_group eq 'HASH') {
- $to_group = {($self->_grouping_columns)[0] => $to_group};
+ my @gcols = $self->_grouping_columns;
+
+ $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1;
+ $to_group = {$gcols[0] => $to_group};
}
my $position_column = $self->position_column;
- #my @grouping_columns = $self->_grouping_columns;
- return 0 if ( ! defined($to_group) );
return 0 if ( defined($to_position) and $to_position < 1 );
- return 0 if ( $self->_is_in_group($to_group)
- and ((not defined($to_position))
- or (defined($to_position) and $self->$position_column==$to_position)
- )
- );
-
- # Move to end of current group and adjust siblings
- $self->move_last;
-
- $self->set_columns($to_group);
- my $new_group_count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
- if (!defined($to_position) or $to_position > $new_group_count) {
- $self->{_ORDERED_INTERNAL_UPDATE} = 1;
- $self->update({ $position_column => $new_group_count + 1 });
- }
- else {
- my @between = ($to_position, $new_group_count);
-
- my $rs = $self->result_source->resultset->search({
- $position_column => { -between => [ @between ] },
- $self->_grouping_clause(),
- });
- $rs->update({ $position_column => \"$position_column + 1" }); #"
- $self->{_ORDERED_INTERNAL_UPDATE} = 1;
- $self->update({ $position_column => $to_position });
+ if ($self->_is_in_group ($to_group) ) {
+ return 0 if not defined $to_position;
+ return $self->move_to ($to_position);
}
- return 1;
+ # FIXME this needs to be wrapped in a transaction
+ {
+ # Move to end of current group to adjust siblings
+ $self->move_last;
+
+ $self->set_inflated_columns({ %$to_group, $position_column => undef });
+ my $new_group_count = $self->_group_rs->count;
+
+ if ( not defined($to_position) or $to_position > $new_group_count) {
+ $self->set_column(
+ $position_column => $new_group_count
+ ? $self->_next_position_value ( $self->last_sibling->get_column ($position_column) ) # FIXME - no need to inflate last_sibling
+ : $self->_initial_position_value
+ );
+ }
+ else {
+ my $bumped_pos_val = $self->_position_value ($to_position);
+ my @between = ($to_position, $new_group_count);
+ $self->_shift_siblings (1, @between); #shift right
+ $self->set_column( $position_column => $bumped_pos_val );
+ }
+
+ $self->_ordered_internal_update;
+
+ return 1;
+ }
}
=head2 insert
sub insert {
my $self = shift;
my $position_column = $self->position_column;
- $self->set_column( $position_column => $self->result_source->resultset->search( {$self->_grouping_clause()} )->count()+1 )
- if (!$self->get_column($position_column));
+
+ unless ($self->get_column($position_column)) {
+ my $lsib = $self->last_sibling; # FIXME - no need to inflate last_sibling
+ $self->set_column(
+ $position_column => ($lsib
+ ? $self->_next_position_value ( $lsib->get_column ($position_column) )
+ : $self->_initial_position_value
+ )
+ );
+ }
+
return $self->next::method( @_ );
}
sub update {
my $self = shift;
- if ($self->{_ORDERED_INTERNAL_UPDATE}) {
- delete $self->{_ORDERED_INTERNAL_UPDATE};
- return $self->next::method( @_ );
- }
+ # this is set by _ordered_internal_update()
+ return $self->next::method(@_) if $self->{_ORDERED_INTERNAL_UPDATE};
- $self->set_columns($_[0]) if @_ > 0;
+ my $upd = shift;
+ $self->set_inflated_columns($upd) if $upd;
my %changes = $self->get_dirty_columns;
$self->discard_changes;
- my $pos_col = $self->position_column;
+ my $position_column = $self->position_column;
- # if any of our grouping columns have been changed
- if (grep {$_} map {exists $changes{$_}} $self->_grouping_columns ) {
+ # if nothing group/position related changed - short circuit
+ if (not grep { exists $changes{$_} } ($self->_grouping_columns, $position_column) ) {
+ return $self->next::method( \%changes, @_ );
+ }
- # create new_group by taking the current group and inserting changes
- my $new_group = {$self->_grouping_clause};
- foreach my $col (keys %$new_group) {
- if (exists $changes{$col}) {
- $new_group->{$col} = $changes{$col};
- delete $changes{$col}; # don't want to pass this on to next::method
+ # FIXME this needs to be wrapped in a transaction
+ {
+ # if any of our grouping columns have been changed
+ if (grep { exists $changes{$_} } ($self->_grouping_columns) ) {
+
+ # create new_group by taking the current group and inserting changes
+ my $new_group = {$self->_grouping_clause};
+ foreach my $col (keys %$new_group) {
+ if (exists $changes{$col}) {
+ $new_group->{$col} = delete $changes{$col}; # don't want to pass this on to next::method
+ }
}
+
+ $self->move_to_group(
+ $new_group,
+ (exists $changes{$position_column}
+ # The FIXME bit contradicts the documentation: when changing groups without supplying explicit
+ # positions in move_to_group(), we push the item to the end of the group.
+ # However when I was rewriting this, the position from the old group was clearly passed to the new one
+ # Probably needs to go away (by ribasushi)
+ ? delete $changes{$position_column} # means there was a position change supplied with the update too
+ : $self->_position # FIXME!
+ ),
+ );
+ }
+ elsif (exists $changes{$position_column}) {
+ $self->move_to(delete $changes{$position_column});
}
- $self->move_to_group(
- $new_group,
- exists($changes{$pos_col}) ? delete($changes{$pos_col}) : $self->$pos_col
- );
- }
- elsif (exists $changes{$pos_col}) {
- $self->move_to(delete $changes{$pos_col});
+ return $self->next::method( \%changes, @_ );
}
- return $self->next::method( \%changes );
}
=head2 delete
Overrides the DBIC delete() method by first moving the object
-to the last position, then deleting it, thus ensuring the
+to the last position, then deleting it, thus ensuring the
integrity of the positions.
=cut
sub delete {
my $self = shift;
- $self->move_last;
- return $self->next::method( @_ );
+ # FIXME this needs to be wrapped in a transaction
+ {
+ $self->move_last;
+ return $self->next::method( @_ );
+ }
+}
+
+=head1 Methods for extending Ordered
+
+You would want to override the methods below if you use sparse
+(non-linear) or non-numeric position values. This can be useful
+if you are working with preexisting non-normalised position data,
+or if you need to work with materialized path columns.
+
+=head2 _position
+
+ my $num_pos = $item->_position;
+
+Returns the absolute numeric position of the current object, with the
+first object being at position 1, its sibling at position 2 and so on.
+By default simply returns the value of L</position_column>.
+
+=cut
+sub _position {
+ my $self = shift;
+
+# #the right way to do this
+# return $self->previous_siblings->count + 1;
+
+ return $self->get_column ($self->position_column);
+}
+
+=head2 _position_value
+
+ my $pos_value = $item->_position_value ( $pos )
+
+Returns the value of L</position_column> of the object at numeric
+position C<$pos>. By default simply returns C<$pos>.
+
+=cut
+sub _position_value {
+ my ($self, $pos) = @_;
+
+# #the right way to do this (not optimized)
+# my $position_column = $self->position_column;
+# return $self -> _group_rs
+# -> search({}, { order_by => $position_column })
+# -> slice ( $pos - 1)
+# -> single
+# -> get_column ($position_column);
+
+ return $pos;
+}
+
+=head2 _initial_position_value
+
+ __PACKAGE__->_initial_position_value(0);
+
+This method specifies a value of L</position_column> which is assigned
+to the first inserted element of a group, if no value was supplied at
+insertion time. All subsequent values are derived from this one by
+L</_next_position_value> below. Defaults to 1.
+
+=cut
+
+__PACKAGE__->mk_classdata( '_initial_position_value' => 1 );
+
+=head2 _next_position_value
+
+ my $new_value = $item->_next_position_value ( $position_value )
+
+Returns a position value that would be considered C<next> with
+regards to C<$position_value>. Can be pretty much anything, given
+that C<< $position_value < $new_value >> where C<< < >> is the
+SQL comparison operator (usually works fine on strings). The
+default method expects C<$position_value> to be numeric, and
+returns C<$position_value + 1>
+
+=cut
+sub _next_position_value {
+ return $_[1] + 1;
+}
+
+=head2 _shift_siblings
+
+ $item->_shift_siblings ($direction, @between)
+
+Shifts all siblings with position in the range @between (inclusive)
+by one position as specified by $direction (left if < 0, right if > 0).
+By default simply increments/decrements each L<position_column> value
+by 1.
+
+=cut
+sub _shift_siblings {
+ my ($self, $direction, @between) = @_;
+ return 0 unless $direction;
+
+ my $position_column = $self->position_column;
+
+ my ($op, $ord);
+ if ($direction < 0) {
+ $op = '-';
+ $ord = 'asc';
+ }
+ else {
+ $op = '+';
+ $ord = 'desc';
+ }
+
+ my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } });
+
+ # some databases (sqlite) are dumb and can not do a blanket
+ # increment/decrement. So what we do here is check if the
+ # position column is part of a unique constraint, and do a
+ # one-by-one update if this is the case
+
+ my %uc = $self->result_source->unique_constraints;
+ if (grep { $_ eq $position_column } ( map { @$_ } (values %uc) ) ) {
+
+ my $rs = $shift_rs->search ({}, { order_by => { "-$ord", $position_column } } );
+ # FIXME - no need to inflate each row
+ while (my $r = $rs->next) {
+ $r->_ordered_internal_update ({ $position_column => \ "$position_column $op 1" } );
+ }
+ }
+ else {
+ $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
+ }
}
=head1 PRIVATE METHODS
These methods are used internally. You should never have the
need to use them.
+=head2 _group_rs
+
+This method returns a resultset containing all memebers of the row
+group (including the row itself).
+
+=cut
+sub _group_rs {
+ my $self = shift;
+ return $self->result_source->resultset->search({$self->_grouping_clause()});
+}
+
+=head2 _siblings
+
+Returns an unordered resultset of all objects in the same group
+excluding the object you called this method on.
+
+=cut
+sub _siblings {
+ my $self = shift;
+ my $position_column = $self->position_column;
+ return $self->_group_rs->search(
+ { $position_column => { '!=' => $self->get_column($position_column) } },
+ );
+}
+
=head2 _grouping_clause
-This method returns one or more name=>value pairs for limiting a search
-by the grouping column(s). If the grouping column is not
+This method returns one or more name=>value pairs for limiting a search
+by the grouping column(s). If the grouping column is not
defined then this will return an empty list.
=cut
return map { $_ => $self->get_column($_) } $self->_grouping_columns();
}
-
-
=head2 _get_grouping_columns
Returns a list of the column names used for grouping, regardless of whether
}
}
-
-
-=head2 _is_in_group($other)
+=head2 _is_in_group
$item->_is_in_group( {user => 'fred', list => 'work'} )
Returns true if the object is in the group represented by hashref $other
+
=cut
sub _is_in_group {
my ($self, $other) = @_;
my $current = {$self->_grouping_clause};
- return 0 unless (ref $other eq 'HASH') and (keys %$current == keys %$other);
+
+ no warnings qw/uninitialized/;
+
+ return 0 if (
+ join ("\x00", sort keys %$current)
+ ne
+ join ("\x00", sort keys %$other)
+ );
for my $key (keys %$current) {
- return 0 unless exists $other->{$key};
return 0 if $current->{$key} ne $other->{$key};
}
return 1;
}
+sub _ordered_internal_update {
+ my $self = shift;
+ local $self->{_ORDERED_INTERNAL_UPDATE} = 1;
+ return $self->update (@_);
+}
1;
-__END__
-
-=head1 BUGS
-=head2 Unique Constraints
+__END__
-Unique indexes and constraints on the position column are not
-supported at this time. It would be make sense to support them,
-but there are some unexpected database issues that make this
-hard to do. The main problem from the author's view is that
-SQLite (the DB engine that we use for testing) does not support
-ORDER BY on updates.
+=head1 CAVEATS
=head2 Race Condition on Insert
If a position is not specified for an insert than a position
-will be chosen based on COUNT(*)+1. But, it first selects the
-count, and then inserts the record. The space of time between select
-and insert introduces a race condition. To fix this we need the
-ability to lock tables in DBIC. I've added an entry in the TODO
-about this.
+will be chosen based either on L</_initial_position_value> or
+L</_next_position_value>, depending if there are already some
+items in the current group. The space of time between the
+necessary selects and insert introduces a race condition.
+Having unique constraints on your position/group columns,
+and using transactions (see L<DBIx::Class::Storage/txn_do>)
+will prevent such race conditions going undetected.
=head2 Multiple Moves
Be careful when issueing move_* methods to multiple objects. If
you've pre-loaded the objects then when you move one of the objects
the position of the other object will not reflect their new value
-until you reload them from the database.
+until you reload them from the database - see
+L<DBIx::Class::Row/discard_changes>.
There are times when you will want to move objects as groups, such
as changeing the parent of several objects at once - this directly
A ResultSource is a component of a schema from which results can be directly
retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
+Basic view support also exists, see L<<DBIx::Class::ResultSource::View>.
+
=head1 METHODS
=pod
--- /dev/null
+package DBIx::Class::ResultSource::View;
+
+use strict;
+use warnings;
+
+use DBIx::Class::ResultSet;
+
+use base qw/DBIx::Class/;
+__PACKAGE__->load_components(qw/ResultSource/);
+__PACKAGE__->mk_group_accessors(
+ 'simple' => qw(is_virtual view_definition)
+);
+
+=head1 NAME
+
+DBIx::Class::ResultSource::View - ResultSource object representing a view
+
+=head1 SYNOPSIS
+
+ package MyDB::Schema::Year2000CDs;
+
+ use DBIx::Class::ResultSource::View;
+
+ __PACKAGE__->load_components('Core');
+ __PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+
+ __PACKAGE__->table('year2000cds');
+ __PACKAGE__->result_source_instance->is_virtual(1);
+ __PACKAGE__->result_source_instance->view_definition(
+ "SELECT cdid, artist, title FROM cd WHERE year ='2000'"
+ );
+
+=head1 DESCRIPTION
+
+View object that inherits from L<DBIx::Class::ResultSource>
+
+This class extends ResultSource to add basic view support.
+
+A view has a L</view_definition>, which contains an SQL query. The
+query cannot have parameters. It may contain JOINs, sub selects and
+any other SQL your database supports.
+
+View definition SQL is deployed to your database on
+L<DBIx::Class::Schema/deploy> unless you set L</is_virtual> to true.
+
+Deploying the view does B<not> translate it between different database
+syntaxes, so be careful what you write in your view SQL.
+
+Virtual views (L</is_virtual> unset or false), are assumed to not
+exist in your database as a real view. The L</view_definition> in this
+case replaces the view name in a FROM clause in a subselect.
+
+=head1 SQL EXAMPLES
+
+=over
+
+=item is_virtual set to true
+
+ $schema->resultset('Year2000CDs')->all();
+
+ SELECT cdid, artist, title FROM year2000cds me
+
+=item is_virtual set to false
+
+ $schema->resultset('Year2000CDs')->all();
+
+ SELECT cdid, artist, title FROM
+ (SELECT cdid, artist, title FROM cd WHERE year ='2000') me
+
+=back
+
+=head1 METHODS
+
+=head2 is_virtual
+
+ __PACKAGE__->result_source_instance->is_virtual(1);
+
+Set to true for a virtual view, false or unset for a real
+database-based view.
+
+=head2 view_definition
+
+ __PACKAGE__->result_source_instance->view_definition(
+ "SELECT cdid, artist, title FROM cd WHERE year ='2000'"
+ );
+
+An SQL query for your view. Will not be translated across database
+syntaxes.
+
+
+=head1 OVERRIDDEN METHODS
+
+=head2 from
+
+Returns the FROM entry for the table (i.e. the view name)
+or the SQL as a subselect if this is a virtual view.
+
+=cut
+
+sub from {
+ my $self = shift;
+ return \"(${\$self->view_definition})" if $self->is_virtual;
+ return $self->name;
+}
+
+1;
+
+=head1 AUTHORS
+
+Matt S. Trout <mst@shadowcatsystems.co.uk>
+
+With Contributions from:
+
+Guillermo Roditi E<lt>groditi@cpan.orgE<gt>
+
+Jess Robinson <castaway@desert-island.me.uk>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
sub __new_related_find_or_new_helper {
my ($self, $relname, $data) = @_;
if ($self->__their_pk_needs_us($relname, $data)) {
+ MULTICREATE_DEBUG and warn "MC $self constructing $relname via new_result";
return $self->result_source
->related_source($relname)
->resultset
->new_result($data);
}
if ($self->result_source->pk_depends_on($relname, $data)) {
+ MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new";
return $self->result_source
->related_source($relname)
->resultset
- ->find_or_create($data);
+ ->find_or_new($data);
}
+ MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new_related";
return $self->find_or_new_related($relname, $data);
}
$relname, { $rel_obj->get_columns }
);
- MULTICREATE_DEBUG and warn "MC $self pre-inserting $relname $rel_obj\n";
+ MULTICREATE_DEBUG and warn "MC $self pre-reconstructing $relname $rel_obj\n";
- $rel_obj->insert();
+ my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_inflated_columns };
+ my $re = $self->result_source
+ ->related_source($relname)
+ ->resultset
+ ->find_or_create($them);
+ %{$rel_obj} = %{$re};
$self->set_from_related($relname, $rel_obj);
delete $related_stuff{$relname};
}
MULTICREATE_DEBUG and warn "MC $self skipping post-insert on $relname";
} else {
MULTICREATE_DEBUG and warn "MC $self re-creating $relname $obj";
- my $re = $self->find_or_create_related($relname, $them);
+ my $re = $self->result_source
+ ->related_source($relname)
+ ->resultset
+ ->find_or_create($them);
%{$obj} = %{$re};
MULTICREATE_DEBUG and warn "MC $self new $relname $obj";
}
return map {
my $accessor = $self->column_info($_)->{'accessor'} || $_;
($_ => $self->$accessor);
- } $self->columns;
+ } grep $self->has_column_loaded($_), $self->columns;
}
=head2 set_column
local *Class::C3::reinitialize = sub { };
use warnings 'redefine';
- foreach my $result (keys %results) {
+ # ensure classes are loaded and fetch properly sorted classes
+ $class->ensure_class_loaded($_) foreach(values %results);
+ my @subclass_last = sort { $results{$a}->isa($results{$b}) } keys(%results);
+
+ foreach my $result (@subclass_last) {
my $result_class = $results{$result};
- $class->ensure_class_loaded($result_class);
my $rs_class = delete $resultsets{$result};
my $rs_set = $result_class->resultset_class;
+
if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') {
if($rs_class && $rs_class ne $rs_set) {
warn "We found ResultSet class '$rs_class' for '$result', but it seems "
}
- foreach my $moniker (sort @monikers)
+ my(@table_monikers, @view_monikers);
+ for my $moniker (@monikers){
+ my $source = $dbicschema->source($moniker);
+ if ( $source->isa('DBIx::Class::ResultSource::Table') ) {
+ push(@table_monikers, $moniker);
+ } elsif( $source->isa('DBIx::Class::ResultSource::View') ){
+ next if $source->is_virtual;
+ push(@view_monikers, $moniker);
+ }
+ }
+
+ foreach my $moniker (sort @table_monikers)
{
my $source = $dbicschema->source($moniker);
$source->_invoke_sqlt_deploy_hook($table);
}
+ foreach my $moniker (sort @view_monikers)
+ {
+ my $source = $dbicschema->source($moniker);
+ # Skip custom query sources
+ next if ref($source->name);
+
+ # Its possible to have multiple DBIC source using same table
+ next if $seen_tables{$source->name}++;
+
+ my $view = $schema->add_view(
+ name => $source->name,
+ fields => [ $source->columns ],
+ $source->view_definition ? ( 'sql' => $source->view_definition ) : ()
+ );
+ if ($source->result_class->can('sqlt_deploy_hook')) {
+ $source->result_class->sqlt_deploy_hook($view);
+ }
+ }
+
if ($dbicschema->can('sqlt_deploy_hook')) {
$dbicschema->sqlt_deploy_hook($schema);
}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 2;
+
+## Real view
+my $cds_rs_2000 = $schema->resultset('CD')->search( { year => 2000 });
+my $year2kcds_rs = $schema->resultset('Year2000CDs');
+
+is($cds_rs_2000->count, $year2kcds_rs->count, 'View Year2000CDs sees all CDs in year 2000');
+
+
+## Virtual view
+my $cds_rs_1999 = $schema->resultset('CD')->search( { year => 1999 });
+my $year1999cds_rs = $schema->resultset('Year1999CDs');
+
+is($cds_rs_1999->count, $year1999cds_rs->count, 'View Year1999CDs sees all CDs in year 1999');
+
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+
+use lib 't/lib';
+
+plan tests => 4;
+
+sub _chk_warning {
+ defined $_[0]?
+ $_[0] !~ qr/We found ResultSet class '([^']+)' for '([^']+)', but it seems that you had already set '([^']+)' to use '([^']+)' instead/ :
+ 1
+}
+
+my $warnings;
+eval {
+ local $SIG{__WARN__} = sub { $warnings .= shift };
+ package DBICNSTest::RtBug41083;
+ use base 'DBIx::Class::Schema';
+ __PACKAGE__->load_namespaces(
+ result_namespace => 'Schema_A',
+ resultset_namespace => 'ResultSet_A',
+ default_resultset_class => 'ResultSet'
+ );
+};
+ok(!$@) or diag $@;
+ok(_chk_warning($warnings), 'expected no complaint');
+
+eval {
+ local $SIG{__WARN__} = sub { $warnings .= shift };
+ package DBICNSTest::RtBug41083;
+ use base 'DBIx::Class::Schema';
+ __PACKAGE__->load_namespaces(
+ result_namespace => 'Schema',
+ resultset_namespace => 'ResultSet',
+ default_resultset_class => 'ResultSet'
+ );
+};
+ok(!$@) or diag $@;
+ok(_chk_warning($warnings), 'expected no complaint') or diag $warnings;
use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
my $schema = DBICTest->init_schema();
-plan tests => 88;
+plan tests => 90;
eval { require DateTime::Format::MySQL };
my $NO_DTFM = $@ ? 1 : 0;
cmp_ok($art[0]->artistid, '==', 3,'Correct artist too');
-$art->delete;
+lives_ok (sub { $art->delete }, 'Cascading delete on Ordered has_many works' ); # real test in ordered.t
@art = $schema->resultset("Artist")->search({ });
ok(!$art->in_storage, "It knows it's dead");
-eval { $art->delete; };
-
-ok($@, "Can't delete twice: $@");
+dies_ok ( sub { $art->delete }, "Can't delete twice");
is($art->name, 'We Are In Rehab', 'But the object is still live');
$new = $schema->resultset("Track")->new( {
trackid => 100,
cd => 1,
- position => 4,
title => 'Insert or Update',
last_updated_on => '1973-07-19 12:01:02'
} );
ok($new->in_storage, 'update_or_insert insert ok');
# test in update mode
-$new->pos(5);
+$new->title('Insert or Update - updated');
$new->update_or_insert;
-is( $schema->resultset("Track")->find(100)->pos, 5, 'update_or_insert update ok');
+is( $schema->resultset("Track")->find(100)->title, 'Insert or Update - updated', 'update_or_insert update ok');
# get_inflated_columns w/relation and accessor alias
SKIP: {
is($tdata{'trackid'}, 100, 'got id');
isa_ok($tdata{'cd'}, 'DBICTest::CD', 'cd is CD object');
is($tdata{'cd'}->id, 1, 'cd object is id 1');
- is($tdata{'position'}, 5, 'got position from pos');
- is($tdata{'title'}, 'Insert or Update');
+ is(
+ $tdata{'position'},
+ $schema->resultset ('Track')->search ({cd => 1})->count,
+ 'Ordered assigned proper position',
+ );
+ is($tdata{'title'}, 'Insert or Update - updated');
is($tdata{'last_updated_on'}, '1973-07-19T12:01:02');
isa_ok($tdata{'last_updated_on'}, 'DateTime', 'inflated accessored column');
}
my $newbook = $schema->resultset( 'Bookmark' )->find(1);
-$@ = '';
-eval {
-my $newlink = $newbook->link;
-};
-ok(!$@, "stringify to false value doesn't cause error");
+lives_ok (sub { my $newlink = $newbook->link}, "stringify to false value doesn't cause error");
# test cascade_delete through many_to_many relations
{
my $art_del = $schema->resultset("Artist")->find({ artistid => 1 });
- $art_del->delete;
+ lives_ok (sub { $art_del->delete }, 'Cascading delete on Ordered has_many works' ); # real test in ordered.t
cmp_ok( $schema->resultset("CD")->search({artist => 1}), '==', 0, 'Cascading through has_many top level.');
cmp_ok( $schema->resultset("CD_to_Producer")->search({cd => 1}), '==', 0, 'Cascading through has_many children.');
}
# test resultsource->table return value when setting
{
my $class = $schema->class('Event');
- diag $class;
my $table = $class->table($class->table);
is($table, $class->table, '->table($table) returns $table');
}
$track = $schema->resultset("Track")->create( {
trackid => 2,
cd => 3,
- position => 99,
title => 'Hidden Track 2'
} );
$track->update_from_related( cd => $cd );
-my $t_cd = ($schema->resultset("Track")->search( cd => 4, position => 99 ))[0]->cd;
+my $t_cd = ($schema->resultset("Track")->search( cd => 4, title => 'Hidden Track 2' ))[0]->cd;
is( $t_cd->cdid, 4, 'update_from_related ok' );
my $schema = DBICTest->init_schema();
-plan tests => 879;
+plan tests => 1269;
my $employees = $schema->resultset('Employee');
$employees->delete();
my $to_group = 1;
my $to_pos = undef;
while (my $employee = $group_3->next) {
+ $employee->discard_changes; # since we are effective shift()ing the $rs
$employee->move_to_group($to_group, $to_pos);
$to_pos++;
$to_group = $to_group==1 ? 2 : 1;
);
# multicol tests begin here
-DBICTest::Employee->grouping_column(['group_id', 'group_id_2']);
+DBICTest::Employee->grouping_column(['group_id_2', 'group_id_3']);
$employees->delete();
-foreach my $group_id (1..4) {
- foreach my $group_id_2 (1..4) {
+foreach my $group_id_2 (1..4) {
+ foreach my $group_id_3 (1..4) {
foreach (1..4) {
- $employees->create({ name=>'temp', group_id=>$group_id, group_id_2=>$group_id_2 });
+ $employees->create({ name=>'temp', group_id_2=>$group_id_2, group_id_3=>$group_id_3 });
}
}
}
-$employees = $employees->search(undef,{order_by=>'group_id,group_id_2,position'});
+$employees = $employees->search(undef,{order_by=>[qw/group_id_2 group_id_3 position/]});
-foreach my $group_id (1..3) {
- foreach my $group_id_2 (1..3) {
- my $group_employees = $employees->search({group_id=>$group_id, group_id_2=>$group_id_2});
+foreach my $group_id_2 (1..3) {
+ foreach my $group_id_3 (1..3) {
+ my $group_employees = $employees->search({group_id_2=>$group_id_2, group_id_3=>$group_id_3});
$group_employees->all();
ok( check_rs($group_employees), "group intial positions" );
hammer_rs( $group_employees );
}
# move_to_group, specifying group by hash
-my $group_4 = $employees->search({group_id=>4});
+my $group_4 = $employees->search({group_id_2=>4});
$to_group = 1;
my $to_group_2_base = 7;
my $to_group_2 = 1;
$to_pos = undef;
while (my $employee = $group_4->next) {
- $employee->move_to_group({group_id=>$to_group, group_id_2=>$to_group_2}, $to_pos);
+ $employee->move_to_group({group_id_2=>$to_group, group_id_3=>$to_group_2}, $to_pos);
$to_pos++;
$to_group = ($to_group % 3) + 1;
$to_group_2_base++;
$to_group_2 = (ceil($to_group_2_base/3.0) %3) +1
}
-foreach my $group_id (1..4) {
- foreach my $group_id_2 (1..4) {
- my $group_employees = $employees->search({group_id=>$group_id,group_id_2=>$group_id_2});
+foreach my $group_id_2 (1..4) {
+ foreach my $group_id_3 (1..4) {
+ my $group_employees = $employees->search({group_id_2=>$group_id_2,group_id_3=>$group_id_3});
$group_employees->all();
ok( check_rs($group_employees), "group positions after move_to_group" );
}
}
$employees->delete();
-foreach my $group_id (1..4) {
- foreach my $group_id_2 (1..4) {
+foreach my $group_id_2 (1..4) {
+ foreach my $group_id_3 (1..4) {
foreach (1..4) {
- $employees->create({ name=>'temp', group_id=>$group_id, group_id_2=>$group_id_2 });
+ $employees->create({ name=>'temp', group_id_2=>$group_id_2, group_id_3=>$group_id_3 });
}
}
}
-$employees = $employees->search(undef,{order_by=>'group_id,group_id_2,position'});
+$employees = $employees->search(undef,{order_by=>[qw/group_id_2 group_id_3 position/]});
-$employee = $employees->search({group_id=>4, group_id_2=>1})->first;
-$employee->group_id(1);
+$employee = $employees->search({group_id_2=>4, group_id_3=>1})->first;
+$employee->group_id_2(1);
$employee->update;
ok(
- check_rs($employees->search_rs({group_id=>4, group_id_2=>1}))
- && check_rs($employees->search_rs({group_id=>1, group_id_2=>1})),
+ check_rs($employees->search_rs({group_id_2=>4, group_id_3=>1}))
+ && check_rs($employees->search_rs({group_id_2=>1, group_id_3=>1})),
"overloaded multicol update 1"
);
-$employee = $employees->search({group_id=>4, group_id_2=>1})->first;
-$employee->update({group_id=>2});
-ok( check_rs($employees->search_rs({group_id=>4, group_id_2=>1}))
- && check_rs($employees->search_rs({group_id=>2, group_id_2=>1})),
- "overloaded multicol update 2"
+$employee = $employees->search({group_id_2=>4, group_id_3=>1})->first;
+$employee->update({group_id_2=>2});
+ok( check_rs($employees->search_rs({group_id_2=>4, group_id_3=>1}))
+ && check_rs($employees->search_rs({group_id_2=>2, group_id_3=>1})),
+ "overloaded multicol update 2"
);
-$employee = $employees->search({group_id=>3, group_id_2=>1})->first;
-$employee->group_id(1);
-$employee->group_id_2(3);
+$employee = $employees->search({group_id_2=>3, group_id_3=>1})->first;
+$employee->group_id_2(1);
+$employee->group_id_3(3);
$employee->update();
-ok( check_rs($employees->search_rs({group_id=>3, group_id_2=>1}))
- && check_rs($employees->search_rs({group_id=>1, group_id_2=>3})),
+ok( check_rs($employees->search_rs({group_id_2=>3, group_id_3=>1}))
+ && check_rs($employees->search_rs({group_id_2=>1, group_id_3=>3})),
"overloaded multicol update 3"
);
-$employee = $employees->search({group_id=>3, group_id_2=>1})->first;
-$employee->update({group_id=>2, group_id_2=>3});
-ok( check_rs($employees->search_rs({group_id=>3, group_id_2=>1}))
- && check_rs($employees->search_rs({group_id=>2, group_id_2=>3})),
+$employee = $employees->search({group_id_2=>3, group_id_3=>1})->first;
+$employee->update({group_id_2=>2, group_id_3=>3});
+ok( check_rs($employees->search_rs({group_id_2=>3, group_id_3=>1}))
+ && check_rs($employees->search_rs({group_id_2=>2, group_id_3=>3})),
"overloaded multicol update 4"
);
-$employee = $employees->search({group_id=>3, group_id_2=>2})->first;
-$employee->update({group_id=>2, group_id_2=>4, position=>2});
-ok( check_rs($employees->search_rs({group_id=>3, group_id_2=>2}))
- && check_rs($employees->search_rs({group_id=>2, group_id_2=>4})),
+$employee = $employees->search({group_id_2=>3, group_id_3=>2})->first;
+$employee->update({group_id_2=>2, group_id_3=>4, position=>2});
+ok( check_rs($employees->search_rs({group_id_2=>3, group_id_3=>2}))
+ && check_rs($employees->search_rs({group_id_2=>2, group_id_3=>4})),
"overloaded multicol update 5"
);
ok( check_rs($rs), "move_to( $position => $to_position )" );
}
- ($row) = $rs->search({ position=>$position })->all();
+ $row = $rs->find({ position => $position });
if ($position==1) {
ok( !$row->previous_sibling(), 'no previous sibling' );
ok( !$row->first_sibling(), 'no first sibling' );
+ ok( $row->next_sibling->position > $position, 'next sibling position > than us');
+ is( $row->next_sibling->previous_sibling->position, $position, 'next-prev sibling is us');
+ ok( $row->last_sibling->position > $position, 'last sibling position > than us');
}
else {
ok( $row->previous_sibling(), 'previous sibling' );
ok( $row->first_sibling(), 'first sibling' );
+ ok( $row->previous_sibling->position < $position, 'prev sibling position < than us');
+ is( $row->previous_sibling->next_sibling->position, $position, 'prev-next sibling is us');
+ ok( $row->first_sibling->position < $position, 'first sibling position < than us');
}
if ($position==$count) {
ok( !$row->next_sibling(), 'no next sibling' );
ok( !$row->last_sibling(), 'no last sibling' );
+ ok( $row->previous_sibling->position < $position, 'prev sibling position < than us');
+ is( $row->previous_sibling->next_sibling->position, $position, 'prev-next sibling is us');
+ ok( $row->first_sibling->position < $position, 'first sibling position < than us');
}
else {
ok( $row->next_sibling(), 'next sibling' );
ok( $row->last_sibling(), 'last sibling' );
+ ok( $row->next_sibling->position > $row->position, 'next sibling position > than us');
+ is( $row->next_sibling->previous_sibling->position, $position, 'next-prev sibling is us');
+ ok( $row->last_sibling->position > $row->position, 'last sibling position > than us');
}
}
use lib qw(t/lib);
use DBICTest;
-plan tests => 77;
+plan tests => 93;
my $schema = DBICTest->init_schema();
-diag '* simple create + parent (the stuff $rs belongs_to)';
-eval {
+lives_ok ( sub {
my $cd = $schema->resultset('CD')->create({
artist => {
name => 'Fred Bloggs'
isa_ok($cd, 'DBICTest::CD', 'Created CD object');
isa_ok($cd->artist, 'DBICTest::Artist', 'Created related Artist');
is($cd->artist->name, 'Fred Bloggs', 'Artist created correctly');
-};
-diag $@ if $@;
+}, 'simple create + parent (the stuff $rs belongs_to) ok');
-diag '* same as above but the child and parent have no values, except for an explicit parent pk';
-eval {
+lives_ok ( sub {
my $bm_rs = $schema->resultset('Bookmark');
my $bookmark = $bm_rs->create({
link => {
1,
'Bookmark and link made it to the DB',
);
-};
-diag $@ if $@;
+}, 'simple create where the child and parent have no values, except for an explicit parent pk ok');
-diag '* create over > 1 levels of has_many create (A => { has_many => { B => has_many => C } } )';
-eval {
+lives_ok ( sub {
my $artist = $schema->resultset('Artist')->first;
my $cd = $artist->create_related (cds => {
title => 'Music to code by',
is($cd->tags->count, 1, 'One tag created for CD');
is($cd->tags->first->tag, 'rock', 'Tag created correctly');
-};
-diag $@ if $@;
+}, 'create over > 1 levels of has_many create (A => { has_many => { B => has_many => C } } )');
throws_ok (
sub {
'create via update of multi relationships throws an exception'
);
-diag '* Create m2m while originating in the linker table';
-eval {
+lives_ok ( sub {
my $artist = $schema->resultset('Artist')->first;
my $c2p = $schema->resultset('CD_to_Producer')->create ({
cd => {
title => 'Bad investment',
year => 2008,
tracks => [
- { position => 1, title => 'Just buy' },
- { position => 2, title => 'Why did we do it' },
- { position => 3, title => 'Burn baby burn' },
+ { title => 'Just buy' },
+ { title => 'Why did we do it' },
+ { title => 'Burn baby burn' },
],
},
producer => {
my $cd = $prod->cds->first;
is ($cd->title, 'Bad investment', 'CD created correctly');
is ($cd->tracks->count, 3, 'CD has 3 tracks');
+}, 'Create m2m while originating in the linker table');
-};
-diag $@ if $@;
-diag (<<'DG');
-* Create over > 1 levels of might_have with multiple has_many and multiple m2m
-but starting at a has_many level
-
-CD -> has_many -> Tracks -> might have -> Single -> has_many -> Tracks
- \
- \-> has_many \
- --> CD2Producer
- /-> has_many /
- /
- Producer
-DG
-
-eval {
+#CD -> has_many -> Tracks -> might have -> Single -> has_many -> Tracks
+# \
+# \-> has_many \
+# --> CD2Producer
+# /-> has_many /
+# /
+# Producer
+lives_ok ( sub {
my $artist = $schema->resultset('Artist')->first;
my $cd = $schema->resultset('CD')->create ({
artist => $artist,
year => 2008,
tracks => [
{
- position => 1, # some day me might test this with Ordered
title => 'Off by one again',
},
{
- position => 2,
title => 'The dereferencer',
cd_single => {
artist => $artist,
year => 2008,
title => 'Was that a null (Single)',
tracks => [
- { title => 'The dereferencer', position => 1 },
- { title => 'The dereferencer II', position => 2 },
+ { title => 'The dereferencer' },
+ { title => 'The dereferencer II' },
],
cd_to_producer => [
{
['Don Knuth', 'K&R'],
'Producers named correctly',
);
-};
-diag $@ if $@;
-
-diag (<<'DG');
-* Same as above but starting at the might_have directly
-
-Track -> might have -> Single -> has_many -> Tracks
- \
- \-> has_many \
- --> CD2Producer
- /-> has_many /
- /
- Producer
-DG
-
-eval {
+}, 'Create over > 1 levels of might_have with multiple has_many and multiple m2m but starting at a has_many level');
+
+#Track -> might have -> Single -> has_many -> Tracks
+# \
+# \-> has_many \
+# --> CD2Producer
+# /-> has_many /
+# /
+# Producer
+lives_ok ( sub {
my $cd = $schema->resultset('CD')->first;
my $track = $schema->resultset('Track')->create ({
cd => $cd,
- position => 77, # some day me might test this with Ordered
title => 'Multicreate rocks',
cd_single => {
artist => $cd->artist,
year => 2008,
title => 'Disemboweling MultiCreate',
tracks => [
- { title => 'Why does mst write this way', position => 1 },
- { title => 'Chainsaw celebration', position => 2 },
- { title => 'Purl cleans up', position => 3 },
+ { title => 'Why does mst write this way' },
+ { title => 'Chainsaw celebration' },
+ { title => 'Purl cleans up' },
],
cd_to_producer => [
{
['castaway', 'mst', 'theorbtwo'],
'Producers named correctly',
);
-};
-diag $@ if $@;
+}, 'Create over > 1 levels of might_have with multiple has_many and multiple m2m but starting at the might_have directly');
-diag '* Test might_have again but with a PK == FK in the middle (obviously not specified)';
-eval {
+lives_ok ( sub {
my $artist = $schema->resultset('Artist')->first;
my $cd = $schema->resultset('CD')->create ({
artist => $artist,
[ 'recursive descent', 'tail packing' ],
'Images named correctly after search',
);
-};
-diag $@ if $@;
+}, 'Test might_have again but with a PK == FK in the middle (obviously not specified)');
-diag '* Test might_have again but with just a PK and FK (neither specified) in the mid-table';
-eval {
+lives_ok ( sub {
my $cd = $schema->resultset('CD')->first;
my $track = $schema->resultset ('Track')->create ({
cd => $cd,
- position => 66,
title => 'Black',
lyrics => {
lyric_versions => [
[ 'The color black', 'The colour black' ],
'Lyrics text via search matches',
);
-};
-diag $@ if $@;
-
-diag (<<'DG');
-* Test a multilevel might-have with a PK == FK in the might_have/has_many table
-
-CD -> might have -> Artwork
- \
- \-> has_many \
- --> Artwork_to_Artist
- /-> has_many /
- /
- Artist
-DG
-
-eval {
- my $someartist = $schema->resultset('Artist')->first;
- my $cd = $schema->resultset('CD')->create ({
- artist => $someartist,
- title => 'Music to code by until the cows come home',
- year => 2008,
- artwork => {
- artwork_to_artist => [
- { artist => { name => 'cowboy joe' } },
- { artist => { name => 'billy the kid' } },
- ],
- },
- });
-
- isa_ok ($cd, 'DBICTest::CD', 'Main CD object created');
- is ($cd->title, 'Music to code by until the cows come home', 'Correct CD title');
+}, 'Test might_have again but with just a PK and FK (neither specified) in the mid-table');
- my $art_obj = $cd->artwork;
- ok ($art_obj->has_column_loaded ('cd_id'), 'PK/FK present on artwork object');
- is ($art_obj->artists->count, 2, 'Correct artwork creator count via the new object');
- is_deeply (
- [ sort $art_obj->artists->get_column ('name')->all ],
- [ 'billy the kid', 'cowboy joe' ],
- 'Artists named correctly when queried via object',
- );
-
- my $artwork = $schema->resultset('Artwork')->search (
- { 'cd.title' => 'Music to code by until the cows come home' },
- { join => 'cd' },
- )->single;
- is ($artwork->artists->count, 2, 'Correct artwork creator count via a new search');
- is_deeply (
- [ sort $artwork->artists->get_column ('name')->all ],
- [ 'billy the kid', 'cowboy joe' ],
- 'Artists named correctly queried via a new search',
- );
-};
-diag $@ if $@;
-
-diag '* Nested find_or_create';
-eval {
+lives_ok ( sub {
my $newartist2 = $schema->resultset('Artist')->find_or_create({
name => 'Fred 3',
cds => [
],
});
is($newartist2->name, 'Fred 3', 'Created new artist with cds via find_or_create');
-};
-diag $@ if $@;
+}, 'Nested find_or_create');
-diag '* Multiple same level has_many create';
-eval {
+lives_ok ( sub {
my $artist2 = $schema->resultset('Artist')->create({
name => 'Fred 4',
cds => [
});
is($artist2->in_storage, 1, 'artist with duplicate rels inserted okay');
-};
-diag $@ if $@;
+}, 'Multiple same level has_many create');
-diag '* First create_related pass';
-eval {
+lives_ok ( sub {
my $artist = $schema->resultset('Artist')->first;
my $cd_result = $artist->create_related('cds', {
title => 'TestOneCD1',
year => 2007,
tracks => [
-
- { position=>111,
- title => 'TrackOne',
- },
- { position=>112,
- title => 'TrackTwo',
- }
+ { title => 'TrackOne' },
+ { title => 'TrackTwo' },
],
});
{
ok( $track && ref $track eq 'DBICTest::Track', 'Got Expected Track Class');
}
-};
-diag $@ if $@;
+}, 'First create_related pass');
-diag '* second create_related with same arguments';
-eval {
+lives_ok ( sub {
my $artist = $schema->resultset('Artist')->first;
my $cd_result = $artist->create_related('cds', {
title => 'TestOneCD2',
year => 2007,
tracks => [
-
- { position=>111,
- title => 'TrackOne',
- },
- { position=>112,
- title => 'TrackTwo',
- }
+ { title => 'TrackOne' },
+ { title => 'TrackTwo' },
],
liner_notes => { notes => 'I can haz liner notes?' },
{
ok( $track && ref $track eq 'DBICTest::Track', 'Got Expected Track Class');
}
-};
-diag $@ if $@;
+}, 'second create_related with same arguments');
-diag '* create of parents of a record linker table';
-eval {
+lives_ok ( sub {
my $cdp = $schema->resultset('CD_to_Producer')->create({
cd => { artist => 1, title => 'foo', year => 2000 },
producer => { name => 'jorge' }
});
ok($cdp, 'join table record created ok');
-};
-diag $@ if $@;
+}, 'create of parents of a record linker table');
-eval {
+lives_ok ( sub {
my $kurt_cobain = { name => 'Kurt Cobain' };
my $in_utero = $schema->resultset('CD')->new({
is($a->name, 'Kurt Cobain', 'Artist insertion ok');
is($a->cds && $a->cds->first && $a->cds->first->title,
'In Utero', 'CD insertion ok');
-};
-diag $@ if $@;
-
-=pod
-# This test case has been moved to t/96multi_create/cd_single.t
-eval {
- my $pink_floyd = { name => 'Pink Floyd' };
-
- my $the_wall = { title => 'The Wall', year => 1979 };
-
- $pink_floyd->{cds} = [ $the_wall ];
-
-
- $schema->resultset('Artist')->populate([ $pink_floyd ]); # %)
- $a = $schema->resultset('Artist')->find({name => 'Pink Floyd'});
-
- is($a->name, 'Pink Floyd', 'Artist insertion ok');
- is($a->cds && $a->cds->first->title, 'The Wall', 'CD insertion ok');
-};
-diag $@ if $@;
-=cut
+}, 'populate');
-diag '* Create foreign key col obj including PK (See test 20 in 66relationships.t)';
## Create foreign key col obj including PK
## See test 20 in 66relationships.t
-eval {
+lives_ok ( sub {
my $new_cd_hashref = {
cdid => 27,
title => 'Boogie Woogie',
my $new_cd = $schema->resultset("CD")->create($new_cd_hashref);
is($new_cd->artist->id, 17, 'new id retained okay');
-};
-diag $@ if $@;
+}, 'Create foreign key col obj including PK');
-eval {
+lives_ok ( sub {
$schema->resultset("CD")->create({
cdid => 28,
title => 'Boogie Wiggle',
year => '2007',
artist => { artistid => 18, name => 'larry' }
});
-};
-is($@, '', 'new cd created without clash on related artist');
+}, 'new cd created without clash on related artist');
-diag '* Make sure exceptions from errors in created rels propogate';
-eval {
+throws_ok ( sub {
my $t = $schema->resultset("Track")->new({ cd => { artist => undef } });
#$t->cd($t->new_related('cd', { artist => undef } ) );
#$t->{_rel_in_storage} = 0;
$t->insert;
-};
-like($@, qr/cd.artist may not be NULL/, "Exception propogated properly");
+}, qr/cd.artist may not be NULL/, "Exception propogated properly");
-diag '* Test multi create over many_to_many';
-eval {
+lives_ok ( sub {
$schema->resultset('CD')->create ({
artist => {
name => 'larry', # should already exist
is ($m2m_cd->count, 1, 'One CD row created via M2M create');
is ($m2m_cd->first->producers->count, 1, 'CD row created with one producer');
is ($m2m_cd->first->producers->first->name, 'Cowboy Neal', 'Correct producer row created');
-};
+}, 'Test multi create over many_to_many');
1;
my $cd = $schema->resultset('CD')->first;
my $track = $schema->resultset('Track')->new_result({
cd => $cd,
- position => 77, # some day me might test this with Ordered
title => 'Multicreate rocks',
cd_single => {
artist => $cd->artist,
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+sub mc_diag { diag (@_) if $ENV{DBIC_MULTICREATE_DEBUG} };
+
+plan tests => 8;
+
+my $schema = DBICTest->init_schema();
+
+mc_diag (<<'DG');
+* Test a multilevel might-have with a PK == FK in the might_have/has_many table
+
+CD -> might have -> Artwork
+ \
+ \-> has_many \
+ --> Artwork_to_Artist
+ /-> has_many /
+ /
+ Artist
+DG
+
+lives_ok (sub {
+ my $someartist = $schema->resultset('Artist')->first;
+ my $cd = $schema->resultset('CD')->create ({
+ artist => $someartist,
+ title => 'Music to code by until the cows come home',
+ year => 2008,
+ artwork => {
+ artwork_to_artist => [
+ { artist => { name => 'cowboy joe' } },
+ { artist => { name => 'billy the kid' } },
+ ],
+ },
+ });
+
+ isa_ok ($cd, 'DBICTest::CD', 'Main CD object created');
+ is ($cd->title, 'Music to code by until the cows come home', 'Correct CD title');
+
+ my $art_obj = $cd->artwork;
+ ok ($art_obj->has_column_loaded ('cd_id'), 'PK/FK present on artwork object');
+ is ($art_obj->artists->count, 2, 'Correct artwork creator count via the new object');
+ is_deeply (
+ [ sort $art_obj->artists->get_column ('name')->all ],
+ [ 'billy the kid', 'cowboy joe' ],
+ 'Artists named correctly when queried via object',
+ );
+
+ my $artwork = $schema->resultset('Artwork')->search (
+ { 'cd.title' => 'Music to code by until the cows come home' },
+ { join => 'cd' },
+ )->single;
+ is ($artwork->artists->count, 2, 'Correct artwork creator count via a new search');
+ is_deeply (
+ [ sort $artwork->artists->get_column ('name')->all ],
+ [ 'billy the kid', 'cowboy joe' ],
+ 'Artists named correctly queried via a new search',
+ );
+}, 'multilevel might-have with a PK == FK in the might_have/has_many table ok');
+
+1;
use lib qw(t/lib);
use DBICTest;
-plan tests => 9;
+plan tests => 12;
my $schema = DBICTest->init_schema();
{
my $new_artist = $schema->resultset("Artist")->new_result({ 'name' => 'Depeche Mode' });
- my $new_related_cd = $new_artist->new_related('cds', { 'title' => 'Leave in Silence', 'year' => 1982});
+ my $new_related_cd = $new_artist->new_related('cds', { 'title' => 'Leave Slightly Noisily', 'year' => 1982});
+ eval {
+ $new_related_cd->insert;
+ };
+ is ($@, '', 'CD insertion survives by finding artist');
+ ok($new_artist->in_storage, 'artist inserted');
+ ok($new_related_cd->in_storage, 'new_related_cd inserted');
+}
+
+{
+ my $new_artist = $schema->resultset("Artist")->new_result({ 'name' => 'Depeche Mode 2: Insertion Boogaloo' });
+ my $new_related_cd = $new_artist->new_related('cds', { 'title' => 'Leave Loudly While Singing Off Key', 'year' => 1982});
eval {
$new_related_cd->insert;
};
use lib qw(t/lib);
use DBICTest;
-plan tests => 19;
+plan tests => 23;
# an insane multicreate
# (should work, despite the fact that no one will probably use it this way)
],
# This cd is created via artist so it doesn't know about producers
cd_to_producer => [
- # if we specify 'bob' here things bomb
- # as the producer attached to Greatest Hits 1 is
- # already created, but not yet inserted.
- # Maybe this can be fixed, but things are hairy
- # enough already.
- #
- #{ producer => { name => 'bob' } },
+ { producer => { name => 'bob' } },
{ producer => { name => 'paul' } },
{ producer => {
name => 'flemming',
);
is ($paul_prod->count, 1, 'Paul had 1 production');
my $pauls_cd = $paul_prod->single;
- is ($pauls_cd->cd_to_producer->count, 2, 'Paul had one co-producer');
+ is ($pauls_cd->cd_to_producer->count, 3, 'Paul had two co-producers');
is (
$pauls_cd->search_related ('cd_to_producer',
{ 'producer.name' => 'flemming'},
{ 'producer.name' => 'bob'},
{ join => 'producer' }
)->count,
- 2,
- 'Lars produced 2 CDs with bob',
+ 3,
+ 'Lars produced 3 CDs with bob',
);
my $bob_prod = $cd_rs->search (
{ 'producer.name' => 'bob'},
{ join => { cd_to_producer => 'producer' } }
);
- is ($bob_prod->count, 3, 'Bob produced a total of 3 CDs');
+ is ($bob_prod->count, 4, 'Bob produced a total of 4 CDs');
+ ok ($bob_prod->find ({ title => 'Greatest hits 1'}), '1st Bob production name correct');
+ ok ($bob_prod->find ({ title => 'Greatest hits 6'}), '2nd Bob production name correct');
+ ok ($bob_prod->find ({ title => 'Greatest hits 2'}), '3rd Bob production name correct');
+ ok ($bob_prod->find ({ title => 'Greatest hits 7'}), '4th Bob production name correct');
is (
$bob_prod->search ({ 'artist.name' => 'james' }, { join => 'artist' })->count,
}
my $schema = DBICTest->init_schema();
-my @sources = grep { $_ ne 'Dummy' } ($schema->sources); # Dummy was yanked out by the sqlt hook test
+# Dummy was yanked out by the sqlt hook test
+# YearXXXXCDs are views
+my @sources = grep { $_ ne 'Dummy' && $_ !~ /^Year\d{4}CDs$/ }
+ $schema->sources;
+
plan tests => ( @sources * 3);
{
--- /dev/null
+package DBICNSTest::RtBug41083::ResultSet;
+use strict;
+use warnings;
+use base 'DBIx::Class::ResultSet';
+1;
--- /dev/null
+package DBICNSTest::RtBug41083::ResultSet::Foo;
+use strict;
+use warnings;
+use base 'DBICNSTest::RtBug41083::ResultSet';
+
+sub fooBar { 1; }
+
+1;
--- /dev/null
+package DBICNSTest::RtBug41083::ResultSet_A::A;
+use strict;
+use warnings;
+use base 'DBICNSTest::RtBug41083::ResultSet';
+
+sub fooBar { 1; }
+1;
--- /dev/null
+package DBICNSTest::RtBug41083::Schema::Foo;
+use strict;
+use warnings;
+use base 'DBIx::Class';
+__PACKAGE__->load_components('Core');
+__PACKAGE__->table('foo');
+__PACKAGE__->add_columns('foo');
+1;
--- /dev/null
+package DBICNSTest::RtBug41083::Schema::Foo::Sub;
+use strict;
+use warnings;
+use base 'DBICNSTest::RtBug41083::Schema::Foo';
+1;
--- /dev/null
+package DBICNSTest::RtBug41083::Schema_A::A;
+use strict;
+use warnings;
+use base 'DBIx::Class';
+__PACKAGE__->load_components('Core');
+__PACKAGE__->table('a');
+__PACKAGE__->add_columns('a');
+1;
--- /dev/null
+package DBICNSTest::RtBug41083::Schema_A::A::Sub;
+use strict;
+use warnings;
+use base 'DBICNSTest::RtBug41083::Schema_A::A';
+1;
#dummy
Track
Tag
+ Year2000CDs
+ Year1999CDs
/,
{ 'DBICTest::Schema' => [qw/
LinerNotes
data_type => 'integer',
is_nullable => 1,
},
+ group_id_3 => {
+ data_type => 'integer',
+ is_nullable => 1,
+ },
name => {
data_type => 'varchar',
size => 100,
DBICTest::Schema::Track;
use base 'DBIx::Class::Core';
-__PACKAGE__->load_components(qw/InflateColumn::DateTime/);
+__PACKAGE__->load_components(qw/InflateColumn::DateTime Ordered/);
__PACKAGE__->table('track');
__PACKAGE__->add_columns(
__PACKAGE__->add_unique_constraint([ qw/cd position/ ]);
__PACKAGE__->add_unique_constraint([ qw/cd title/ ]);
+__PACKAGE__->position_column ('position');
+__PACKAGE__->grouping_column ('cd');
+
+
__PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD' );
__PACKAGE__->belongs_to( disc => 'DBICTest::Schema::CD' => 'cd');
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::Year1999CDs;
+## Used in 104view.t
+
+use base 'DBIx::Class::Core';
+use DBIx::Class::ResultSource::View;
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+
+__PACKAGE__->table('year1999cds');
+__PACKAGE__->result_source_instance->is_virtual(1);
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT cdid, artist, title FROM cd WHERE year ='1999'"
+);
+__PACKAGE__->add_columns(
+ 'cdid' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'artist' => {
+ data_type => 'integer',
+ },
+ 'title' => {
+ data_type => 'varchar',
+ size => 100,
+ },
+
+);
+__PACKAGE__->set_primary_key('cdid');
+__PACKAGE__->add_unique_constraint([ qw/artist title/ ]);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::Year2000CDs;
+## Used in 104view.t
+
+use base 'DBIx::Class::Core';
+use DBIx::Class::ResultSource::View;
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+
+__PACKAGE__->table('year2000cds');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT cdid, artist, title FROM cd WHERE year ='2000'"
+);
+__PACKAGE__->add_columns(
+ 'cdid' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'artist' => {
+ data_type => 'integer',
+ },
+ 'title' => {
+ data_type => 'varchar',
+ size => 100,
+ },
+
+);
+__PACKAGE__->set_primary_key('cdid');
+__PACKAGE__->add_unique_constraint([ qw/artist title/ ]);
+
+1;
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Sat Jan 24 19:42:15 2009
+-- Created on Sun Feb 22 00:15:06 2009
--
-BEGIN TRANSACTION;
+BEGIN TRANSACTION;
+
--
-- Table: artist
--
charfield char(10)
);
-
--
-- Table: artist_undirected_map
--
);
CREATE INDEX artist_undirected_map_idx_id1_ ON artist_undirected_map (id1);
+
CREATE INDEX artist_undirected_map_idx_id2_ ON artist_undirected_map (id2);
--
);
CREATE INDEX artwork_to_artist_idx_artist_id_artwork_to_arti ON artwork_to_artist (artist_id);
+
CREATE INDEX artwork_to_artist_idx_artwork_cd_id_artwork_to_ ON artwork_to_artist (artwork_cd_id);
--
clob clob
);
-
--
-- Table: bookmark
--
price integer
);
-
--
-- Table: cd
--
);
CREATE INDEX cd_idx_artist_cd ON cd (artist);
+
CREATE INDEX cd_idx_genreid_cd ON cd (genreid);
+
CREATE INDEX cd_idx_single_track_cd ON cd (single_track);
+
CREATE UNIQUE INDEX cd_artist_title_cd ON cd (artist, title);
--
);
CREATE INDEX cd_to_producer_idx_cd_cd_to_pr ON cd_to_producer (cd);
+
CREATE INDEX cd_to_producer_idx_producer_cd ON cd_to_producer (producer);
--
name varchar(100) NOT NULL
);
-
--
-- Table: collection_object
--
);
CREATE INDEX collection_object_idx_collection_collection_obj ON collection_object (collection);
+
CREATE INDEX collection_object_idx_object_c ON collection_object (object);
--
position integer NOT NULL,
group_id integer,
group_id_2 integer,
+ group_id_3 integer,
name varchar(100)
);
+--
+-- Table: encoded
+--
+CREATE TABLE encoded (
+ id INTEGER PRIMARY KEY NOT NULL,
+ encoded varchar(100)
+);
--
-- Table: event
skip_inflation datetime
);
-
--
-- Table: file_columns
--
file varchar(255) NOT NULL
);
-
--
-- Table: forceforeign
--
PRIMARY KEY (foo, bar, hello, goodbye)
);
-
--
-- Table: fourkeys_to_twokeys
--
);
CREATE INDEX fourkeys_to_twokeys_idx_f_foo_f_bar_f_hello_f_goodbye_ ON fourkeys_to_twokeys (f_foo, f_bar, f_hello, f_goodbye);
+
CREATE INDEX fourkeys_to_twokeys_idx_t_artist_t_cd_fourkeys_to ON fourkeys_to_twokeys (t_artist, t_cd);
--
title varchar(100)
);
-
--
-- Table: lyric_versions
--
cd integer NOT NULL
);
-
--
-- Table: owners
--
name varchar(100) NOT NULL
);
-
--
-- Table: producer
--
name varchar(100) NOT NULL
);
-
--
-- Table: self_ref_alias
--
);
CREATE INDEX self_ref_alias_idx_alias_self_ ON self_ref_alias (alias);
+
CREATE INDEX self_ref_alias_idx_self_ref_se ON self_ref_alias (self_ref);
--
PRIMARY KEY (pkid1, pkid2)
);
-
--
-- Table: serialized
--
serialized text NOT NULL
);
-
--
-- Table: tags
--
);
CREATE INDEX track_idx_cd_track ON track (cd);
+
CREATE UNIQUE INDEX track_cd_position_track ON track (cd, position);
+
CREATE UNIQUE INDEX track_cd_title_track ON track (cd, title);
--
);
CREATE INDEX twokeytreelike_idx_parent1_parent2_twokeytre ON twokeytreelike (parent1, parent2);
+
CREATE UNIQUE INDEX tktlnameunique_twokeytreelike ON twokeytreelike (name);
--
);
--
--- Table: encoded
+-- View: year2000cds
--
-CREATE TABLE encoded (
- id INTEGER PRIMARY KEY NOT NULL,
- encoded varchar(100) NOT NULL
-);
+CREATE VIEW year2000cds AS
+ SELECT cdid, artist, title FROM cd WHERE year ='2000';
COMMIT;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+use POSIX qw(ceil);
+
+my $schema = DBICTest->init_schema();
+
+plan tests => 1;
+
+{
+ my $artist = $schema->resultset ('Artist')->search ({}, { rows => 1})->single; # braindead sqlite
+ my $cd = $schema->resultset ('CD')->create ({
+ artist => $artist,
+ title => 'Get in order',
+ year => 2009,
+ tracks => [
+ { title => 'T1' },
+ { title => 'T2' },
+ { title => 'T3' },
+ ],
+ });
+
+ lives_ok (sub { $cd->delete}, "Cascade delete on ordered has_many doesn't bomb");
+}
+
+1;