--- /dev/null
+Build
+Build.bat
+Makefile
+_build/
+blib/
+t/var/
'Scalar::Util' => 0,
'SQL::Abstract' => 1.20,
'SQL::Abstract::Limit' => 0.101,
- 'Algorithm::C3' => 0.02,
+ 'Algorithm::C3' => 0.04,
'Class::C3' => 0.11,
'Storable' => 0,
'Class::Data::Accessor' => 0.01,
Revision history for DBIx::Class
-0.07001
+ - remove_columns now deletes columns from _columns
+
+0.07001 2006-08-18 19:55:00
+ - add directory argument to deploy()
+ - support default aliases in many_to_many accessors.
+ - support for relationship attributes in many_to_many accessors.
+ - stop search_rs being destructive to attrs
+ - better error reporting when loading components
+ - UTF8Columns changed to use "utf8" instead of "Encode"
- restore automatic aliasing in ResultSet::find() on nonunique queries
- allow aliases in ResultSet::find() queries (in cases of relationships
with prefetch)
https://bugzilla.redhat.com/bugzilla/show_bug.cgi?id=196836
- fix a pathological prefetch case
- table case fix for Oracle in columns_info_for
+ - stopped search_rs deleting attributes from passed hash
0.07000 2006-07-23 02:30:00
- supress warnings for possibly non-unique queries, since
gphat: Cory G Watson <gphat@cpan.org>
+dyfrgi: Michael Leuchtenmurg <michael@slashhome.org>
+
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
my $author->delete_related('books', { name => 'Titanic' });
+=head3 Ordering a relationship result set
+
+If you always want a relation to be ordered, you can specify this when you
+create the relationship.
+
+To order C<< $book->pages >> by descending page_number.
+
+ Book->has_many('pages' => 'Page', 'book', { order_by => \'page_number DESC'} );
+
+
+
=head2 Transactions
As of version 0.04001, there is improved transaction support in
my ($self, @rest) = @_;
my $ret = $self->next::method(@rest);
- my ($pri, $too_many) = grep { !defined $self->get_column($_) } $self->primary_columns;
+ my ($pri, $too_many) = grep { !defined $self->get_column($_) ||
+ ref($self->get_column($_)) eq 'SCALAR'} $self->primary_columns;
return $ret unless defined $pri; # if all primaries are already populated, skip auto-inc
$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
if defined $too_many;
my $storage = $self->result_source->storage;
- $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" ) unless $storage->can('last_insert_id');
+ $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
+ unless $storage->can('last_insert_id');
my $id = $storage->last_insert_id($self->result_source,$pri);
$self->throw_exception( "Can't get last insert id" ) unless $id;
$self->store_column($pri => $id);
$obj->author($new_author_obj);
Creates a relationship where the calling class stores the foreign class's
-primary key in one (or more) of its columns. If $cond is a column name
+primary key in one (or more) of its columns. If C<$cond> is a column name
instead of a join condition hash, that is used as the name of the column
-holding the foreign key. If $cond is not given, the relname is used as
+holding the foreign key. If C<$cond> is not given, the relname is used as
the column name.
-If the relationship is optional - ie the column containing the foreign
+If the relationship is optional - i.e. the column containing the foreign
key can be NULL - then the belongs_to relationship does the right
-thing - so in the example above C<$obj->author> would return C<undef>.
+thing - so in the example above C<$obj-E<gt>author> would return C<undef>.
However in this case you would probably want to set the C<join_type>
attribute so that a C<LEFT JOIN> is done, which makes complex
resultsets involving C<join> or C<prefetch> operations work correctly.
-The modified declaration is shown below:-
+The modified declaration is shown below:
- # in a Book class (where Author has many Books)
+ # in a Book class (where Author has_many Books)
__PACKAGE__->belongs_to(author => 'My::DBIC::Schema::Author',
'author', {join_type => 'left'});
-Cascading deletes are off per default on a C<belongs_to> relationship, to turn
-them on, pass C<< cascade_delete => 1 >> in the $attr hashref.
+Cascading deletes are off by default on a C<belongs_to>
+relationship. To turn them on, pass C<< cascade_delete => 1 >>
+in the $attr hashref.
NOTE: If you are used to L<Class::DBI> relationships, this is the equivalent
of C<has_a>.
=head2 has_many
- # in an Author class (where Author has many Books)
+ # in an Author class (where Author has_many Books)
My::DBIC::Schema::Author->has_many(books => 'My::DBIC::Schema::Book', 'author');
my $booklist = $obj->books;
my $booklist = $obj->books({
Creates a one-to-many relationship, where the corresponding elements of the
foreign class store the calling class's primary key in one (or more) of its
columns. You should pass the name of the column in the foreign class as the
-$cond argument, or specify a complete join condition.
+C<$cond> argument, or specify a complete join condition.
Three methods are created when you create a has_many relationship. The first
method is the expected accessor method. The second is almost exactly the same
as the accessor method but "_rs" is added to the end of the method name. This
method works just like the normal accessor, except that it returns a resultset
no matter what, even in list context. The third method, named
-C<< add_to_<relname> >>, will also be added to your Row items, this allows
+C<< add_to_<relname> >>, will also be added to your Row items; this allows
you to insert new related items, using the same mechanism as in
L<DBIx::Class::Relationship::Base/"create_related">.
If you delete an object in a class with a C<has_many> relationship, all
-the related objects will be deleted as well. However, any database-level
-cascade or restrict will take precedence. To turn this behavior off, pass
-C<< cascade_delete => 0 >> in the $attr hashref.
+the related objects will be deleted as well. To turn this behaviour off,
+pass C<< cascade_delete => 0 >> in the C<$attr> hashref. However, any
+database-level cascade or restrict will take precedence over a
+DBIx-Class-based cascading delete.
=head2 might_have
Creates an optional one-to-one relationship with a class, where the foreign
class stores our primary key in one of its columns. Defaults to the primary
-key of the foreign class unless $cond specifies a column or join condition.
+key of the foreign class unless C<$cond> specifies a column or join condition.
If you update or delete an object in a class with a C<might_have>
-relationship, the related object will be updated or deleted as well.
-Any database-level update or delete constraints will override this behaviour.
-To turn off this behavior, add C<< cascade_delete => 0 >> to the $attr hashref.
+relationship, the related object will be updated or deleted as well. To
+turn off this behavior, add C<< cascade_delete => 0 >> to the C<$attr>
+hashref. Any database-level update or delete constraints will override
+this behavior.
=head2 has_one
My::DBIC::Schema::Actor->many_to_many( roles => 'actor_roles',
'role' );
-Creates a accessors bridging two relationships; not strictly a relationship in
+Creates accessors bridging two relationships; not strictly a relationship in
its own right, although the accessor will return a resultset or collection of
objects just as a has_many would.
To add an C<OR>ed condition, use an arrayref of hashrefs. See the
L<SQL::Abstract> documentation for more details.
-Valid attributes are as follows:
+In addition to standard result set attributes, the following attributes are also valid:
=over 4
my $remove_meth = "remove_from_${meth}";
my $set_meth = "set_${meth}";
+ $rel_attrs->{alias} ||= $f_rel;
+
*{"${class}::${meth}"} = sub {
my $self = shift;
my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
+ my @args = ($f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs });
$self->search_related($rel)->search_related(
$f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs }
);
my $rel_source_name = $source->relationship_info($rel)->{source};
my $rel_source = $schema->resultset($rel_source_name)->result_source;
my $f_rel_source_name = $rel_source->relationship_info($f_rel)->{source};
- my $f_rel_rs = $schema->resultset($f_rel_source_name);
- my $obj = ref $_[0]
- ? ( ref $_[0] eq 'HASH' ? $f_rel_rs->create($_[0]) : $_[0] )
- : ( $f_rel_rs->create({@_}) );
+ my $f_rel_rs = $schema->resultset($f_rel_source_name)->search({}, $rel_attrs||{});
+
+ my $obj;
+ if (ref $_[0]) {
+ if (ref $_[0] eq 'HASH') {
+ $obj = $f_rel_rs->create($_[0]);
+ } else {
+ $obj = $_[0];
+ }
+ } else {
+ $obj = $f_rel_rs->create({@_});
+ }
+
my $link_vals = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
my $link = $self->search_related($rel)->new_result({});
$link->set_from_related($f_rel, $obj);
$attrs = pop(@_) if @_ > 1 and ref $_[$#_] eq 'HASH';
my $our_attrs = { %{$self->{attrs}} };
my $having = delete $our_attrs->{having};
+ my $where = delete $our_attrs->{where};
+
+ my $new_attrs = { %{$our_attrs}, %{$attrs} };
# merge new attrs into inherited
foreach my $key (qw/join prefetch/) {
next unless exists $attrs->{$key};
- $our_attrs->{$key} = $self->_merge_attr($our_attrs->{$key}, delete $attrs->{$key});
+ $new_attrs->{$key} = $self->_merge_attr($our_attrs->{$key}, $attrs->{$key});
}
-
- my $new_attrs = { %{$our_attrs}, %{$attrs} };
- my $where = (@_
+
+ my $cond = (@_
? (
(@_ == 1 || ref $_[0] eq "HASH")
? shift
}
: $where);
}
+ if (defined $cond) {
+ $new_attrs->{where} = (
+ defined $new_attrs->{where}
+ ? { '-and' => [
+ map {
+ ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_
+ } $cond, $new_attrs->{where}
+ ]
+ }
+ : $cond);
+ }
if (defined $having) {
$new_attrs->{having} = (
Deletes the contents of the resultset from its result source. Note that this
will not run DBIC cascade triggers. See L</delete_all> if you need triggers
-to run.
+to run. See also L<DBIx::Class::Row/delete>.
=cut
) if ($self->{cond} && !(ref $self->{cond} eq 'HASH'));
my $alias = $self->{attrs}{alias};
+ my $collapsed_cond = $self->{cond} ? $self->_collapse_cond($self->{cond}) : {};
my %new = (
%{ $self->_remove_alias($values, $alias) },
- %{ $self->_remove_alias($self->{cond}, $alias) },
+ %{ $self->_remove_alias($collapsed_cond, $alias) },
);
my $obj = $self->result_class->new(\%new);
return $obj;
}
+# _collapse_cond
+#
+# Recursively collapse the condition.
+
+sub _collapse_cond {
+ my ($self, $cond, $collapsed) = @_;
+
+ $collapsed ||= {};
+
+ if (ref $cond eq 'ARRAY') {
+ foreach my $subcond (@$cond) {
+ next unless ref $subcond; # -or
+# warn "ARRAY: " . Dumper $subcond;
+ $collapsed = $self->_collapse_cond($subcond, $collapsed);
+ }
+ }
+ elsif (ref $cond eq 'HASH') {
+ if (keys %$cond and (keys %$cond)[0] eq '-and') {
+ foreach my $subcond (@{$cond->{-and}}) {
+# warn "HASH: " . Dumper $subcond;
+ $collapsed = $self->_collapse_cond($subcond, $collapsed);
+ }
+ }
+ else {
+# warn "LEAF: " . Dumper $cond;
+ foreach my $col (keys %$cond) {
+ my $value = $cond->{$col};
+ $collapsed->{$col} = $value;
+ }
+ }
+ }
+
+ return $collapsed;
+}
+
# _remove_alias
#
# Remove the specified alias from the specified query hash. A copy is made so
}
foreach (@cols) {
- undef $columns->{$_};
+ delete $columns->{$_};
};
$self->_ordered_columns(\@remaining);
$obj->insert;
-Inserts an object into the database if it isn't already in there. Returns
-the object itself. Requires the object's result source to be set, or the
-class to have a result_source_instance method.
+Inserts an object into the database if it isn't already in
+there. Returns the object itself. Requires the object's result source to
+be set, or the class to have a result_source_instance method. To insert
+an entirely new object into the database, use C<create> (see
+L<DBIx::Class::ResultSet/create>).
=cut
$obj->delete
-Deletes the object from the database. The object is still perfectly usable,
-but ->in_storage() will now return 0 and the object must re inserted using
-->insert() before ->update() can be used on it.
+Deletes the object from the database. The object is still perfectly
+usable, but C<-E<gt>in_storage()> will now return 0 and the object must
+reinserted using C<-E<gt>insert()> before C<-E(<gt>update()> can be used
+on it. If you delete an object in a class with a C<has_many>
+relationship, all the related objects will be deleted as well. To turn
+this behavior off, pass C<cascade_delete => 0> in the C<$attr>
+hashref. Any database-level cascade or restrict will take precedence
+over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
=cut
=over 4
-=item Arguments: $sqlt_args
+=item Arguments: $sqlt_args, $dir
=back
=cut
sub deploy {
- my ($self, $sqltargs) = @_;
+ my ($self, $sqltargs, $dir) = @_;
$self->throw_exception("Can't deploy without storage") unless $self->storage;
- $self->storage->deploy($self, undef, $sqltargs);
+ $self->storage->deploy($self, undef, $sqltargs, $dir);
}
=head2 create_ddl_dir (EXPERIMENTAL)
=cut
-sub create_ddl_dir
-{
+sub create_ddl_dir {
my $self = shift;
$self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
=cut
-sub ddl_filename
-{
+sub ddl_filename {
my ($self, $type, $dir, $version) = @_;
my $filename = ref($self);
You may distribute this code under the same terms as Perl itself.
=cut
-
$self;
}
+sub _RowNumberOver {
+ my ($self, $sql, $order, $rows, $offset ) = @_;
+
+ $offset += 1;
+ my $last = $rows + $offset;
+ my ( $order_by ) = $self->_order_by( $order );
+
+ $sql = <<"";
+SELECT * FROM
+(
+ SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
+ $sql
+ $order_by
+ ) Q1
+) Q2
+WHERE ROW_NUM BETWEEN $offset AND $last
+
+ return $sql;
+}
+
+
# While we're at it, this should make LIMIT queries more efficient,
# without digging into things too deeply
sub _find_syntax {
my ($self, $syntax) = @_;
+ my $dbhname = eval { $syntax->{Driver}->{Name}} || '';
+ if(ref($self) && $dbhname && $dbhname eq 'DB2') {
+ return 'RowNumberOver';
+ }
+
$self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
}
}
sub deploy {
- my ($self, $schema, $type, $sqltargs) = @_;
- foreach my $statement ( $self->deployment_statements($schema, $type, undef, undef, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
+ my ($self, $schema, $type, $sqltargs, $dir) = @_;
+ foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
for ( split(";\n", $statement)) {
next if($_ =~ /^--/);
next if(!$_);
sub DESTROY {
my $self = shift;
return if !$self->_dbh;
-
$self->_verify_pid;
$self->_dbh(undef);
}
use base 'DBIx::Class::Storage::DBI';
+=head1 NAME
+
+DBIx::Class::Storage::DBI::NoBindVars - Sometime DBDs have poor to no support for bind variables
+
+=head1 DESCRIPTION
+
+This class allows queries to work when the DBD or underlying library does not
+support the usual C<?> placeholders, or at least doesn't support them very
+well, as is the case with L<DBD::Sybase>
+
+=head1 METHODS
+
+=head2 sth
+
+Uses C<prepare> instead of the usual C<prepare_cached>, seeing as we can't cache very effectively without bind variables.
+
+=cut
+
+sub sth {
+ my ($self, $sql) = @_;
+ return $self->dbh->prepare($sql);
+}
+
+=head2 _execute
+
+Manually subs in the values for the usual C<?> placeholders before calling L</sth> on the generated SQL.
+
+=cut
+
sub _execute {
my ($self, $op, $extra_bind, $ident, @args) = @_;
my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
return (wantarray ? ($rv, $sth, @bind) : $rv);
}
-1;
-
-=head1 NAME
-
-DBIx::Class::Storage::DBI::NoBindVars - Sometime DBDs have poor to no support for bind variables
-
-=head1 SYNOPSIS
-
-=head1 DESCRIPTION
-
-This class allows queries to work when the DBD or underlying library does not
-support the usual C<?> placeholders, or at least doesn't support them very
-well, as is the case with L<DBD::Sybase>
-
=head1 AUTHORS
Brandon Black <blblack@gmail.com>
+
Trym Skaar <trym@tryms.no>
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
=cut
+
+1;
--- /dev/null
+#!/usr/bin/perl -w
+
+# Originally by: Zbigniew Lukasiak, C<zz bb yy@gmail.com>
+# but refactored and modified to our nefarious purposes
+
+# XXX I'm not done refactoring this yet --blblack
+
+use strict;
+use warnings;
+
+use Pod::Coverage;
+use Data::Dumper;
+use File::Find::Rule;
+use File::Slurp;
+use Path::Class;
+use Template;
+
+# Convert filename to package name
+sub getpac {
+ my $file = shift;
+ my $filecont = read_file( $file );
+ $filecont =~ /package\s*(.*?);/s or return;
+ my $pac = $1;
+ $pac =~ /\s+(.*)$/;
+ return $1;
+}
+
+my @files = File::Find::Rule->file()->name('*.pm', '*.pod')->in('lib');
+
+my %docsyms;
+for my $file (@files){
+ my $package = getpac( $file ) or next;
+ my $pc = Pod::Coverage->new(package => $package);
+ my %allsyms = map {$_ => 1} $pc->_get_syms($package);
+ my $podarr = $pc->_get_pods();
+ next if !$podarr;
+ for my $sym (@{$podarr}){
+ $docsyms{$sym}{$package} = $file if $allsyms{$sym};
+ }
+}
+
+my @lines;
+for my $sym (sort keys %docsyms){
+ for my $pac (sort keys %{$docsyms{$sym}}){
+ push @lines, {symbol => $sym, package => $pac};
+ }
+}
+
+my $tt = Template->new({})
+|| die Template->error(), "\n";
+
+$tt->process(\*DATA, { lines => \@lines })
+|| die $tt->error(), "\n";
+
+
+__DATA__
+
+=head1 NAME
+
+Method Index
+
+[% FOR line = lines %]
+L<[% line.symbol %] ([% line.package %])|[% line.package %]/[% line.symbol %]>
+[% END %]
--- /dev/null
+use strict;\r
+use warnings;\r
+\r
+use Test::More;\r
+use Data::Dumper;\r
+use lib qw(t/lib);\r
+use DBICTest;\r
+my $schema = DBICTest->init_schema();\r
+\r
+plan tests => 14;\r
+\r
+# select from a class with resultset_attributes\r
+my $resultset = $schema->resultset('BooksInLibrary');\r
+is($resultset, 3, "select from a class with resultset_attributes okay");\r
+\r
+# now test out selects through a resultset\r
+my $owner = $schema->resultset('Owners')->find({name => "Newton"});\r
+my $programming_perl = $owner->books->find_or_create({ title => "Programming Perl" });\r
+is($programming_perl->id, 1, 'select from a resultset with find_or_create for existing entry ok');\r
+\r
+# and inserts?\r
+my $see_spot;\r
+$see_spot = eval { $owner->books->find_or_create({ title => "See Spot Run" }) };\r
+if ($@) { print $@ }\r
+ok(!$@, 'find_or_create on resultset with attribute for non-existent entry did not throw');\r
+ok(defined $see_spot, 'successfully did insert on resultset with attribute for non-existent entry');\r
+\r
+# many_to_many tests\r
+my $collection = $schema->resultset('Collection')->search({collectionid => 1});\r
+my $pointy_objects = $collection->search_related('collection_object')->search_related('object', { type => "pointy"});\r
+my $pointy_count = $pointy_objects->count();\r
+is($pointy_count, 2, 'many_to_many explicit query through linking table with query starting from resultset count correct');\r
+\r
+$collection = $schema->resultset('Collection')->find(1);\r
+$pointy_objects = $collection->search_related('collection_object')->search_related('object', { type => "pointy"});\r
+$pointy_count = $pointy_objects->count();\r
+is($pointy_count, 2, 'many_to_many explicit query through linking table with query starting from row count correct');\r
+\r
+# use where on many_to_many query\r
+$collection = $schema->resultset('Collection')->find(1);\r
+$pointy_objects = $collection->search_related('collection_object')->search_related('object', {}, { where => { 'object.type' => 'pointy' } });\r
+is($pointy_objects->count(), 2, 'many_to_many explicit query through linking table with where starting from row count correct');\r
+\r
+$collection = $schema->resultset('Collection')->find(1);\r
+$pointy_objects = $collection->pointy_objects();\r
+$pointy_count = $pointy_objects->count();\r
+is($pointy_count, 2, 'many_to_many resultset with where in resultset attrs count correct');\r
+\r
+# add_to_$rel on many_to_many with where containing a required field\r
+eval {$collection->add_to_pointy_objects({ value => "Nail" }) };\r
+if ($@) { print $@ }\r
+ok( !$@, 'many_to_many add_to_$rel($hash) with where in relationship attrs did not throw');\r
+is($pointy_objects->count, $pointy_count+1, 'many_to_many add_to_$rel($hash) with where in relationship attrs count correct');\r
+$pointy_count = $pointy_objects->count();\r
+\r
+my $pen = $schema->resultset('TypedObject')->create({ value => "Pen", type => "pointy"});\r
+eval {$collection->add_to_pointy_objects($pen)};\r
+if ($@) { print $@ }\r
+ok( !$@, 'many_to_many add_to_$rel($object) with where in relationship attrs did not throw');\r
+is($pointy_objects->count, $pointy_count+1, 'many_to_many add_to_$rel($object) with where in relationship attrs count correct');\r
+$pointy_count = $pointy_objects->count();\r
+\r
+my $round_objects = $collection->round_objects();\r
+my $round_count = $round_objects->count();\r
+eval {$collection->add_to_objects({ value => "Wheel", type => "round" })};\r
+if ($@) { print $@ }\r
+ok( !$@, 'many_to_many add_to_$rel($hash) did not throw');\r
+is($round_objects->count, $round_count+1, 'many_to_many add_to_$rel($hash) count correct');\r
my $schema = DBICTest->init_schema();
-plan tests => 62;
+plan tests => 63;
# 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_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/]);
+ ok(! exists $schema->source('CD')->_columns->{'year'}, 'year still exists in _columns');
}
use Test::More;
use lib qw(t/lib);
use DBICTest;
+use Data::Dumper;
my $schema = DBICTest->init_schema();
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 47 );
+ : ( tests => 49 );
}
# figure out if we've got a version of sqlite that is older than 3.2.6, in
is($rs->first->name, 'We Are Goth', 'Correct record returned');
-$rs = $schema->resultset("CD")->search(
- { 'artist.name' => 'Caterwauler McCrae' },
- { prefetch => [ qw/artist liner_notes/ ],
- order_by => 'me.cdid' });
+# bug in 0.07000 caused attr (join/prefetch) to be modifed by search
+# so we check the search & attr arrays are not modified
+my $search = { 'artist.name' => 'Caterwauler McCrae' };
+my $attr = { prefetch => [ qw/artist liner_notes/ ],
+ order_by => 'me.cdid' };
+my $search_str = Dumper($search);
+my $attr_str = Dumper($attr);
+
+$rs = $schema->resultset("CD")->search($search, $attr);
+is(Dumper($search), $search_str, 'Search hash untouched after search()');
+is(Dumper($attr), $attr_str, 'Attribute hash untouched after search()');
cmp_ok($rs + 0, '==', 3, 'Correct number of records returned');
my $queries = 0;
my $sql;
{ local $/ = undef; $sql = <IN>; }
close IN;
- $schema->storage->dbh->do($_) for split(/;\n/, $sql);
+ ($schema->storage->dbh->do($_) || print "Error on SQL: $_\n") for split(/;\n/, $sql);
}
}
[ qw/id link/ ],
[ 1, 1 ]
]);
+
+ $schema->populate('Collection', [
+ [ qw/collectionid name/ ],
+ [ 1, "Tools" ],
+ [ 2, "Body Parts" ],
+ ]);
+
+ $schema->populate('CollectionObject', [
+ [ qw/collection object/ ],
+ [ 1, 1 ],
+ [ 1, 2 ],
+ [ 1, 3 ],
+ [ 2, 4 ],
+ [ 2, 5 ],
+ ]);
+
+ $schema->populate('TypedObject', [
+ [ qw/objectid type value/ ],
+ [ 1, "pointy", "Awl" ],
+ [ 2, "round", "Bearing" ],
+ [ 3, "pointy", "Knife" ],
+ [ 4, "pointy", "Tooth" ],
+ [ 5, "round", "Head" ],
+ ]);
+
+ $schema->populate('Owners', [
+ [ qw/ownerid name/ ],
+ [ 1, "Newton" ],
+ [ 2, "Waltham" ],
+ ]);
+
+ $schema->populate('BooksInLibrary', [
+ [ qw/id owner title source/ ],
+ [ 1, 1, "Programming Perl", "Library" ],
+ [ 2, 1, "Dynamical Systems", "Library" ],
+ [ 3, 2, "Best Recipe Cookbook", "Library" ],
+ ]);
}
1;
'Producer',
'CD_to_Producer',
),
- qw/SelfRefAlias TreeLike TwoKeyTreeLike Event NoPrimaryKey/
+ qw/SelfRefAlias TreeLike TwoKeyTreeLike Event NoPrimaryKey/,
+ qw/Collection CollectionObject TypedObject/,
+ qw/Owners BooksInLibrary/
);
1;
--- /dev/null
+package # hide from PAUSE \r
+ DBICTest::Schema::BooksInLibrary;\r
+\r
+use base qw/DBIx::Class::Core/;\r
+\r
+__PACKAGE__->table('books');\r
+__PACKAGE__->add_columns(\r
+ 'id' => {\r
+ data_type => 'integer',\r
+ is_auto_increment => 1,\r
+ },\r
+ 'source' => {\r
+ data_type => 'varchar',\r
+ size => '100',\r
+ },\r
+ 'owner' => {\r
+ data_type => 'integer',\r
+ },\r
+ 'title' => {\r
+ data_type => 'varchar',\r
+ size => '100',\r
+ },\r
+);\r
+__PACKAGE__->set_primary_key('id');\r
+\r
+__PACKAGE__->resultset_attributes({where => { source => "Library" } });\r
+\r
+1;\r
--- /dev/null
+package # hide from PAUSE \r
+ DBICTest::Schema::Collection;\r
+\r
+use base qw/DBIx::Class::Core/;\r
+\r
+__PACKAGE__->table('collection');\r
+__PACKAGE__->add_columns(\r
+ 'collectionid' => {\r
+ data_type => 'integer',\r
+ is_auto_increment => 1,\r
+ },\r
+ 'name' => {\r
+ data_type => 'varchar',\r
+ size => 100,\r
+ },\r
+);\r
+__PACKAGE__->set_primary_key('collectionid');\r
+\r
+__PACKAGE__->has_many( collection_object => "DBICTest::Schema::CollectionObject",\r
+ { "foreign.collection" => "self.collectionid" }\r
+ );\r
+__PACKAGE__->many_to_many( objects => collection_object => "object" );\r
+__PACKAGE__->many_to_many( pointy_objects => collection_object => "object",\r
+ { where => { "object.type" => "pointy" } }\r
+ );\r
+__PACKAGE__->many_to_many( round_objects => collection_object => "object",\r
+ { where => { "object.type" => "round" } } \r
+ );\r
+\r
+1;\r
--- /dev/null
+package # hide from PAUSE \r
+ DBICTest::Schema::CollectionObject;\r
+\r
+use base qw/DBIx::Class::Core/;\r
+\r
+__PACKAGE__->table('collection_object');\r
+__PACKAGE__->add_columns(\r
+ 'collection' => {\r
+ data_type => 'integer',\r
+ },\r
+ 'object' => {\r
+ data_type => 'integer',\r
+ },\r
+);\r
+__PACKAGE__->set_primary_key(qw/collection object/);\r
+\r
+__PACKAGE__->belongs_to( collection => "DBICTest::Schema::Collection",\r
+ { "foreign.collectionid" => "self.collection" }\r
+ );\r
+__PACKAGE__->belongs_to( object => "DBICTest::Schema::TypedObject",\r
+ { "foreign.objectid" => "self.object" }\r
+ );\r
+\r
+1;\r
--- /dev/null
+package # hide from PAUSE \r
+ DBICTest::Schema::Owners;\r
+\r
+use base qw/DBIx::Class::Core/;\r
+\r
+__PACKAGE__->table('owners');\r
+__PACKAGE__->add_columns(\r
+ 'ownerid' => {\r
+ data_type => 'integer',\r
+ is_auto_increment => 1,\r
+ },\r
+ 'name' => {\r
+ data_type => 'varchar',\r
+ size => '100',\r
+ },\r
+);\r
+__PACKAGE__->set_primary_key('ownerid');\r
+\r
+__PACKAGE__->has_many(books => "DBICTest::Schema::BooksInLibrary", "owner");\r
+\r
+1;\r
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::TypedObject;
+
+use base qw/DBIx::Class::Core/;
+
+__PACKAGE__->table('typed_object');
+__PACKAGE__->add_columns(
+ 'objectid' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'type' => {
+ data_type => 'varchar',
+ size => '100',
+ },
+ 'value' => {
+ data_type => 'varchar',
+ size => 100,
+ },
+);
+__PACKAGE__->set_primary_key('objectid');
+
+__PACKAGE__->has_many( collection_object => "DBICTest::Schema::CollectionObject",
+ { "foreign.object" => "self.objectid" }
+ );
+__PACKAGE__->many_to_many( collections => collection_object => "collection" );
+
+1;
cd integer NOT NULL
);
+--
+-- Table: typed_object
+--
+CREATE TABLE typed_object (
+ objectid INTEGER PRIMARY KEY NOT NULL,
+ type VARCHAR(100) NOT NULL,
+ value VARCHAR(100)
+);
+
+--
+-- Table: collection
+--
+CREATE TABLE collection (
+ collectionid INTEGER PRIMARY KEY NOT NULL,
+ name VARCHAR(100)
+);
+
+--
+-- Table: collection_object
+--
+CREATE TABLE collection_object (
+ collection INTEGER NOT NULL,
+ object INTEGER NOT NULL
+);
+
+--
+-- Table: owners
+--
+CREATE TABLE owners (
+ ownerid INTEGER PRIMARY KEY NOT NULL,
+ name varchar(100)
+);
+
+--
+-- Table: books
+--
+CREATE TABLE books (
+ id INTEGER PRIMARY KEY NOT NULL,
+ owner INTEGER,
+ source varchar(100),
+ title varchar(100)
+);
+
+
CREATE UNIQUE INDEX tktlnameunique_twokeytreelike on twokeytreelike (name);
CREATE UNIQUE INDEX cd_artist_title_cd on cd (artist, title);
CREATE UNIQUE INDEX track_cd_position_track on track (cd, position);
projects / dbsrgits/DBIx-Class.git / commitdiff