Revision history for DBIx::Class
+ - modified SQLT parser to skip dupe table names
+ - added remove_column(s) to ResultSource/ResultSourceProxy
+ - added add_column alias to ResultSourceProxy
+ - added source_name to ResultSource
+ - load_classes now uses source_name and sets it if necessary
+ - add update_or_create_related to Relationship::Base
+ - add find_or_new to ResultSet/ResultSetProxy and find_or_new_related
+ to Relationship::Base
+ - add accessors for unique constraint names and coulums to
+ ResultSource/ResultSourceProxy
+ - rework ResultSet::find() to search unique constraints
+ - CDBICompat: modify retrieve to fix column casing when ColumnCase is
+ loaded
+ - CDBICompat: override find_or_create to fix column casing when
+ ColumnCase is loaded
+
0.06002 2006-04-20 00:42:41
- fix set_from_related to accept undef
- fix to Dumper-induced hash iteration bug
- remove build dependency on version.pm
0.05004 2006-02-13 20:59:00
- - allow specification of related columns via cols attr when primary
+ - allow specification of related columns via cols attr when primary
keys of the related table are not fetched
- fix count for group_by as scalar
- add horrific fix to make Oracle's retarded limit syntax work
+2005-04-16 by mst
+ - set_from_related should take undef
+ - ResultSource objects caching ->resultset causes interesting problems
+ - find why XSUB dumper kills schema in Catalyst (may be Pg only?)
+
+2006-04-11 by castaway
+ - using PK::Auto should set is_auto_increment for the PK columns, so that copy() "just works"
+ - docs of copy() should say that is_auto_increment is essential for auto_incrementing keys
+
+2006-03-25 by mst
+ - Refactor ResultSet::new to be less hairy
+ - we should move the setup of select, as, and from out of here
+ - these should be local rs attrs, not main attrs, and extra joins
+ provided on search should be merged
+ - find a way to un-wantarray search without breaking compat
+ - audit logging component
+ - delay relationship setup if done via ->load_classes
+ - double-sided relationships
+ - incremental deploy
+ - make short form of class specifier in relationships work
2006-01-31 by bluefeet
- Create a DBIx::Class::FilterColumn to replace inflate/deflate. This
We should still support the old inflate/deflate syntax, but this new
way should be recommended.
-2006-02-07 by JR
+2006-02-07 by castaway
- Extract DBIC::SQL::Abstract into a separate module for CPAN
- Chop PK::Auto::Foo up to have PK::Auto refer to an appropriate
DBIx::Storage::DBI::Foo, which will be loaded on connect from Driver info?
+(done -> 0.06001!)
- Add deploy method to Schema, which will create DB tables from Schema, via
SQLT
+(sorta done)
2006-03-18 by bluefeet
- Support table locking.
+2006-03-21 by bluefeet
+ - When subclassing a dbic class make it so you don't have to do
+ __PACKAGE__->table(__PACKAGE__->table()); for the result set to
+ return the correct object type.
+
+2006-03-27 by mst
+ Add the ability for deploy to be given a directory and grab <dbname>.sql
+ out of there if available. Try SQL::Translator if not. If none of the above,
+ cry (and die()). Then you can have a script that pre-gens for all available
+ SQLT modules so an app can do its own deploy without SQLT on the target
+ system
+
return $class->next::method(lc($col));
}
+# _build_query
+#
+# Build a query hash for find, et al. Overrides Retrieve::_build_query.
+
+sub _build_query {
+ my ($self, $query) = @_;
+
+ my %new_query;
+ $new_query{lc $_} = $query->{$_} for keys %$query;
+
+ return \%new_query;
+}
+
sub _mk_group_accessors {
my ($class, $type, $group, @fields) = @_;
#warn join(', ', map { ref $_ ? (@$_) : ($_) } @fields);
use warnings FATAL => 'all';
-sub retrieve {
- die "No args to retrieve" unless @_ > 1;
- shift->find(@_);
+sub retrieve {
+ my $self = shift;
+ die "No args to retrieve" unless @_ > 0;
+
+ my @cols = $self->primary_columns;
+
+ my $query;
+ if (ref $_[0] eq 'HASH') {
+ $query = { %{$_[0]} };
+ }
+ elsif (@_ == @cols) {
+ $query = {};
+ @{$query}{@cols} = @_;
+ }
+ else {
+ $query = {@_};
+ }
+
+ $query = $self->_build_query($query);
+ $self->find($query);
+}
+
+sub find_or_create {
+ my $self = shift;
+ my $query = ref $_[0] eq 'HASH' ? shift : {@_};
+
+ $query = $self->_build_query($query);
+ $self->next::method($query);
+}
+
+# _build_query
+#
+# Build a query hash. Defaults to a no-op; ColumnCase overrides.
+
+sub _build_query {
+ my ($self, $query) = @_;
+
+ return $query;
}
sub retrieve_from_sql {
L<DBIx::Class::HTMLWidget> - Like FromForm but with DBIx::Class and HTML::Widget.
+L<DBIx::Class::Ordered> - Modify the position of objects in an ordered list.
+
L<DBIx::Class::PK::Auto> - Retrieve automatically created primary keys upon insert.
L<DBIx::Class::QueriesTime> - Display the amount of time it takes to run queries.
--- /dev/null
+# vim: ts=8:sw=4:sts=4:et
+package DBIx::Class::Ordered;
+use strict;
+use warnings;
+use base qw( DBIx::Class );
+
+=head1 NAME
+
+DBIx::Class::Ordered - Modify the position of objects in an ordered list.
+
+=head1 SYNOPSIS
+
+Create a table for your ordered data.
+
+ CREATE TABLE items (
+ item_id INTEGER PRIMARY KEY AUTOINCREMENT,
+ name TEXT NOT NULL,
+ position INTEGER NOT NULL
+ );
+ # Optional: group_id INTEGER NOT NULL
+
+In your Schema or DB class add Ordered to the top
+of the component list.
+
+ __PACKAGE__->load_components(qw( Ordered ... ));
+
+Specify the column that stores the position number for
+each row.
+
+ package My::Item;
+ __PACKAGE__->position_column('position');
+ __PACKAGE__->grouping_column('group_id'); # optional
+
+Thats it, now you can change the position of your objects.
+
+ #!/use/bin/perl
+ use My::Item;
+
+ my $item = My::Item->create({ name=>'Matt S. Trout' });
+ # If using grouping_column:
+ my $item = My::Item->create({ name=>'Matt S. Trout', group_id=>1 });
+
+ my $rs = $item->siblings();
+ my @siblings = $item->siblings();
+
+ my $sibling;
+ $sibling = $item->first_sibling();
+ $sibling = $item->last_sibling();
+ $sibling = $item->previous_sibling();
+ $sibling = $item->next_sibling();
+
+ $item->move_previous();
+ $item->move_next();
+ $item->move_first();
+ $item->move_last();
+ $item->move_to( $position );
+
+=head1 DESCRIPTION
+
+This module provides a simple interface for modifying the ordered
+position of DBIx::Class objects.
+
+=head1 AUTO UPDATE
+
+All of the move_* methods automatically update the rows involved in
+the query. This is not configurable and is due to the fact that if you
+move a record it always causes other records in the list to be updated.
+
+=head1 METHODS
+
+=head2 position_column
+
+ __PACKAGE__->position_column('position');
+
+Sets and retrieves the name of the column that stores the
+positional value of each record. Default to "position".
+
+=cut
+
+__PACKAGE__->mk_classdata( 'position_column' => 'position' );
+
+=head2 grouping_column
+
+ __PACKAGE__->grouping_column('group_id');
+
+This method specified a column to limit all queries in
+this module by. This effectively allows you to have multiple
+ordered lists within the same table.
+
+=cut
+
+__PACKAGE__->mk_classdata( 'grouping_column' );
+
+=head2 siblings
+
+ my $rs = $item->siblings();
+ my @siblings = $item->siblings();
+
+Returns either a result set or an array of all other objects
+excluding the one you called it on.
+
+=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;
+}
+
+=head2 first_sibling
+
+ my $sibling = $item->first_sibling();
+
+Returns the first sibling object, or 0 if the first sibling
+is this sibliing.
+
+=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];
+}
+
+=head2 last_sibling
+
+ my $sibling = $item->last_sibling();
+
+Return the last sibling, or 0 if the last sibling is this
+sibling.
+
+=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];
+}
+
+=head2 previous_sibling
+
+ my $sibling = $item->previous_sibling();
+
+Returns the sibling that resides one position back. Undef
+is returned if the current object is the first one.
+
+=cut
+
+sub previous_sibling {
+ my( $self ) = @_;
+ 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];
+}
+
+=head2 next_sibling
+
+ my $sibling = $item->next_sibling();
+
+Returns the sibling that resides one position foward. Undef
+is returned if the current object is the last one.
+
+=cut
+
+sub next_sibling {
+ my( $self ) = @_;
+ 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];
+}
+
+=head2 move_previous
+
+ $item->move_previous();
+
+Swaps position with the sibling on position previous in the list.
+1 is returned on success, and 0 is returned if the objects is already
+the first one.
+
+=cut
+
+sub move_previous {
+ my( $self ) = @_;
+ my $position = $self->get_column( $self->position_column() );
+ return $self->move_to( $position - 1 );
+}
+
+=head2 move_next
+
+ $item->move_next();
+
+Swaps position with the sibling in the next position. 1 is returned on
+success, and 0 is returned if the object is already the last in the list.
+
+=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 );
+}
+
+=head2 move_first
+
+ $item->move_first();
+
+Moves the object to the first position. 1 is returned on
+success, and 0 is returned if the object is already the first.
+
+=cut
+
+sub move_first {
+ my( $self ) = @_;
+ return $self->move_to( 1 );
+}
+
+=head2 move_last
+
+ $item->move_last();
+
+Moves the object to the very last position. 1 is returned on
+success, and 0 is returned if the object is already the last one.
+
+=cut
+
+sub move_last {
+ my( $self ) = @_;
+ my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
+ return $self->move_to( $count );
+}
+
+=head2 move_to
+
+ $item->move_to( $position );
+
+Moves the object to the specified position. 1 is returned on
+success, and 0 is returned if the object is already at the
+specified position.
+
+=cut
+
+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 $rs = $self->result_source->resultset->search({
+ -and => [
+ $position_column => { ($from_position>$to_position?'<':'>') => $from_position },
+ $position_column => { ($from_position>$to_position?'>=':'<=') => $to_position },
+ ],
+ $self->_grouping_clause(),
+ });
+ my $op = ($from_position>$to_position) ? '+' : '-';
+ $rs->update({
+ $position_column => \"$position_column $op 1",
+ });
+ $self->set_column( $position_column => $to_position );
+ $self->update();
+ return 1;
+}
+
+=head2 insert
+
+Overrides the DBIC insert() method by providing a default
+position number. The default will be the number of rows in
+the table +1, thus positioning the new record at the last position.
+
+=cut
+
+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));
+ return $self->next::method( @_ );
+}
+
+=head2 delete
+
+Overrides the DBIC delete() method by first moving the object
+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( @_ );
+}
+
+=head1 PRIVATE METHODS
+
+These methods are used internally. You should never have the
+need to use them.
+
+=head2 _grouping_clause
+
+This method returns a name=>value pare for limiting a search
+by the collection column. If the collection column is not
+defined then this will return an empty list.
+
+=cut
+
+sub _grouping_clause {
+ my( $self ) = @_;
+ my $col = $self->grouping_column();
+ if ($col) {
+ return ( $col => $self->get_column($col) );
+ }
+ return ();
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+=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 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.
+
+=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.
+
+The are times when you will want to move objects as groups, such
+as changeing the parent of several objects at once - this directly
+conflicts with this problem. One solution is for us to write a
+ResultSet class that supports a parent() method, for example. Another
+solution is to somehow automagically modify the objects that exist
+in the current object's result set to have the new position value.
+
+=head1 AUTHOR
+
+Aran Deltac <bluefeet@cpan.org>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
return $self->search_related($rel)->find(@_);
}
+=head2 find_or_new_related
+
+ my $new_obj = $obj->find_or_new_related('relname', \%col_data);
+
+Find an item of a related class. If none exists, instantiate a new item of the
+related class. The object will not be saved into your storage until you call
+L<DBIx::Class::Row/insert> on it.
+
+=cut
+
+sub find_or_new_related {
+ my $self = shift;
+ return $self->find_related(@_) || $self->new_related(@_);
+}
+
=head2 find_or_create_related
my $new_obj = $obj->find_or_create_related('relname', \%col_data);
Find or create an item of a related class. See
-L<DBIx::Class::ResultSet/"find_or_create"> for details.
+L<DBIx::Class::ResultSet/find_or_create> for details.
=cut
return $self->find_related(@_) || $self->create_related(@_);
}
+=head2 update_or_create_related
+
+ my $updated_item = $obj->update_or_create_related('relname', \%col_data, \%attrs?);
+
+Update or create an item of a related class. See
+L<DBIx::Class::ResultSet/update_or_create> for details.
+
+=cut
+
+sub update_or_create_related {
+ my $self = shift;
+ my $rel = shift;
+ return $self->related_resultset($rel)->update_or_create(@_);
+}
+
=head2 set_from_related
$book->set_from_related('author', $author_obj);
use Storable;
use Scalar::Util qw/weaken/;
+use DBIx::Class::ResultSetColumn;
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/AccessorGroup/);
__PACKAGE__->mk_group_accessors('simple' => qw/result_source result_class/);
=back
-Finds a row based on its primary key or unique constraint. For example:
+Finds a row based on its primary key or unique constraint. For example, to find
+a row by its primary key:
my $cd = $schema->resultset('CD')->find(5);
-Also takes an optional C<key> attribute, to search by a specific key or unique
-constraint. For example:
+You can also find a row by a specific unique constraint using the C<key>
+attribute. For example:
+
+ my $cd = $schema->resultset('CD')->find('Massive Attack', 'Mezzanine', { key => 'artist_title' });
+
+Additionally, you can specify the columns explicitly by name:
my $cd = $schema->resultset('CD')->find(
{
{ key => 'artist_title' }
);
-See also L</find_or_create> and L</update_or_create>.
+If no C<key> is specified and you explicitly name columns, it searches on all
+unique constraints defined on the source, including the primary key.
+
+If the C<key> is specified as C<primary>, it searches only on the primary key.
+
+See also L</find_or_create> and L</update_or_create>. For information on how to
+declare unique constraints, see
+L<DBIx::Class::ResultSource/add_unique_constraint>.
=cut
sub find {
- my ($self, @vals) = @_;
- my $attrs = (@vals > 1 && ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {});
+ my $self = shift;
+ my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
+
+ # Parse out a hash from input
+ my @cols = exists $attrs->{key}
+ ? $self->result_source->unique_constraint_columns($attrs->{key})
+ : $self->result_source->primary_columns;
- my @cols = $self->result_source->primary_columns;
- if (exists $attrs->{key}) {
- my %uniq = $self->result_source->unique_constraints;
+ my $hash;
+ if (ref $_[0] eq 'HASH') {
+ $hash = { %{$_[0]} };
+ }
+ elsif (@_ == @cols) {
+ $hash = {};
+ @{$hash}{@cols} = @_;
+ }
+ else {
$self->throw_exception(
- "Unknown key $attrs->{key} on '" . $self->result_source->name . "'"
- ) unless exists $uniq{$attrs->{key}};
- @cols = @{ $uniq{$attrs->{key}} };
+ "Arguments to find must be a hashref or match the number of columns in the "
+ . exists $attrs->{key} ? "$attrs->{key} unique constraint" : "primary key"
+ );
}
- #use Data::Dumper; warn Dumper($attrs, @vals, @cols);
+
+ # Check the hash we just parsed against our source's unique constraints
+ my @constraint_names = exists $attrs->{key}
+ ? ($attrs->{key})
+ : $self->result_source->unique_constraint_names;
$self->throw_exception(
"Can't find unless a primary key or unique constraint is defined"
- ) unless @cols;
-
- my $query;
- if (ref $vals[0] eq 'HASH') {
- $query = { %{$vals[0]} };
- } elsif (@cols == @vals) {
- $query = {};
- @{$query}{@cols} = @vals;
- } else {
- $query = {@vals};
- }
- foreach my $key (grep { ! m/\./ } keys %$query) {
- $query->{"$self->{attrs}{alias}.$key"} = delete $query->{$key};
+ ) unless @constraint_names;
+
+ my @unique_queries;
+ foreach my $name (@constraint_names) {
+ my @unique_cols = $self->result_source->unique_constraint_columns($name);
+ my $unique_query = $self->_build_unique_query($hash, \@unique_cols);
+
+ # Add the ResultSet's alias
+ foreach my $key (grep { ! m/\./ } keys %$unique_query) {
+ $unique_query->{"$self->{attrs}{alias}.$key"} = delete $unique_query->{$key};
+ }
+
+ push @unique_queries, $unique_query if %$unique_query;
}
- #warn Dumper($query);
-
+
+ # Handle cases where the ResultSet already defines the query
+ my $query = @unique_queries ? \@unique_queries : undef;
+
+ # Run the query
if (keys %$attrs) {
- my $rs = $self->search($query,$attrs);
- return keys %{$rs->{collapse}} ? $rs->next : $rs->single;
- } else {
- return keys %{$self->{collapse}} ?
- $self->search($query)->next :
- $self->single($query);
+ my $rs = $self->search($query, $attrs);
+ return keys %{$rs->{collapse}} ? $rs->next : $rs->single;
+ }
+ else {
+ return keys %{$self->{collapse}}
+ ? $self->search($query)->next
+ : $self->single($query);
}
}
+# _build_unique_query
+#
+# Constrain the specified query hash based on the specified column names.
+
+sub _build_unique_query {
+ my ($self, $query, $unique_cols) = @_;
+
+ my %unique_query =
+ map { $_ => $query->{$_} }
+ grep { exists $query->{$_} }
+ @$unique_cols;
+
+ return \%unique_query;
+}
+
=head2 search_related
=over 4
my $cd = $schema->resultset('CD')->single({ year => 2001 });
Inflates the first result without creating a cursor if the resultset has
-any records in it; if not returns nothing. Used by find() as an optimisation.
+any records in it; if not returns nothing. Used by L</find> as an optimisation.
=cut
return (@data ? $self->_construct_object(@data) : ());
}
+=head2 get_column
+
+=over 4
+
+=item Arguments: $cond?
+
+=item Return Value: $resultsetcolumn
+
+=back
+
+ my $max_length = $rs->get_column('length')->max;
+
+Returns a ResultSetColumn instance for $column based on $self
+
+=cut
+
+sub get_column {
+ my ($self, $column) = @_;
+
+ my $new = DBIx::Class::ResultSetColumn->new($self, $column);
+ return $new;
+}
=head2 search_like
return $obj;
}
+=head2 find_or_new
+
+=over 4
+
+=item Arguments: \%vals, \%attrs?
+
+=item Return Value: $object
+
+=back
+
+Find an existing record from this resultset. If none exists, instantiate a new
+result object and return it. The object will not be saved into your storage
+until you call L<DBIx::Class::Row/insert> on it.
+
+If you want objects to be saved immediately, use L</find_or_create> instead.
+
+=cut
+
+sub find_or_new {
+ my $self = shift;
+ my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
+ my $hash = ref $_[0] eq 'HASH' ? shift : {@_};
+ my $exists = $self->find($hash, $attrs);
+ return defined $exists ? $exists : $self->new_result($hash);
+}
+
=head2 create
=over 4
{ key => 'artist_title' }
);
-See also L</find> and L</update_or_create>.
+See also L</find> and L</update_or_create>. For information on how to declare
+unique constraints, see L<DBIx::Class::ResultSource/add_unique_constraint>.
=cut
If the C<key> is specified as C<primary>, it searches only on the primary key.
-See also L</find> and L</find_or_create>.
+See also L</find> and L</find_or_create>. For information on how to declare
+unique constraints, see L<DBIx::Class::ResultSource/add_unique_constraint>.
=cut
my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
my $hash = ref $_[0] eq 'HASH' ? shift : {@_};
- my %unique_constraints = $self->result_source->unique_constraints;
- my @constraint_names = (exists $attrs->{key}
- ? ($attrs->{key})
- : keys %unique_constraints);
-
- my @unique_hashes;
- foreach my $name (@constraint_names) {
- my @unique_cols = @{ $unique_constraints{$name} };
- my %unique_hash =
- map { $_ => $hash->{$_} }
- grep { exists $hash->{$_} }
- @unique_cols;
-
- push @unique_hashes, \%unique_hash
- if (scalar keys %unique_hash == scalar @unique_cols);
- }
-
- if (@unique_hashes) {
- my $row = $self->single(\@unique_hashes);
- if (defined $row) {
- $row->set_columns($hash);
- $row->update;
- return $row;
- }
+ my $row = $self->find($hash, $attrs);
+ if (defined $row) {
+ $row->set_columns($hash);
+ $row->update;
+ return $row;
}
return $self->create($hash);
--- /dev/null
+package DBIx::Class::ResultSetColumn;
+use strict;
+use warnings;
+use base 'DBIx::Class';
+
+=head1 NAME
+
+ DBIx::Class::ResultSetColumn - helpful methods for messing
+ with a single column of the resultset
+
+=head1 SYNOPSIS
+
+ $rs = $schema->resultset('CD')->search({ artist => 'Tool' });
+ $rs_column = $rs->get_column('year');
+ $max_year = $rs_column->max; #returns latest year
+
+=head1 DESCRIPTION
+
+A convenience class used to perform operations on a specific column of a resultset.
+
+=cut
+
+=head1 METHODS
+
+=head2 new
+
+ my $obj = DBIx::Class::ResultSetColumn->new($rs, $column);
+
+Creates a new resultset column object from the resultset and column passed as params
+
+=cut
+
+sub new {
+ my ($class, $rs, $column) = @_;
+ $class = ref $class if ref $class;
+
+ my $object_ref = { _column => $column,
+ _parent_resultset => $rs };
+
+ my $new = bless $object_ref, $class;
+ $new->throw_exception("column must be supplied") unless ($column);
+ return $new;
+}
+
+=head2 next
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: $value
+
+=back
+
+Returns the next value of the column in the resultset (C<undef> is there is none).
+
+Much like $rs->next but just returning the one value
+
+=cut
+
+sub next {
+ my $self = shift;
+
+ $self->{_resultset} = $self->{_parent_resultset}->search(undef, {select => [$self->{_column}], as => [$self->{_column}]}) unless ($self->{_resultset});
+ my ($row) = $self->{_resultset}->cursor->next;
+ return $row;
+}
+
+=head2 all
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: @values
+
+=back
+
+Returns all values of the column in the resultset (C<undef> is there are none).
+
+Much like $rs->all but returns values rather than row objects
+
+=cut
+
+sub all {
+ my $self = shift;
+ return map {$_->[0]} $self->{_parent_resultset}->search(undef, {select => [$self->{_column}], as => [$self->{_column}]})->cursor->all;
+}
+
+=head2 min
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: $lowest_value
+
+=back
+
+Wrapper for ->func. Returns the lowest value of the column in the resultset (C<undef> is there are none).
+
+=cut
+
+sub min {
+ my $self = shift;
+ return $self->func('MIN');
+}
+
+=head2 max
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: $highest_value
+
+=back
+
+Wrapper for ->func. Returns the highest value of the column in the resultset (C<undef> is there are none).
+
+=cut
+
+sub max {
+ my $self = shift;
+ return $self->func('MAX');
+}
+
+=head2 sum
+
+=over 4
+
+=item Arguments: none
+
+=item Return Value: $sum_of_values
+
+=back
+
+Wrapper for ->func. Returns the sum of all the values in the column of the resultset. Use on varchar-like columns at your own risk.
+
+=cut
+
+sub sum {
+ my $self = shift;
+ return $self->func('SUM');
+}
+
+=head2 func
+
+=over 4
+
+=item Arguments: $function
+
+=item Return Value: $function_return_value
+
+=back
+
+Runs a query using the function on the column and returns the value. For example
+ $rs = $schema->resultset("CD")->search({});
+ $length = $rs->get_column('title')->func('LENGTH');
+
+Produces the following SQL
+ SELECT LENGTH( title ) from cd me
+
+=cut
+
+sub func {
+ my $self = shift;
+ my $function = shift;
+
+ my ($row) = $self->{_parent_resultset}->search(undef, {select => {$function => $self->{_column}}, as => [$self->{_column}]})->cursor->next;
+ return $row;
+}
+
+1;
+
+=head1 AUTHORS
+
+Luke Saunders <luke.saunders@gmail.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
sub find { shift->resultset_instance->find(@_); }
sub create { shift->resultset_instance->create(@_); }
sub find_or_create { shift->resultset_instance->find_or_create(@_); }
+sub find_or_new { shift->resultset_instance->find_or_new(@_); }
sub update_or_create { shift->resultset_instance->update_or_create(@_); }
1;
schema from _relationships/);
__PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
- result_class/);
+ result_class source_name/);
=head1 NAME
sub add_columns {
my ($self, @cols) = @_;
$self->_ordered_columns(\@cols) unless $self->_ordered_columns;
-
+
my @added;
my $columns = $self->_columns;
while (my $col = shift @cols) {
return @{$self->{_ordered_columns}||[]};
}
+=head2 remove_columns
+
+ $table->remove_columns(qw/col1 col2 col3/);
+
+Removes columns from the result source.
+
+=head2 remove_column
+
+ $table->remove_column('col');
+
+Convenience alias to remove_columns.
+
+=cut
+
+sub remove_columns {
+ my ($self, @cols) = @_;
+
+ return unless $self->_ordered_columns;
+
+ my $columns = $self->_columns;
+ my @remaining;
+
+ foreach my $col (@{$self->_ordered_columns}) {
+ push @remaining, $col unless grep(/$col/, @cols);
+ }
+
+ foreach (@cols) {
+ undef $columns->{$_};
+ };
+
+ $self->_ordered_columns(\@remaining);
+}
+
+*remove_column = \&remove_columns;
+
=head2 set_primary_key
=over 4
=head2 add_unique_constraint
Declare a unique constraint on this source. Call once for each unique
-constraint. Unique constraints are used when you call C<find> on a
-L<DBIx::Class::ResultSet>. Only columns in the constraint are searched,
-for example:
+constraint.
# For UNIQUE (column1, column2)
__PACKAGE__->add_unique_constraint(
constraint_name => [ qw/column1 column2/ ],
);
+Unique constraints are used, for example, when you call
+L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
+
=cut
sub add_unique_constraint {
return %{shift->_unique_constraints||{}};
}
+=head2 unique_constraint_names
+
+Returns the list of unique constraint names defined on this source.
+
+=cut
+
+sub unique_constraint_names {
+ my ($self) = @_;
+
+ my %unique_constraints = $self->unique_constraints;
+
+ return keys %unique_constraints;
+}
+
+=head2 unique_constraint_columns
+
+Returns the list of columns that make up the specified unique constraint.
+
+=cut
+
+sub unique_constraint_columns {
+ my ($self, $constraint_name) = @_;
+
+ my %unique_constraints = $self->unique_constraints;
+
+ $self->throw_exception(
+ "Unknown unique constraint $constraint_name on '" . $self->name . "'"
+ ) unless exists $unique_constraints{$constraint_name};
+
+ return @{ $unique_constraints{$constraint_name} };
+}
+
=head2 from
Returns an expression of the source to be supplied to storage to specify
An arrayref containing a list of accessors in the foreign class to proxy in
the main class. If, for example, you do the following:
-
+
CD->might_have(liner_notes => 'LinerNotes', undef, {
proxy => [ qw/notes/ ],
});
-
+
Then, assuming LinerNotes has an accessor named notes, you can do:
my $cd = CD->find(1);
return exists $self->_relationships->{$rel};
}
+=head2 reverse_relationship_info
+
+=over 4
+
+=item Arguments: $relname
+
+=back
+
+Returns an array of hash references of relationship information for
+the other side of the specified relationship name.
+
+=cut
+
+sub reverse_relationship_info {
+ my ($self, $rel) = @_;
+ my $rel_info = $self->relationship_info($rel);
+ my $ret = {};
+
+ return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
+
+ my @cond = keys(%{$rel_info->{cond}});
+ my @refkeys = map {/^\w+\.(\w+)$/} @cond;
+ my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
+
+ # Get the related result source for this relationship
+ my $othertable = $self->related_source($rel);
+
+ # Get all the relationships for that source that related to this source
+ # whose foreign column set are our self columns on $rel and whose self
+ # columns are our foreign columns on $rel.
+ my @otherrels = $othertable->relationships();
+ my $otherrelationship;
+ foreach my $otherrel (@otherrels) {
+ my $otherrel_info = $othertable->relationship_info($otherrel);
+
+ my $back = $othertable->related_source($otherrel);
+ next unless $back->name eq $self->name;
+
+ my @othertestconds;
+
+ if (ref $otherrel_info->{cond} eq 'HASH') {
+ @othertestconds = ($otherrel_info->{cond});
+ }
+ elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
+ @othertestconds = @{$otherrel_info->{cond}};
+ }
+ else {
+ next;
+ }
+
+ foreach my $othercond (@othertestconds) {
+ my @other_cond = keys(%$othercond);
+ my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
+ my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
+ next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
+ !$self->compare_relationship_keys(\@other_refkeys, \@keys));
+ $ret->{$otherrel} = $otherrel_info;
+ }
+ }
+ return $ret;
+}
+
+=head2 compare_relationship_keys
+
+=over 4
+
+=item Arguments: $keys1, $keys2
+
+=back
+
+Returns true if both sets of keynames are the same, false otherwise.
+
+=cut
+
+sub compare_relationship_keys {
+ my ($self, $keys1, $keys2) = @_;
+
+ # Make sure every keys1 is in keys2
+ my $found;
+ foreach my $key (@$keys1) {
+ $found = 0;
+ foreach my $prim (@$keys2) {
+ if ($prim eq $key) {
+ $found = 1;
+ last;
+ }
+ }
+ last unless $found;
+ }
+
+ # Make sure every key2 is in key1
+ if ($found) {
+ foreach my $prim (@$keys2) {
+ $found = 0;
+ foreach my $key (@$keys1) {
+ if ($prim eq $key) {
+ $found = 1;
+ last;
+ }
+ }
+ last unless $found;
+ }
+ }
+
+ return $found;
+}
+
=head2 resolve_join
=over 4
);
}
+=head2 source_name
+
+=over 4
+
+=item Arguments: $source_name
+
+=back
+
+Set the name of the result source when it is loaded into a schema.
+This is usefull if you want to refer to a result source by a name other than
+its class name.
+
+ package ArchivedBooks;
+ use base qw/DBIx::Class/;
+ __PACKAGE__->table('books_archive');
+ __PACKAGE__->source_name('Books');
+
+ # from your schema...
+ $schema->resultset('Books')->find(1);
+
=head2 throw_exception
See L<DBIx::Class::Schema/"throw_exception">.
sub iterator_class { shift->result_source_instance->resultset_class(@_) }
sub resultset_class { shift->result_source_instance->resultset_class(@_) }
+sub source_name { shift->result_source_instance->source_name(@_) }
sub resultset_attributes {
shift->result_source_instance->resultset_attributes(@_);
}
}
+*add_column = \&add_columns;
+
sub has_column {
my ($self, $column) = @_;
return $self->result_source_instance->has_column($column);
return $self->result_source_instance->column_info($column);
}
-
+
sub columns {
return shift->result_source_instance->columns(@_);
}
-
+
+sub remove_columns {
+ return shift->result_source_instance->remove_columns(@_);
+}
+
+*remove_column = \&remove_columns;
+
sub set_primary_key {
shift->result_source_instance->set_primary_key(@_);
}
shift->result_source_instance->unique_constraints(@_);
}
+sub unique_constraint_names {
+ shift->result_source_instance->unique_constraint_names(@_);
+}
+
+sub unique_constraint_columns {
+ shift->result_source_instance->unique_constraint_columns(@_);
+}
+
sub add_relationship {
my ($class, $rel, @rest) = @_;
my $source = $class->result_source_instance;
=head2 is_changed
- my @changed_col_names = $obj->is_changed
+ my @changed_col_names = $obj->is_changed();
+ if ($obj->is_changed()) { ... }
=cut
return keys %{shift->{_dirty_columns} || {}};
}
+=head2 is_column_changed
+
+ if ($obj->is_column_changed('col')) { ... }
+
+=cut
+
+sub is_column_changed {
+ my( $self, $col ) = @_;
+ return exists $self->{_dirty_columns}->{$col};
+}
+
=head2 result_source
Accessor to the ResultSource this object was created from
package Library::Schema;
use base qw/DBIx::Class::Schema/;
-
+
# load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
__PACKAGE__->load_classes(qw/CD Book DVD/);
$password,
{ AutoCommit => 0 },
);
-
+
my $schema2 = Library::Schema->connect($coderef_returning_dbh);
# fetch objects using Library::Schema::DVD
sub load_classes {
my ($class, @params) = @_;
-
+
my %comps_for;
-
+
if (@params) {
foreach my $param (@params) {
if (ref $param eq 'ARRAY') {
# filter out commented entries
my @modules = grep { $_ !~ /^#/ } @$param;
-
+
push (@{$comps_for{$class}}, @modules);
}
elsif (ref $param eq 'HASH') {
die $@ unless $@ =~ /Can't locate.+$comp_class\.pm\sin\s\@INC/;
warn $@ if $@;
}
- push(@to_register, [ $comp, $comp_class ]);
+
+ $comp_class->source_name($comp) unless $comp_class->source_name;
+
+ push(@to_register, [ $comp_class->source_name, $comp_class ]);
}
}
}
__PACKAGE__->load_components(qw/AccessorGroup/);
__PACKAGE__->mk_group_accessors('simple' =>
- qw/connect_info _dbh _sql_maker _conn_pid _conn_tid debug debugfh
+ qw/_connect_info _dbh _sql_maker _conn_pid _conn_tid debug debugfh
cursor on_connect_do transaction_depth/);
sub new {
=cut
+=head2 connect_info
+
+Connection information arrayref. Can either be the same arguments
+one would pass to DBI->connect, or a code-reference which returns
+a connected database handle. In either case, there is an optional
+final element in the arrayref, which can hold a hashref of
+connection-specific Storage::DBI options. These include
+C<on_connect_do>, and the sql_maker options C<limit_dialect>,
+C<quote_char>, and C<name_sep>. Examples:
+
+ ->connect_info([ 'dbi:SQLite:./foo.db' ]);
+ ->connect_info(sub { DBI->connect(...) });
+ ->connect_info([ 'dbi:Pg:dbname=foo',
+ 'postgres',
+ '',
+ { AutoCommit => 0 },
+ { quote_char => q{`}, name_sep => q{@} },
+ ]);
+
=head2 on_connect_do
Executes the sql statements given as a listref on every db connect.
return $self->_sql_maker;
}
+sub connect_info {
+ my ($self, $info_arg) = @_;
+
+ if($info_arg) {
+ my $info = [ @$info_arg ]; # copy because we can alter it
+ my $last_info = $info->[-1];
+ if(ref $last_info eq 'HASH') {
+ my $used;
+ if(my $on_connect_do = $last_info->{on_connect_do}) {
+ $used = 1;
+ $self->on_connect_do($on_connect_do);
+ }
+ for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
+ if(my $opt_val = $last_info->{$sql_maker_opt}) {
+ $used = 1;
+ $self->sql_maker->$sql_maker_opt($opt_val);
+ }
+ }
+
+ # remove our options hashref if it was there, to avoid confusing
+ # DBI in the case the user didn't use all 4 DBI options, as in:
+ # [ 'dbi:SQLite:foo.db', { quote_char => q{`} } ]
+ pop(@$info) if $used;
+ }
+
+ $self->_connect_info($info);
+ }
+
+ $self->_connect_info;
+}
+
sub _populate_dbh {
my ($self) = @_;
- my @info = @{$self->connect_info || []};
+ my @info = @{$self->_connect_info || []};
$self->_dbh($self->_connect(@info));
my $driver = $self->_dbh->{Driver}->{Name};
eval "require DBIx::Class::Storage::DBI::${driver}";
# print Dumper($dbixschema->registered_classes);
#foreach my $tableclass ($dbixschema->registered_classes)
+
+ my %seen_tables;
+
foreach my $moniker ($dbixschema->sources)
{
#eval "use $tableclass";
#print("Can't load $tableclass"), next if($@);
my $source = $dbixschema->source($moniker);
+ next if $seen_tables{$source->name}++;
+
my $table = $schema->add_table(
name => $source->name,
type => 'TABLE',
}
$table->primary_key($source->primary_columns);
+ my @primary = $source->primary_columns;
+ my %unique_constraints = $source->unique_constraints;
+ foreach my $uniq (keys %unique_constraints) {
+ if (!$source->compare_relationship_keys($unique_constraints{$uniq}, \@primary)) {
+ $table->add_constraint(
+ type => 'unique',
+ name => "$uniq",
+ fields => $unique_constraints{$uniq}
+ );
+ }
+ }
+
my @rels = $source->relationships();
foreach my $rel (@rels)
{
my $rel_info = $source->relationship_info($rel);
- my $rel_table = $source->related_source($rel)->name;
-
# Ignore any rel cond that isn't a straight hash
next unless ref $rel_info->{cond} eq 'HASH';
+ my $othertable = $source->related_source($rel);
+ my $rel_table = $othertable->name;
+
# Get the key information, mapping off the foreign/self markers
my @cond = keys(%{$rel_info->{cond}});
my @refkeys = map {/^\w+\.(\w+)$/} @cond;
if($rel_table)
{
- #Decide if this is a foreign key based on whether the self
- #items are our primary columns.
+ my $reverse_rels = $source->reverse_relationship_info($rel);
+ my ($otherrelname, $otherrelationship) = each %{$reverse_rels};
- # Make sure every self key is in the primary key list
- my $found;
- foreach my $key (@keys) {
- $found = 0;
- foreach my $prim ($source->primary_columns) {
- if ($prim eq $key) {
- $found = 1;
- last;
- }
- }
- last unless $found;
- }
+ my $on_delete = '';
+ my $on_update = '';
- # Make sure every primary key column is in the self keys
- if ($found) {
- foreach my $prim ($source->primary_columns) {
- $found = 0;
- foreach my $key (@keys) {
- if ($prim eq $key) {
- $found = 1;
- last;
- }
- }
- last unless $found;
- }
+ if (defined $otherrelationship) {
+ $on_delete = $otherrelationship->{'attrs'}->{cascade_delete} ? 'CASCADE' : '';
+ $on_update = $otherrelationship->{'attrs'}->{cascade_copy} ? 'CASCADE' : '';
}
- # if $found then the two sets are equal.
+ #Decide if this is a foreign key based on whether the self
+ #items are our primary columns.
# If the sets are different, then we assume it's a foreign key from
# us to another table.
- if (!$found) {
+ if (!$source->compare_relationship_keys(\@keys, \@primary)) {
$table->add_constraint(
type => 'foreign_key',
name => "fk_$keys[0]",
fields => \@keys,
reference_fields => \@refkeys,
reference_table => $rel_table,
+ on_delete => $on_delete,
+ on_update => $on_update
);
}
}
}
1;
+
use lib qw(lib t/lib);
use DBICTest;
-use DBICTest::HelperRels;
+use DBICTest::Schema::HelperRels;
my $schema = DBICTest->initialise;
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+use lib qw(lib t/lib);
+
+# USAGE:
+# maint/inheritance_pod.pl Some::Module
+
+my $module = $ARGV[0];
+eval(" require $module; ");
+
+my @modules = Class::C3::calculateMRO($module);
+shift( @modules );
+
+print "=head1 INHERITED METHODS\n\n";
+
+foreach my $module (@modules) {
+ print "=head2 $module\n\n";
+ print "=over 4\n\n";
+ my $file = $module;
+ $file =~ s/::/\//g;
+ $file .= '.pm';
+ foreach my $path (@INC){
+ if (-e "$path/$file") {
+ open(MODULE,"<$path/$file");
+ while (my $line = <MODULE>) {
+ if ($line=~/^\s*sub ([a-z][a-z_]+) \{/) {
+ my $method = $1;
+ print "=item *\n\n";
+ print "L<$method|$module/$method>\n\n";
+ }
+ }
+ close(MODULE);
+ last;
+ }
+ }
+ print "=back\n\n";
+}
+
+1;
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::BasicRels;
+
+require "t/run/28result_set_column.tl";
+run_tests(DBICTest->schema);
my $schema = DBICTest::Schema;
-plan tests => 27;
+plan tests => 33;
my $translator = SQL::Translator->new(
parser_args => {
my $output = $translator->translate();
-my @constraints =
+my @fk_constraints =
(
{'display' => 'twokeys->cd',
'selftable' => 'twokeys', 'foreigntable' => 'cd',
{'display' => 'twokeys->artist',
'selftable' => 'twokeys', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
- 'needed' => 1, on_delete => '', on_update => ''},
+ 'needed' => 1, on_delete => 'CASCADE', on_update => 'CASCADE'},
{'display' => 'cd_to_producer->cd',
'selftable' => 'cd_to_producer', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- 'needed' => 1, on_delete => '', on_update => ''},
+ 'needed' => 1, on_delete => 'CASCADE', on_update => 'CASCADE'},
{'display' => 'cd_to_producer->producer',
'selftable' => 'cd_to_producer', 'foreigntable' => 'producer',
'selfcols' => ['producer'], 'foreigncols' => ['producerid'],
{'display' => 'self_ref_alias -> self_ref for self_ref',
'selftable' => 'self_ref_alias', 'foreigntable' => 'self_ref',
'selfcols' => ['self_ref'], 'foreigncols' => ['id'],
- 'needed' => 1, on_delete => '', on_update => ''},
+ 'needed' => 1, on_delete => 'CASCADE', on_update => 'CASCADE'},
{'display' => 'self_ref_alias -> self_ref for alias',
'selftable' => 'self_ref_alias', 'foreigntable' => 'self_ref',
'selfcols' => ['alias'], 'foreigncols' => ['id'],
{'display' => 'cd -> artist',
'selftable' => 'cd', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
- 'needed' => 1, on_delete => '', on_update => ''},
+ 'needed' => 1, on_delete => 'CASCADE', on_update => 'CASCADE'},
{'display' => 'artist_undirected_map -> artist for id1',
'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist',
'selfcols' => ['id1'], 'foreigncols' => ['artistid'],
- 'needed' => 1, on_delete => '', on_update => ''},
+ 'needed' => 1, on_delete => 'CASCADE', on_update => ''},
{'display' => 'artist_undirected_map -> artist for id2',
'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist',
'selfcols' => ['id2'], 'foreigncols' => ['artistid'],
- 'needed' => 1, on_delete => '', on_update => ''},
+ 'needed' => 1, on_delete => 'CASCADE', on_update => ''},
{'display' => 'track->cd',
'selftable' => 'track', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- 'needed' => 2, on_delete => '', on_update => ''},
+ 'needed' => 2, on_delete => 'CASCADE', on_update => 'CASCADE'},
{'display' => 'treelike -> treelike for parent',
'selftable' => 'treelike', 'foreigntable' => 'treelike',
'selfcols' => ['parent'], 'foreigncols' => ['id'],
{'display' => 'tags -> cd',
'selftable' => 'tags', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
- 'needed' => 1, on_delete => '', on_update => ''},
+ 'needed' => 1, on_delete => 'CASCADE', on_update => 'CASCADE'},
);
+my @unique_constraints = (
+ {'display' => 'cd artist and title unique',
+ 'table' => 'cd', 'cols' => ['artist', 'title'],
+ 'needed' => 1},
+ {'display' => 'twokeytreelike name unique',
+ 'table' => 'twokeytreelike', 'cols' => ['name'],
+ 'needed' => 1},
+ {'display' => 'employee position and group_id unique',
+ 'table' => 'employee', cols => ['position', 'group_id'],
+ 'needed' => 1},
+);
+
my $tschema = $translator->schema();
for my $table ($tschema->get_tables) {
my $table_name = $table->name;
for my $c ( $table->get_constraints ) {
- next unless $c->type eq 'FOREIGN KEY';
-
- ok(check($table_name, scalar $c->fields,
- $c->reference_table, scalar $c->reference_fields,
- $c->on_delete, $c->on_update), "Constraint on $table_name matches an expected constraint");
+ if ($c->type eq 'FOREIGN KEY') {
+ ok(check_fk($table_name, scalar $c->fields,
+ $c->reference_table, scalar $c->reference_fields,
+ $c->on_delete, $c->on_update), "Foreign key constraint on $table_name matches an expected constraint");
+ }
+ elsif ($c->type eq 'UNIQUE') {
+ ok(check_unique($table_name, scalar $c->fields),
+ "Unique constraint on $table_name matches an expected constraint");
+ }
}
}
+# Make sure all the foreign keys are done.
my $i;
-for ($i = 0; $i <= $#constraints; ++$i) {
- ok(!$constraints[$i]->{'needed'}, "Constraint $constraints[$i]->{display}");
+for ($i = 0; $i <= $#fk_constraints; ++$i) {
+ ok(!$fk_constraints[$i]->{'needed'}, "Constraint $fk_constraints[$i]->{display}");
+}
+# Make sure all the uniques are done.
+for ($i = 0; $i <= $#unique_constraints; ++$i) {
+ ok(!$unique_constraints[$i]->{'needed'}, "Constraint $unique_constraints[$i]->{display}");
}
-sub check {
+sub check_fk {
my ($selftable, $selfcol, $foreigntable, $foreigncol, $ondel, $onupd) = @_;
$ondel = '' if (!defined($ondel));
$onupd = '' if (!defined($onupd));
my $i;
- for ($i = 0; $i <= $#constraints; ++$i) {
- if ($selftable eq $constraints[$i]->{'selftable'} &&
- $foreigntable eq $constraints[$i]->{'foreigntable'} &&
- ($ondel eq $constraints[$i]->{on_delete}) &&
- ($onupd eq $constraints[$i]->{on_update})) {
+ for ($i = 0; $i <= $#fk_constraints; ++$i) {
+ if ($selftable eq $fk_constraints[$i]->{'selftable'} &&
+ $foreigntable eq $fk_constraints[$i]->{'foreigntable'} &&
+ ($ondel eq $fk_constraints[$i]->{on_delete}) &&
+ ($onupd eq $fk_constraints[$i]->{on_update})) {
# check columns
my $found = 0;
for (my $j = 0; $j <= $#$selfcol; ++$j) {
$found = 0;
- for (my $k = 0; $k <= $#{$constraints[$i]->{'selfcols'}}; ++$k) {
- if ($selfcol->[$j] eq $constraints[$i]->{'selfcols'}->[$k] &&
- $foreigncol->[$j] eq $constraints[$i]->{'foreigncols'}->[$k]) {
+ for (my $k = 0; $k <= $#{$fk_constraints[$i]->{'selfcols'}}; ++$k) {
+ if ($selfcol->[$j] eq $fk_constraints[$i]->{'selfcols'}->[$k] &&
+ $foreigncol->[$j] eq $fk_constraints[$i]->{'foreigncols'}->[$k]) {
+ $found = 1;
+ last;
+ }
+ }
+ last unless $found;
+ }
+
+ if ($found) {
+ for (my $j = 0; $j <= $#{$fk_constraints[$i]->{'selfcols'}}; ++$j) {
+ $found = 0;
+ for (my $k = 0; $k <= $#$selfcol; ++$k) {
+ if ($selfcol->[$k] eq $fk_constraints[$i]->{'selfcols'}->[$j] &&
+ $foreigncol->[$k] eq $fk_constraints[$i]->{'foreigncols'}->[$j]) {
+ $found = 1;
+ last;
+ }
+ }
+ last unless $found;
+ }
+ }
+
+ if ($found) {
+ --$fk_constraints[$i]->{needed};
+ return 1;
+ }
+ }
+ }
+ return 0;
+}
+
+sub check_unique {
+ my ($selftable, $selfcol) = @_;
+
+ $ondel = '' if (!defined($ondel));
+ $onupd = '' if (!defined($onupd));
+
+ my $i;
+ for ($i = 0; $i <= $#unique_constraints; ++$i) {
+ if ($selftable eq $unique_constraints[$i]->{'table'}) {
+
+ my $found = 0;
+ for (my $j = 0; $j <= $#$selfcol; ++$j) {
+ $found = 0;
+ for (my $k = 0; $k <= $#{$unique_constraints[$i]->{'cols'}}; ++$k) {
+ if ($selfcol->[$j] eq $unique_constraints[$i]->{'cols'}->[$k]) {
$found = 1;
last;
}
}
if ($found) {
- for (my $j = 0; $j <= $#{$constraints[$i]->{'selfcols'}}; ++$j) {
+ for (my $j = 0; $j <= $#{$unique_constraints[$i]->{'cols'}}; ++$j) {
$found = 0;
for (my $k = 0; $k <= $#$selfcol; ++$k) {
- if ($selfcol->[$k] eq $constraints[$i]->{'selfcols'}->[$j] &&
- $foreigncol->[$k] eq $constraints[$i]->{'foreigncols'}->[$j]) {
+ if ($selfcol->[$k] eq $unique_constraints[$i]->{'cols'}->[$j]) {
$found = 1;
last;
}
}
if ($found) {
- --$constraints[$i]->{needed};
+ --$unique_constraints[$i]->{needed};
return 1;
}
}
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::HelperRels;
+
+require "t/run/27ordered.tl";
+run_tests(DBICTest->schema);
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::HelperRels;
+
+require "t/run/28result_set_column.tl";
+run_tests(DBICTest->schema);
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema;
use base qw/DBIx::Class::Schema/;
__PACKAGE__->load_classes(qw/
Artist
+ Employee
CD
#dummy
Track
'#dummy',
'SelfRef',
'ArtistUndirectedMap',
+ 'ArtistSourceName',
'Producer',
'CD_to_Producer',
),
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::ArtistSourceName;
+
+use base 'DBICTest::Schema::Artist';
+
+__PACKAGE__->source_name('SourceNameArtists');
+
+1;
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::Employee;
+
+use base 'DBIx::Class';
+
+__PACKAGE__->load_components(qw( Ordered PK::Auto Core ));
+
+__PACKAGE__->table('employee');
+
+__PACKAGE__->add_columns(
+ employee_id => {
+ data_type => 'integer',
+ is_auto_increment => 1
+ },
+ position => {
+ data_type => 'integer',
+ },
+ group_id => {
+ data_type => 'integer',
+ is_nullable => 1,
+ },
+ name => {
+ data_type => 'varchar',
+ size => 100,
+ is_nullable => 1,
+ },
+);
+
+__PACKAGE__->set_primary_key('employee_id');
+__PACKAGE__->position_column('position');
+
+__PACKAGE__->add_unique_constraint(position_group => [ qw/position group_id/ ]);
+
+__PACKAGE__->mk_classdata('field_name_for', {
+ employee_id => 'primary key',
+ position => 'list position',
+ group_id => 'collection column',
+ name => 'employee name',
+});
+
+1;
},
);
__PACKAGE__->set_primary_key(qw/id1 id2/);
+__PACKAGE__->add_unique_constraint('tktlnameunique' => ['name']);
__PACKAGE__->belongs_to('parent', 'TwoKeyTreeLike',
{ 'foreign.id1' => 'self.parent1', 'foreign.id2' => 'self.parent2'});
close IN;
- $dbh->do($_) for split(/\n\n/, $sql);
+ $dbh->do($_) for split(/;\n/, $sql);
}
$schema->storage->dbh->do("PRAGMA synchronous = OFF");
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Sun Mar 19 19:16:50 2006
+-- Created on Wed Apr 19 18:32:39 2006
--
BEGIN TRANSACTION;
--
--- Table: serialized
+-- Table: employee
--
-CREATE TABLE serialized (
- id INTEGER PRIMARY KEY NOT NULL,
- serialized text NOT NULL
+CREATE TABLE employee (
+ employee_id INTEGER PRIMARY KEY NOT NULL,
+ position integer NOT NULL,
+ group_id integer,
+ name varchar(100)
);
--
--- Table: twokeys
+-- Table: serialized
--
-CREATE TABLE twokeys (
- artist integer NOT NULL,
- cd integer NOT NULL,
- PRIMARY KEY (artist, cd)
+CREATE TABLE serialized (
+ id INTEGER PRIMARY KEY NOT NULL,
+ serialized text NOT NULL
);
--
);
--
+-- Table: twokeytreelike
+--
+CREATE TABLE twokeytreelike (
+ id1 integer NOT NULL,
+ id2 integer NOT NULL,
+ parent1 integer NOT NULL,
+ parent2 integer NOT NULL,
+ name varchar(100) NOT NULL,
+ PRIMARY KEY (id1, id2)
+);
+
+--
-- Table: self_ref_alias
--
CREATE TABLE self_ref_alias (
);
--
--- Table: fourkeys
---
-CREATE TABLE fourkeys (
- foo integer NOT NULL,
- bar integer NOT NULL,
- hello integer NOT NULL,
- goodbye integer NOT NULL,
- PRIMARY KEY (foo, bar, hello, goodbye)
-);
-
---
-- Table: cd
--
CREATE TABLE cd (
);
--
--- Table: artist_undirected_map
---
-CREATE TABLE artist_undirected_map (
- id1 integer NOT NULL,
- id2 integer NOT NULL,
- PRIMARY KEY (id1, id2)
-);
-
---
--- Table: onekey
---
-CREATE TABLE onekey (
- id INTEGER PRIMARY KEY NOT NULL,
- artist integer NOT NULL,
- cd integer NOT NULL
-);
-
---
-- Table: track
--
CREATE TABLE track (
);
--
--- Table: producer
+-- Table: self_ref
--
-CREATE TABLE producer (
- producerid INTEGER PRIMARY KEY NOT NULL,
+CREATE TABLE self_ref (
+ id INTEGER PRIMARY KEY NOT NULL,
+ name varchar(100) NOT NULL
+);
+
+--
+-- Table: treelike
+--
+CREATE TABLE treelike (
+ id INTEGER PRIMARY KEY NOT NULL,
+ parent integer NOT NULL,
name varchar(100) NOT NULL
);
);
--
--- Table: self_ref
+-- Table: twokeys
--
-CREATE TABLE self_ref (
- id INTEGER PRIMARY KEY NOT NULL,
- name varchar(100) NOT NULL
+CREATE TABLE twokeys (
+ artist integer NOT NULL,
+ cd integer NOT NULL,
+ PRIMARY KEY (artist, cd)
);
--
--- Table: treelike
+-- Table: fourkeys
--
-CREATE TABLE treelike (
+CREATE TABLE fourkeys (
+ foo integer NOT NULL,
+ bar integer NOT NULL,
+ hello integer NOT NULL,
+ goodbye integer NOT NULL,
+ PRIMARY KEY (foo, bar, hello, goodbye)
+);
+
+--
+-- Table: artist_undirected_map
+--
+CREATE TABLE artist_undirected_map (
+ id1 integer NOT NULL,
+ id2 integer NOT NULL,
+ PRIMARY KEY (id1, id2)
+);
+
+--
+-- Table: onekey
+--
+CREATE TABLE onekey (
id INTEGER PRIMARY KEY NOT NULL,
- parent integer NOT NULL,
+ artist integer NOT NULL,
+ cd integer NOT NULL
+);
+
+--
+-- Table: producer
+--
+CREATE TABLE producer (
+ producerid INTEGER PRIMARY KEY NOT NULL,
name varchar(100) NOT NULL
);
+CREATE UNIQUE INDEX position_group_employee on employee (position, group_id);
+CREATE UNIQUE INDEX tktlnameunique_twokeytreelike on twokeytreelike (name);
+CREATE UNIQUE INDEX artist_title_cd on cd (artist, title);
COMMIT;
sub run_tests {
my $schema = shift;
-plan tests => 46;
+plan tests => 55;
# figure out if we've got a version of sqlite that is older than 3.2.6, in
# which case COUNT(DISTINCT()) doesn't work
is($schema->resultset("Artist")->count, 4, 'count ok');
+# test find_or_new
+{
+ my $existing_obj = $schema->resultset('Artist')->find_or_new({
+ artistid => 4,
+ });
+
+ is($existing_obj->name, 'Man With A Spoon', 'find_or_new: found existing artist');
+ ok($existing_obj->in_storage, 'existing artist is in storage');
+
+ my $new_obj = $schema->resultset('Artist')->find_or_new({
+ artistid => 5,
+ name => 'find_or_new',
+ });
+
+ is($new_obj->name, 'find_or_new', 'find_or_new: instantiated a new artist');
+ ok(! $new_obj->in_storage, 'new artist is not in storage');
+}
+
my $cd = $schema->resultset("CD")->find(1);
my %cols = $cd->get_columns;
is($art->name, 'Test _cond_for_update_delete', 'updated second artist name');
}
-#test cascade_delete thru many_many relations
-my $art_del = $schema->resultset("Artist")->find({ artistid => 1 });
-$art_del->delete;
-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 source_name
+{
+ # source_name should be set for normal modules
+ is($schema->source('CD')->source_name, 'CD', 'source_name is set to moniker');
+
+ # test the result source that sets source_name explictly
+ ok($schema->source('SourceNameArtists'), 'SourceNameArtists result source exists');
+
+ my @artsn = $schema->resultset('SourceNameArtists')->search({}, { order_by => 'name DESC' });
+ cmp_ok(@artsn, '==', 4, "Four artists returned");
+}
+
+# test cascade_delete through many_to_many relations
+{
+ my $art_del = $schema->resultset("Artist")->find({ artistid => 1 });
+ $art_del->delete;
+ 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 column_info
+{
+ $schema->source("Artist")->{_columns}{'artistid'} = {};
-$schema->source("Artist")->{_columns}{'artistid'} = {};
+ my $typeinfo = $schema->source("Artist")->column_info('artistid');
+ is($typeinfo->{data_type}, 'INTEGER', 'column_info ok');
+ $schema->source("Artist")->column_info('artistid');
+ ok($schema->source("Artist")->{_columns_info_loaded} == 1, 'Columns info flag set');
+}
-my $typeinfo = $schema->source("Artist")->column_info('artistid');
-is($typeinfo->{data_type}, 'INTEGER', 'column_info ok');
-$schema->source("Artist")->column_info('artistid');
-ok($schema->source("Artist")->{_columns_info_loaded} == 1, 'Columns info flag set');
+# test remove_columns
+{
+ is_deeply([$schema->source('CD')->columns], [qw/cdid artist title year/]);
+ $schema->source('CD')->remove_columns('year');
+ is_deeply([$schema->source('CD')->columns], [qw/cdid artist title/]);
+}
}
'name' => {
'data_type' => 'varchar',
'is_nullable' => 0,
- }
+ },
};
is_deeply($type_info, $test_type_info, 'columns_info_for - column data types');
use strict;
use warnings;
-plan tests => 26;
+plan tests => 30;
# has_a test
my $cd = $schema->resultset("CD")->find(4);
$artist->delete_related( cds => { title => 'Greatest Hits' });
cmp_ok( $schema->resultset("CD")->search( title => 'Greatest Hits' ), '==', 0, 'delete_related ok' );
+# find_or_new_related with an existing record
+$cd = $artist->find_or_new_related( 'cds', { title => 'Big Flop' } );
+is( $cd->year, 2005, 'find_or_new_related on existing record ok' );
+ok( $cd->in_storage, 'find_or_new_related on existing record: is in_storage' );
+
+# find_or_new_related instantiating a new record
+$cd = $artist->find_or_new_related( 'cds', {
+ title => 'Greatest Hits 2: Louder Than Ever',
+ year => 2007,
+} );
+is( $cd->title, 'Greatest Hits 2: Louder Than Ever', 'find_or_new_related new record ok' );
+ok( ! $cd->in_storage, 'find_or_new_related on a new record: not in_storage' );
+
SKIP: {
skip "relationship checking needs fixing", 1;
# try to add a bogus relationship using the wrong cols
my $dbh = DB2Test->schema->storage->dbh;
-{
- local $SIG{__WARN__} = sub {};
- $dbh->do("DROP TABLE artist;");
-}
+$dbh->do("DROP TABLE artist", { RaiseError => 0, PrintError => 0 });
$dbh->do("CREATE TABLE artist (artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1), name VARCHAR(255), charfield CHAR(10));");
sub run_tests {
my $schema = shift;
-plan tests => 18;
+plan tests => 34;
my $artistid = 1;
my $title = 'UNIQUE Constraint';
is($cd2->title, $cd1->title, 'title is correct');
is($cd2->year, $cd1->year, 'year is correct');
-my $cd3 = $schema->resultset('CD')->update_or_create(
+my $cd3 = $schema->resultset('CD')->find($artistid, $title, { key => 'artist_title' });
+
+is($cd3->get_column('artist'), $cd1->get_column('artist'), 'find by specific key, ordered columns: artist is correct');
+is($cd3->title, $cd1->title, 'title is correct');
+is($cd3->year, $cd1->year, 'year is correct');
+
+my $cd4 = $schema->resultset('CD')->update_or_create(
{
artist => $artistid,
title => $title,
},
);
-ok(! $cd3->is_changed, 'update_or_create without key: row is clean');
-is($cd3->cdid, $cd2->cdid, 'cdid is correct');
-is($cd3->get_column('artist'), $cd2->get_column('artist'), 'artist is correct');
-is($cd3->title, $cd2->title, 'title is correct');
-is($cd3->year, 2007, 'updated year is correct');
+ok(! $cd4->is_changed, 'update_or_create without key: row is clean');
+is($cd4->cdid, $cd2->cdid, 'cdid is correct');
+is($cd4->get_column('artist'), $cd2->get_column('artist'), 'artist is correct');
+is($cd4->title, $cd2->title, 'title is correct');
+is($cd4->year, 2007, 'updated year is correct');
-my $cd4 = $schema->resultset('CD')->update_or_create(
+my $cd5 = $schema->resultset('CD')->update_or_create(
{
artist => $artistid,
title => $title,
{ key => 'artist_title' }
);
-ok(! $cd4->is_changed, 'update_or_create by specific key: row is clean');
-is($cd4->cdid, $cd2->cdid, 'cdid is correct');
-is($cd4->get_column('artist'), $cd2->get_column('artist'), 'artist is correct');
-is($cd4->title, $cd2->title, 'title is correct');
-is($cd4->year, 2007, 'updated year is correct');
+ok(! $cd5->is_changed, 'update_or_create by specific key: row is clean');
+is($cd5->cdid, $cd2->cdid, 'cdid is correct');
+is($cd5->get_column('artist'), $cd2->get_column('artist'), 'artist is correct');
+is($cd5->title, $cd2->title, 'title is correct');
+is($cd5->year, 2007, 'updated year is correct');
-my $cd5 = $schema->resultset('CD')->update_or_create(
+my $cd6 = $schema->resultset('CD')->update_or_create(
{
cdid => $cd2->cdid,
artist => 1,
{ key => 'primary' }
);
-ok(! $cd5->is_changed, 'update_or_create by PK: row is clean');
-is($cd5->cdid, $cd2->cdid, 'cdid is correct');
-is($cd5->get_column('artist'), $cd2->get_column('artist'), 'artist is correct');
-is($cd5->title, $cd2->title, 'title is correct');
-is($cd5->year, 2005, 'updated year is correct');
+ok(! $cd6->is_changed, 'update_or_create by PK: row is clean');
+is($cd6->cdid, $cd2->cdid, 'cdid is correct');
+is($cd6->get_column('artist'), $cd2->get_column('artist'), 'artist is correct');
+is($cd6->title, $cd2->title, 'title is correct');
+is($cd6->year, 2005, 'updated year is correct');
+
+my $cd7 = $schema->resultset('CD')->find_or_create(
+ {
+ artist => $artistid,
+ title => $title,
+ year => 2010,
+ },
+ { key => 'artist_title' }
+);
+
+is($cd7->cdid, $cd1->cdid, 'find_or_create by specific key: cdid is correct');
+is($cd7->get_column('artist'), $cd1->get_column('artist'), 'artist is correct');
+is($cd7->title, $cd1->title, 'title is correct');
+is($cd7->year, $cd1->year, 'year is correct');
+
+my $artist = $schema->resultset('Artist')->find($artistid);
+my $cd8 = $artist->find_or_create_related('cds',
+ {
+ artist => $artistid,
+ title => $title,
+ year => 2020,
+ },
+ { key => 'artist_title' }
+);
+
+is($cd8->cdid, $cd1->cdid, 'find_or_create related by specific key: cdid is correct');
+is($cd8->get_column('artist'), $cd1->get_column('artist'), 'artist is correct');
+is($cd8->title, $cd1->title, 'title is correct');
+is($cd8->year, $cd1->year, 'year is correct');
+
+my $cd9 = $artist->update_or_create_related('cds',
+ {
+ artist => $artistid,
+ title => $title,
+ year => 2021,
+ },
+ { key => 'artist_title' }
+);
+
+ok(! $cd9->is_changed, 'update_or_create by specific key: row is clean');
+is($cd9->cdid, $cd1->cdid, 'cdid is correct');
+is($cd9->get_column('artist'), $cd1->get_column('artist'), 'artist is correct');
+is($cd9->title, $cd1->title, 'title is correct');
+is($cd9->year, 2021, 'year is correct');
}
--- /dev/null
+# vim: filetype=perl
+
+sub run_tests {
+
+ plan tests => 321;
+ my $schema = shift;
+
+ my $employees = $schema->resultset('Employee');
+ $employees->delete();
+
+ foreach (1..5) {
+ $employees->create({ name=>'temp' });
+ }
+ $employees = $employees->search(undef,{order_by=>'position'});
+ ok( check_rs($employees), "intial positions" );
+
+ hammer_rs( $employees );
+
+ DBICTest::Employee->grouping_column('group_id');
+ $employees->delete();
+ foreach my $group_id (1..3) {
+ foreach (1..6) {
+ $employees->create({ name=>'temp', group_id=>$group_id });
+ }
+ }
+ $employees = $employees->search(undef,{order_by=>'group_id,position'});
+
+ foreach my $group_id (1..3) {
+ my $group_employees = $employees->search({group_id=>$group_id});
+ $group_employees->all();
+ ok( check_rs($group_employees), "group intial positions" );
+ hammer_rs( $group_employees );
+ }
+
+}
+
+sub hammer_rs {
+ my $rs = shift;
+ my $employee;
+ my $count = $rs->count();
+ my $position_column = $rs->result_class->position_column();
+
+ foreach my $position (1..$count) {
+
+ $row = $rs->find({ $position_column=>$position });
+ $row->move_previous();
+ ok( check_rs($rs), "move_previous( $position )" );
+
+ $row = $rs->find({ $position_column=>$position });
+ $row->move_next();
+ ok( check_rs($rs), "move_next( $position )" );
+
+ $row = $rs->find({ $position_column=>$position });
+ $row->move_first();
+ ok( check_rs($rs), "move_first( $position )" );
+
+ $row = $rs->find({ $position_column=>$position });
+ $row->move_last();
+ ok( check_rs($rs), "move_last( $position )" );
+
+ foreach my $to_position (1..$count) {
+ $row = $rs->find({ $position_column=>$position });
+ $row->move_to($to_position);
+ ok( check_rs($rs), "move_to( $position => $to_position )" );
+ }
+
+ $row = $rs->find({ position=>$position });
+ if ($position==1) {
+ ok( !$row->previous_sibling(), 'no previous sibling' );
+ ok( !$row->first_sibling(), 'no first sibling' );
+ }
+ else {
+ ok( $row->previous_sibling(), 'previous sibling' );
+ ok( $row->first_sibling(), 'first sibling' );
+ }
+ if ($position==$count) {
+ ok( !$row->next_sibling(), 'no next sibling' );
+ ok( !$row->last_sibling(), 'no last sibling' );
+ }
+ else {
+ ok( $row->next_sibling(), 'next sibling' );
+ ok( $row->last_sibling(), 'last sibling' );
+ }
+
+ }
+}
+
+sub check_rs {
+ my( $rs ) = @_;
+ $rs->reset();
+ my $position_column = $rs->result_class->position_column();
+ my $expected_position = 0;
+ while (my $row = $rs->next()) {
+ $expected_position ++;
+ if ($row->get_column($position_column)!=$expected_position) {
+ return 0;
+ }
+ }
+ return 1;
+}
+
+1;
--- /dev/null
+sub run_tests {
+my $schema = shift;
+
+plan tests => 5;
+
+my $rs = $cd = $schema->resultset("CD")->search({});
+
+my $rs_title = $rs->get_column('title');
+my $rs_year = $rs->get_column('year');
+
+is($rs_title->next, 'Spoonful of bees', "next okay");
+
+my @all = $rs_title->all;
+cmp_ok(scalar @all, '==', 5, "five titles returned");
+
+cmp_ok($rs_year->max, '==', 2001, "max okay for year");
+is($rs_title->min, 'Caterwaulin\' Blues', "min okay for title");
+
+cmp_ok($rs_year->sum, '==', 9996, "three artists returned");
+
+}
+
+1;