Build
Build.bat
MANIFEST
+MANIFEST.bak
META.yml
Makefile
Makefile.old
Revision history for DBIx::Class
+
+0.08102 2009-04-30 08:29:00 (UTC)
+ - Fixed two subtle bugs when using columns or select/as
+ paired with a join (limited prefetch)
+ - Fixed breakage of cdbi tests (RT#45551)
+ - Some POD improvements
+
+0.08101 2009-04-27 09:45:00 (UTC)
+ - Fix +select, +as, +columns and include_columns being stripped
+ by $rs->get_column
+ - move load_optional_class from DBIx::Class::Componentised to
+ Class::C3::Componentised, bump dependency
+ - register_extra_source() now *really* fixed wrt subclassing
+ - Added missing POD descriptions (RT#45195)
+ - Fix insert() to not store_column() every present object column
+ - Multiple Makefile.PL fixes
+
+0.08100 2009-04-19 11:39:35 (UTC)
+ - Todo out the register_extra_source test until after shipping
+
+0.08099_08 2009-03-30 00:00:00 (UTC)
+ - Fixed taint mode with load_namespaces
+ - Putting IC::DateTime locale, timezone or floating_tz_ok attributes into
+ extra => {} has been deprecated. The new way is to put these things
+ directly into the columns definition
+ - Switched MI code to MRO::Compat
+ - Document db-side default_value caveats
+ - Search_like() now warns to indicate deprecation in 0.09.
+ - TxnScopeGuard left experimental state
+
+0.08099_07 2009-02-27 02:00:00 (UTC)
- multi-create using find_or_create rather than _related for post-insert
- fix get_inflated_columns to check has_column_loaded
- Add DBIC_MULTICREATE_DEBUG env var (undocumented, quasi-internal)
- not try and insert things tagged on via new_related unless required
- Possible to set locale in IC::DateTime extra => {} config
- Calling the accessor of a belongs_to when the foreign_key
- was NULL and the row was not stored would unexpectedly fail (groditi)
+ was NULL and the row was not stored would unexpectedly fail
- Split sql statements for deploy only if SQLT::Producer returned a scalar
containing all statements to be executed
- Add as_query() for ResultSet and ResultSetColumn. This makes subqueries
- possible. See the Cookbook for details. (robkinyon, michaelr)
+ possible. See the Cookbook for details.
- Massive rewrite of Ordered to properly handle position constraints and
to make it more matpath-friendly
+ - deploy_statements called ddl_filename with the $version and $dir arguments
+ in the wrong order.
+ - columns/+columns attributes now support { as => select } hahsrefs
+ - support for views both in DBIC and via deploy() in SQLT
0.08099_06 2009-01-23 07:30:00 (UTC)
- Allow a scalarref to be supplied to the 'from' resultset attribute
(http://msdn.microsoft.com/en-us/library/ms190315.aspx)
- an sqlt_deploy_hook can now be shared between result sources using
a configurable callback trigger
- - new order_by => { -desc => 'colname' } syntax supported with
- SQLA >= 1.50
- - PG array datatype supported with SQLA >= 1.50
+ - new order_by => { -desc => 'colname' } syntax supported
+ - PG array datatype supported
- insert should use store_column, not set_column to avoid marking
- clean just-stored values as dirty. New test for this (groditi)
- - regression test for source_name (groditi)
+ clean just-stored values as dirty. New test for this
+ - regression test for source_name
0.08099_05 2008-10-30 21:30:00 (UTC)
- - Rewritte of Storage::DBI::connect_info(), extended with an
+ - Rewrite of Storage::DBI::connect_info(), extended with an
additional argument format type
- InflateColumn::DateTime: add warning about floating timezone
- InflateColumn::DateTime: possible to enforce/skip inflation
- - delete throws exception if passed arguments to prevent drunken mishaps. (purge)
+ - delete throws exception if passed arguments to prevent drunken mishaps.
- Fix storage to copy scalar conds before regexping to avoid
trying to modify a constant in odd edge cases
- Related resultsets on uninserted objects are now empty
(Potential) Features for 0.09
=============================
-Subselects - everyone wants these
- - Will require new/improved SQL::Abstract
- - The API will involve passing ResultSets to searches as conditions/values/whatever.
-
Row/find caching - would be pretty useful
- Need to have good definitions of when the cache should be queried and when invalidated
- Be able to supply own expiry?
- Be able to invalidate manually? Single item / entire cache / single table
-Deprecate compose_connection / DB.pm
+Remove compose_connection / DB.pm
- Everyone has probably forgotten what this is anyway..
Syntax improvements?
- "as" to "alias" ?
- "belongs_to" to "contains/refers/something"
- - order_by to take a arrayref/hashref so it also just works with quoting
- - ??
Using inflated objects/references as values in searches
- Goes together with subselects above
Relationships
- single vs filter, discrepancies.. remove one of them and make behave the same?
-SQL::Abstract et al
- - be able to extract/view/dump what the SQL is *going to* be before running it
- - bind params sanity? (order of bind params broken when using a resultsource based on a select statement)
- - etc
-
Joining/searching weird attribute tables?
- Support legacy/badly designed junk better..
Documentation - improvements
- better indexing for finding of stuff in general
- more cross-referencing of docs
-
+
+^(?!script/|examples/|lib/|inc/|t/|Makefile.PL$|README$|MANIFEST$|Changes$|META.yml$)
+
+
# Avoid version control files.
\bRCS\b
\bCVS\b
-use inc::Module::Install 0.67;
+use inc::Module::Install 0.79;
use strict;
use warnings;
use POSIX ();
perl_version '5.006001';
all_from 'lib/DBIx/Class.pm';
+# configure_requires so _check_sqlite() below can run
+# remove once test deprecated
+configure_requires 'DBD::SQLite';
+
+requires 'DBD::SQLite' => 1.23;
requires 'Data::Page' => 2.00;
requires 'Scalar::Util' => 0;
-requires 'SQL::Abstract' => 1.49;
+requires 'SQL::Abstract' => 1.53;
requires 'SQL::Abstract::Limit' => 0.13;
-requires 'Class::C3' => 0.20;
-requires 'Class::C3::Componentised' => 0;
+requires 'Class::C3::Componentised' => 1.0005;
requires 'Storable' => 0;
requires 'Carp::Clan' => 0;
requires 'DBI' => 1.40;
requires 'Module::Find' => 0;
requires 'Class::Inspector' => 0;
-requires 'Class::Accessor::Grouped' => 0.08002;
+requires 'Class::Accessor::Grouped' => 0.08003;
requires 'JSON::Any' => 1.17;
requires 'Scope::Guard' => 0.03;
requires 'Path::Class' => 0;
requires 'List::Util' => 1.19;
requires 'Sub::Name' => 0.04;
-requires 'namespace::clean' => 0.09;
+requires 'MRO::Compat' => 0.09;
# Perl 5.8.0 doesn't have utf8::is_utf8()
requires 'Encode' => 0 if ($] <= 5.008000);
-configure_requires 'DBD::SQLite' => 1.14;
-
test_requires 'Test::Builder' => 0.33;
test_requires 'Test::Warn' => 0.11;
test_requires 'Test::Exception' => 0;
recommends 'SQL::Translator' => 0.09004;
-install_script 'script/dbicadmin';
+install_script (qw|
+ script/dbicadmin
+|);
-tests_recursive 't';
+tests_recursive (qw|
+ t
+|);
-# re-build README and require CDBI modules for testing if we're in a checkout
+# re-build README and require extra modules for testing if we're in a checkout
my %force_requires_if_author = (
+ 'Test::Pod::Coverage' => 1.04,
+ 'SQL::Translator' => 0.09004,
+
+ # CDBI-compat related
'DBIx::ContextualFetch' => 0,
+ 'Class::DBI::Plugin::DeepAbstractSearch' => 0,
'Class::Trigger' => 0,
- 'Time::Piece' => 0,
+ 'Time::Piece::MySQL' => 0,
'Clone' => 0,
- 'Test::Pod::Coverage' => 0,
+ 'Date::Simple' => 0,
+
+ # t/52cycle.t
'Test::Memory::Cycle' => 0,
- 'SQL::Translator' => 0.09004,
+
+ # t/60core.t
+ 'DateTime::Format::MySQL' => 0,
+
+ # t/72pg.t
+ $ENV{DBICTEST_PG_DSN}
+ ? ('Sys::SigAction'=> 0)
+ : ()
+ ,
+
+ # t/93storage_replication.t
+ 'Moose', => 0.54,
+ 'Moose::Util::TypeConstraints' => 0.54,
+ 'MooseX::AttributeHelpers' => 0.12,
+ 'Class::MOP' => 0.63,
+
+ # t/96_is_deteministic_value.t
+ 'DateTime::Format::Strptime' => 0,
);
if ($Module::Install::AUTHOR) {
foreach my $module (keys %force_requires_if_author) {
- requires ($module => $force_requires_if_author{$module});
+ build_requires ($module => $force_requires_if_author{$module});
}
system('pod2text lib/DBIx/Class.pm > README');
auto_provides;
+if ($Module::Install::AUTHOR) {
+ warn <<'EOW';
+******************************************************************************
+******************************************************************************
+*** ***
+*** AUTHOR MODE: all optional test dependencies converted to hard requires ***
+*** ***
+******************************************************************************
+******************************************************************************
+
+EOW
+}
auto_install;
# Have all prerequisites, check DBD::SQLite sanity
-if (! $ENV{DBICTEST_NO_SQLITE_CHECK} ) {
+_check_sqlite() if (! $ENV{DBICTEST_NO_SQLITE_CHECK} );
- my $pid = fork();
- if (not defined $pid) {
- die "Unable to fork(): $!";
- }
- elsif (! $pid) {
+WriteAll();
- # Win32 does not have real fork()s so a segfault will bring
- # everything down. Warn about it.
- if ($^O eq 'MSWin32') {
- print <<'EOW';
+if ($Module::Install::AUTHOR) {
+ # Need to do this _after_ WriteAll else it loses track of them
+ Meta->{values}{build_requires} = [ grep {
+ my $ok = 1;
+ foreach my $module (keys %force_requires_if_author) {
+ if ($_->[0] =~ /$module/) {
+ $ok = 0;
+ last;
+ }
+ }
+ $ok;
+ } @{Meta->{values}{build_requires}} ];
-######################################################################
-# #
-# A short stress-testing of DBD::SQLite will follow. If you have a #
-# buggy library this might very well be the last text you will see #
-# before the installation silently terminates. If this happens it #
-# would mean that you are running a buggy version of DBD::SQLite #
-# known to randomly segfault on errors. Even if you have the latest #
-# CPAN module version, the system sqlite3 dynamic library might have #
-# been compiled against an older buggy sqlite3 dev library (oddly #
-# DBD::SQLite will prefer the system library against the one bundled #
-# with it). You are strongly advised to resolve this issue before #
-# proceeding. #
-# #
-# If this happens to you (this text is the last thing you see), and #
-# you just want to install this module without worrying about the #
-# tests (which will almost certainly fail) - set the environment #
-# variable DBICTEST_NO_SQLITE_CHECK to a true value and try again. #
-# #
-######################################################################
+ Meta->{values}{resources} = [
+ [ 'MailingList', 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class' ],
+ [ 'IRC', 'irc://irc.perl.org/#dbix-class' ],
+ [ 'license', 'http://dev.perl.org/licenses/' ],
+ [ 'repository', 'http://dev.catalyst.perl.org/svnweb/bast/browse/DBIx-Class/' ],
+ ];
+ Meta->write;
+}
-EOW
- }
- require DBI;
- for (1 .. 100) {
- my $dbh;
- $dbh = DBI->connect ('dbi:SQLite::memory:', undef, undef, {
- AutoCommit => 1,
- RaiseError => 0,
- PrintError => 0,
- })
- or die "Unable to connect to database: $@";
- $dbh->do ('CREATE TABLE name_with_no_columns'); # a subtle syntax error
- $dbh->do ('COMMIT'); # followed by commit
- $dbh->disconnect;
- }
+# This is legacy code. Latest DBD::SQLite developments fixed all known bugs
+# in this area. Remove before some arbitrary next version
+sub _check_sqlite {
+ # Win32 does not have real fork()s so a segfault will bring
+ # everything down. Warn about it below, and don't try fork()
+ if ($^O ne 'MSWin32') {
+
+ my $pid = fork();
+ if (not defined $pid) {
+ die "Unable to fork(): $!";
+ }
+ elsif (! $pid) {
+ _torture_sqlite();
exit 0;
- }
- else {
+ }
+ else {
eval {
local $SIG{ALRM} = sub { die "timeout\n" };
alarm 5;
my $sig = $? & 127;
-# make sure process actually dies
+ # make sure process actually dies
$exception && kill POSIX::SIGKILL(), $pid;
if ($exception || $sig == POSIX::SIGSEGV() || $sig == POSIX::SIGABRT()
);
exit 0 unless ($ans =~ /^y(es)?$/i);
}
+ }
}
-}
+ else { # the win32 version
-WriteAll();
+ print <<'EOW';
+######################################################################
+# #
+# A short stress-testing of DBD::SQLite will follow. If you have a #
+# buggy library this might very well be the last text you will see #
+# before the installation silently terminates. If this happens it #
+# would mean that you are running a buggy version of DBD::SQLite #
+# known to randomly segfault on errors. Even if you have the latest #
+# CPAN module version, the system sqlite3 dynamic library might have #
+# been compiled against an older buggy sqlite3 dev library (oddly #
+# DBD::SQLite will prefer the system library against the one bundled #
+# with it). You are strongly advised to resolve this issue before #
+# proceeding. #
+# #
+# If this happens to you (this text is the last thing you see), and #
+# you just want to install this module without worrying about the #
+# tests (which will almost certainly fail) - set the environment #
+# variable DBICTEST_NO_SQLITE_CHECK to a true value and try again. #
+# #
+######################################################################
+EOW
-if ($Module::Install::AUTHOR) {
- # Need to do this _after_ WriteAll else it looses track of them
- Meta->{values}{build_requires} = [ grep {
- my $ok = 1;
- foreach my $module (keys %force_requires_if_author) {
- if ($_->[0] =~ /$module/) {
- $ok = 0;
- last;
- }
- }
- $ok;
- } @{Meta->{values}{build_requires}} ];
+ _torture_sqlite();
+ }
+}
- my @scalar_keys = Module::Install::Metadata::Meta_TupleKeys();
- my $cr = Module::Install::Metadata->can("Meta_TupleKeys");
- {
- no warnings 'redefine';
- *Module::Install::Metadata::Meta_TupleKeys = sub {
- return $cr->(@_), 'resources';
- };
+sub _torture_sqlite {
+ require DBI;
+
+ for (1 .. 100) {
+ my $dbh = DBI->connect ('dbi:SQLite::memory:', undef, undef, {
+ AutoCommit => 1,
+ RaiseError => 0,
+ PrintError => 0,
+ }) or die "Unable to connect to database: $@";
+
+ $dbh->do ('CREATE TABLE name_with_no_columns'); # a subtle syntax error
+ $dbh->do ('COMMIT'); # followed by commit
+ $dbh->disconnect;
}
- Meta->{values}{resources} = [
- [ 'MailingList', 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class' ],
- [ 'IRC', 'irc://irc.perl.org/#dbix-class' ],
- [ 'license', 'http://dev.perl.org/licenses/' ],
- [ 'repository', 'http://dev.catalyst.perl.org/svnweb/bast/browse/DBIx-Class/' ],
- ];
- Meta->write;
}
# i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
# brain damage and presumably various other packaging systems too
-$VERSION = '0.08099_06';
+$VERSION = '0.08102';
$VERSION = eval $VERSION; # numify for warning-free dev releases
ank: Andres Kievsky
+arcanez: Justin Hunter <justin.d.hunter@gmail.com>
+
ash: Ash Berlin <ash@cpan.org>
bert: Norbert Csongradi <bert@cpan.org>
caelum: Rafael Kitover <rkitover@cpan.org>
-captainL: Luke Saunders <luke.saunders@gmail.com>
-
castaway: Jess Robinson
claco: Christopher H. Laco
groditi: Guillermo Roditi <groditi@cpan.org>
+ilmari: Dagfinn Ilmari MannsE<aring>ker <ilmari@ilmari.org>
+
+jasonmay: Jason May <jason.a.may@gmail.com>
+
jesper: Jesper Krogh
jgoulah: John Goulah <jgoulah@cpan.org>
konobi: Scott McWhirter
+lukes: Luke Saunders <luke.saunders@gmail.com>
+
marcus: Marcus Ramberg <mramberg@cpan.org>
mattlaw: Matt Lawrence
+michaelr: Michael Reddick <michael.reddick@gmail.com>
+
ned: Neil de Carteret
nigel: Nigel Metheringham <nigelm@cpan.org>
ningu: David Kamholz <dkamholz@cpan.org>
+norbi: Norbert Buchmuller <norbi@nix.hu>
+
Numa: Dan Sully <daniel@cpan.org>
oyse: Øystein Torget <oystein.torget@dnv.com>
perigrin: Chris Prather <chris@prather.org>
+peter: Peter Collingbourne <peter@pcc.me.uk>
+
phaylon: Robert Sedlacek <phaylon@dunkelheit.at>
plu: Johannes Plunien <plu@cpan.org>
semifor: Marc Mims <marc@questright.com>
+solomon: Jared Johnson <jaredj@nmgi.com>
+
sszabo: Stephan Szabo <sszabo@bigpanda.com>
teejay : Aaron Trevena <teejay@cpan.org>
willert: Sebastian Willert <willert@cpan.org>
-zamolxes: Bogdan Lucaciu <bogdan@wiz.ro>
+wreis: Wallace Reis <wreis@cpan.org>
-norbi: Norbert Buchmuller <norbi@nix.hu>
+zamolxes: Bogdan Lucaciu <bogdan@wiz.ro>
=head1 LICENSE
=head1 NAME
-DBIx::Class::CDBICompat::AbstractSearch
+DBIx::Class::CDBICompat::AbstractSearch - Emulates Class::DBI::AbstractSearch
=head1 SYNOPSIS
return map { $class->find_column($_) } @col;
}
-package DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
+package # hide from PAUSE (should be harmless, no POD no Version)
+ DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
sub groups_for {
my ($self, @cols) = @_;
}
return keys %groups;
}
-
1;
=head1 NAME
-DBIx::Class::CDBICompat::ColumnsAsHash
+DBIx::Class::CDBICompat::ColumnsAsHash - Emulates the behavior of Class::DBI where the object can be accessed as a hash of columns.
=head1 SYNOPSIS
=head1 NAME
-DBIx::Class::CDBICompat::Copy
+DBIx::Class::CDBICompat::Copy - Emulates Class::DBI->copy($new_id)
=head1 SYNOPSIS
=head1 NAME
-DBIx::Class::CDBICompat::Iterator
+DBIx::Class::CDBICompat::Iterator - Emulates the extra behaviors of the Class::DBI search iterator.
=head1 SYNOPSIS
=head1 NAME
-DBIx::Class::CDBICompat::NoObjectIndex
+DBIx::Class::CDBICompat::NoObjectIndex - Defines empty methods for object indexing. They do nothing
=head1 SYNOPSIS
=head1 NAME
-DBIx::Class::CDBICompat::Relationship
+DBIx::Class::CDBICompat::Relationship - Emulate the Class::DBI::Relationship object returned from meta_info()
=head1 DESCRIPTION
=head1 NAME
-DBIx::Class::CDBICompat::Relationships
+DBIx::Class::CDBICompat::Relationships - Emulate has_a(), has_many(), might_have() and meta_info()
=head1 DESCRIPTION
$cond =~ s/^\s*WHERE//i;
- if( $cond =~ s/\bLIMIT (\d+)\s*$//i ) {
- push @rest, { rows => $1 };
+ # Need to parse the SQL clauses after WHERE in reverse
+ # order of appearance.
+
+ my %attrs;
+
+ if( $cond =~ s/\bLIMIT\s+(\d+)\s*$//i ) {
+ $attrs{rows} = $1;
+ }
+
+ if ( $cond =~ s/\bORDER\s+BY\s+(.*)\s*$//i ) {
+ $attrs{order_by} = $1;
+ }
+
+ if( $cond =~ s/\bGROUP\s+BY\s+(.*)\s*$//i ) {
+ $attrs{group_by} = $1;
}
- return $class->search_literal($cond, @rest);
+ return $class->search_literal($cond, @rest, ( %attrs ? \%attrs : () ) );
}
sub construct {
$class->next::method($target, @to_inject);
}
-# Returns a true value if the specified class is installed and loaded
-# successfully, throws an exception if the class is found but not loaded
-# successfully, and false if the class is not installed
-sub load_optional_class {
- my ($class, $f_class) = @_;
- eval { $class->ensure_class_loaded($f_class) };
- my $err = $@; # so we don't lose it
- if (! $err) {
- return 1;
- }
- else {
- my $fn = (join ('/', split ('::', $f_class) ) ) . '.pm';
- if ($err =~ /Can't locate ${fn} in \@INC/ ) {
- return 0;
- }
- else {
- die $err;
- }
- }
-}
-
1;
sub _maybe_attach_source_to_schema {
my ($class, $source) = @_;
if (my $meth = $class->can('schema_instance')) {
- my $schema = $class->$meth;
- $schema->register_class($class, $class);
- my $new_source = $schema->source($class);
- %$source = %$new_source;
- $schema->source_registrations->{$class} = $source;
+ if (my $schema = $class->$meth) {
+ $schema->register_class($class, $class);
+ my $new_source = $schema->source($class);
+ %$source = %$new_source;
+ $schema->source_registrations->{$class} = $source;
+ }
}
}
If you want to set a specific timezone and locale for that field, use:
__PACKAGE__->add_columns(
- starts_when => { data_type => 'datetime', extra => { timezone => "America/Chicago", locale => "de_DE" } }
+ starts_when => { data_type => 'datetime', timezone => "America/Chicago", locale => "de_DE" }
);
If you want to inflate no matter what data_type your column is,
my $timezone;
if ( defined $info->{extra}{timezone} ) {
+ warn "Putting timezone into extra => { timezone => '...' } has been deprecated, ".
+ "please put it directly into the columns definition.";
$timezone = $info->{extra}{timezone};
}
my $locale;
if ( defined $info->{extra}{locale} ) {
+ warn "Putting locale into extra => { locale => '...' } has been deprecated, ".
+ "please put it directly into the columns definition.";
$locale = $info->{extra}{locale};
}
+
+ $locale = $info->{locale} if defined $info->{locale};
+ $timezone = $info->{timezone} if defined $info->{timezone};
my $undef_if_invalid = $info->{datetime_undef_if_invalid};
# closure &G, $info => $H
# $H => %E
#
- my $floating_tz_ok = $info->{extra}{floating_tz_ok};
+ my $floating_tz_ok;
+ if (defined $info->{extra}{floating_tz_ok}) {
+ warn "Putting floating_tz_ok into extra => { floating_tz_ok => 1 } has been deprecated, ".
+ "please put it directly into the columns definition.";
+ $floating_tz_ok = $info->{extra}{floating_tz_ok};
+ }
+ $floating_tz_ok = $info->{floating_tz_ok} if defined $info->{floating_tz_ok};
$self->inflate_column(
$column =>
result you expect). For example:
__PACKAGE__->add_columns(
- starts_when => { data_type => 'datetime', extra => { timezone => "America/Chicago" } }
+ starts_when => { data_type => 'datetime', timezone => "America/Chicago" }
);
my $event = $schema->resultset('EventTZ')->create({
=item Suppress the check on per-column basis
__PACKAGE__->add_columns(
- starts_when => { data_type => 'datetime', extra => { timezone => "America/Chicago", floating_tz_ok => 1 } }
+ starts_when => { data_type => 'datetime', timezone => "America/Chicago", floating_tz_ok => 1 }
);
=item Suppress the check globally
=back
-
+Putting extra attributes like timezone, locale or floating_tz_ok into extra => {} has been
+B<DEPRECATED> because this gets you into trouble using L<DBIx::Class::Schema::Versioned>.
+Instead put it directly into the columns definition like in the examples above. If you still
+use the old way you'll see a warning - please fix your code then!
=head1 SEE ALSO
return $rs->all(); # all records for page 1
-The C<page> attribute does not have to be specified in your search:
-
- my $rs = $schema->resultset('Artist')->search(
- undef,
- {
- rows => 10,
- }
- );
-
- return $rs->page(1); # DBIx::Class::ResultSet containing first 10 records
-
-In either of the above cases, you can get a L<Data::Page> object for the
-resultset (suitable for use in e.g. a template) using the C<pager> method:
+You can get a L<Data::Page> object for the resultset (suitable for use
+in e.g. a template) using the C<pager> method:
return $rs->pager();
Say you want to run a complex custom query on your user data, here's what
you have to add to your User class:
- package My::Schema::User;
+ package My::Schema::Result::User;
use base qw/DBIx::Class/;
achieve the same with subclassing the resultset class and defining the
ResultSource there:
- package My::Schema::UserFriendsComplex;
+ package My::Schema::Result::UserFriendsComplex;
- use My::Schema::User;
- use base qw/My::Schema::User/;
+ use My::Schema::Result::User;
+ use base qw/My::Schema::Result::User/;
__PACKAGE__->table('dummy'); # currently must be called before anything else
are in any way unsure about the use of the attributes above (C< join
>, C< select >, C< as > and C< group_by >).
-=head2 Subqueries
+=head2 Subqueries (EXPERIMENTAL)
You can write subqueries relatively easily in DBIC.
WHERE artistid = me.artistid
)
+=head3 EXPERIMENTAL
+
+Please note that subqueries are considered an experimental feature.
+
=head2 Predefined searches
You can write your own L<DBIx::Class::ResultSet> class by inheriting from it
module.
To make an object stringify itself as a single column, use something
-like this (replace C<foo> with the column/method of your choice):
+like this (replace C<name> with the column/method of your choice):
use overload '""' => sub { shift->name}, fallback => 1;
B<Schema Definition>
- package DB::Schema;
+ package My::Schema;
use base qw/DBIx::Class::Schema/;
- __PACKAGE__->load_classes(qw/User/);
+ __PACKAGE__->load_namespaces;
B<Proxy-Class definitions>
- package DB::Schema::User;
+ package My::Schema::Result::User;
use strict;
use warnings;
}
- package DB::Schema::User::Admin;
+ package My::Schema::Result::User::Admin;
use strict;
use warnings;
- use base qw/DB::Schema::User/;
+ use base qw/My::Schema::Result::User/;
sub hello
{
use warnings;
use strict;
- use DB::Schema;
+ use My::Schema;
my $user_data = { email => 'someguy@place.com',
password => 'pass1',
password => 'pass2',
admin => 1 };
- my $schema = DB::Schema->connection('dbi:Pg:dbname=test');
+ my $schema = My::Schema->connection('dbi:Pg:dbname=test');
$schema->resultset('User')->create( $user_data );
$schema->resultset('User')->create( $admin_data );
Wasn't that easy?
+Beware, changing the Result class using
+L<DBIx::Class::ResultSet/result_class> will replace any existing class
+completely including any special components loaded using
+load_components, eg L<DBIx::Class::InflateColumn::DateTime>.
+
=head2 Get raw data for blindingly fast results
If the L<HashRefInflator|DBIx::Class::ResultClass::HashRefInflator> solution
above is not fast enough for you, you can use a DBIx::Class to return values
-exactly as they come out of the data base with none of the convenience methods
+exactly as they come out of the database with none of the convenience methods
wrapped round them.
This is used like so:
}
You will need to map the array offsets to particular columns (you can
-use the I<select> attribute of C<search()> to force ordering).
+use the L<DBIx::Class::ResultSet/select> attribute of L<DBIx::Class::ResultSet/search> to force ordering).
=head1 RESULTSET OPERATIONS
=head2 Getting Schema from a ResultSet
-To get the schema object from a result set, do the following:
+To get the L<DBIx::Class::Schema> object from a ResultSet, do the following:
$rs->result_source->schema
$rs = $user->addresses(); # get all addresses for a user
$rs = $address->users(); # get all users for an address
+=head2 Relationships across DB schemas
+
+Mapping relationships across L<DB schemas|DBIx::Class::Manual::Glossary/DB schema>
+is easy as long as the schemas themselves are all accessible via the same DBI
+connection. In most cases, this means that they are on the same database host
+as each other and your connecting database user has the proper permissions to them.
+
+To accomplish this one only needs to specify the DB schema name in the table
+declaration, like so...
+
+ package MyDatabase::Main::Artist;
+ use base qw/DBIx::Class/;
+ __PACKAGE__->load_components(qw/PK::Auto Core/);
+
+ __PACKAGE__->table('database1.artist'); # will use "database1.artist" in FROM clause
+
+ __PACKAGE__->add_columns(qw/ artistid name /);
+ __PACKAGE__->set_primary_key('artistid');
+ __PACKAGE__->has_many('cds' => 'MyDatabase::Main::Cd');
+
+ 1;
+
+Whatever string you specify there will be used to build the "FROM" clause in SQL
+queries.
+
+The big drawback to this is you now have DB schema names hardcoded in your
+class files. This becomes especially troublesome if you have multiple instances
+of your application to support a change lifecycle (e.g. DEV, TEST, PROD) and
+the DB schemas are named based on the environment (e.g. database1_dev).
+
+However, one can dynamically "map" to the proper DB schema by overriding the
+L<connection|DBIx::Class::Schama/connection> method in your Schema class and
+building a renaming facility, like so:
+
+ package MyDatabase::Schema;
+ use Moose;
+
+ extends 'DBIx::Class::Schema';
+
+ around connection => sub {
+ my ( $inner, $self, $dsn, $username, $pass, $attr ) = ( shift, @_ );
+
+ my $postfix = delete $attr->{schema_name_postfix};
+
+ $inner->(@_);
+
+ if ( $postfix ) {
+ $self->append_db_name($postfix);
+ }
+ };
+
+ sub append_db_name {
+ my ( $self, $postfix ) = @_;
+
+ my @sources_with_db
+ = grep
+ { $_->name =~ /^\w+\./mx }
+ map
+ { $self->source($_) }
+ $self->sources;
+
+ foreach my $source (@sources_with_db) {
+ my $name = $source->name;
+ $name =~ s{^(\w+)\.}{${1}${postfix}\.}mx;
+
+ $source->name($name);
+ }
+ }
+
+ 1;
+
+By overridding the L<connection|DBIx::Class::Schama/connection>
+method and extracting a custom option from the provided \%attr hashref one can
+then simply iterate over all the Schema's ResultSources, renaming them as
+needed.
+
+To use this facility, simply add or modify the \%attr hashref that is passed to
+L<connection|DBIx::Class::Schama/connect>, as follows:
+
+ my $schema
+ = MyDatabase::Schema->connect(
+ $dsn,
+ $user,
+ $pass,
+ {
+ schema_name_postfix => '_dev'
+ # ... Other options as desired ...
+ })
+
+Obviously, one could accomplish even more advanced mapping via a hash map or a
+callback routine.
+
=head1 TRANSACTIONS
As of version 0.04001, there is improved transaction support in
while (my @vals = $cursor->next) {
print $vals[0]."\n";
}
+
+In case you're going to use this "trick" together with L<DBIx::Class::Schema/deploy> or
+L<DBIx::Class::Schema/create_ddl_dir> a table called "dual" will be created in your
+current schema. This would overlap "sys.dual" and you could not fetch "sysdate" or
+"sequence.nextval" anymore from dual. To avoid this problem, just tell
+L<SQL::Translator> to not create table dual:
+
+ my $sqlt_args = {
+ add_drop_table => 1,
+ parser_args => { sources => [ grep $_ ne 'Dual', schema->sources ] },
+ };
+ $schema->create_ddl_dir( [qw/Oracle/], undef, './sql', undef, $sqlt_args );
Or use L<DBIx::Class::ResultClass::HashRefInflator>
L<callback system|DBIx::Class::ResultSource/sqlt_deploy_callback> if you wish
to share a hook between multiple sources):
- package My::Schema::Artist;
+ package My::Schema::Result::Artist;
__PACKAGE__->table('artist');
__PACKAGE__->add_columns(id => { ... }, name => { ... })
=head2 Working with PostgreSQL array types
-If your SQL::Abstract version (>= 1.50) supports it, you can assign to
-PostgreSQL array values by passing array references in the C<\%columns>
-(C<\%vals>) hashref of the L<DBIx::Class::ResultSet/create> and
-L<DBIx::Class::Row/update> family of methods:
+You can also assign values to PostgreSQL array columns by passing array
+references in the C<\%columns> (C<\%vals>) hashref of the
+L<DBIx::Class::ResultSet/create> and L<DBIx::Class::Row/update> family of
+methods:
$resultset->create({
numbers => [1, 2, 3]
syntax to load the appropriate classes there is not a direct alternative
avoiding L<Module::Find|Module::Find>.
+=head1 MEMORY USAGE
+
+=head2 Cached statements
+
+L<DBIx::Class> normally caches all statements with L<< prepare_cached()|DBI/prepare_cached >>.
+This is normally a good idea, but if too many statements are cached, the database may use too much
+memory and may eventually run out and fail entirely. If you suspect this may be the case, you may want
+to examine DBI's L<< CachedKids|DBI/CachedKidsCachedKids_(hash_ref) >> hash:
+
+ # print all currently cached prepared statements
+ print for keys %{$schema->storage->dbh->{CachedKids}};
+ # get a count of currently cached prepared statements
+ my $count = scalar keys %{$schema->storage->dbh->{CachedKids}};
+
+If it's appropriate, you can simply clear these statements, automatically deallocating them in the
+database:
+
+ my $kids = $schema->storage->dbh->{CachedKids};
+ delete @{$kids}{keys %$kids} if scalar keys %$kids > 100;
+
+But what you probably want is to expire unused statements and not those that are used frequently.
+You can accomplish this with L<Tie::Cache> or L<Tie::Cache::LRU>:
+
+ use Tie::Cache;
+ use DB::Main;
+ my $schema = DB::Main->connect($dbi_dsn, $user, $pass, {
+ on_connect_do => sub { tie %{shift->_dbh->{CachedKids}}, 'Tie::Cache', 100 },
+ });
+
=cut
Or, if you have quoting off:
- ->search({ 'YEAR(date_of_birth' => 1979 });
+ ->search({ 'YEAR(date_of_birth)' => 1979 });
=item .. find more help on constructing searches?
L<DBIx::Class::PK/discard_changes> does just that by re-fetching the row from storage
using the row's primary key.
+=item .. fetch my data a "page" at a time?
+
+Pass the C<rows> and C<page> attributes to your search, eg:
+
+ ->search({}, { rows => 10, page => 1});
+
+=item .. get a count of all rows even when paging?
+
+Call C<pager> on the paged resultset, it will return a L<Data::Page>
+object. Calling C<total_entries> on the pager will return the correct
+total.
+
+C<count> on the resultset will only return the total number in the page.
+
=back
=head2 Inserting and updating data
=head1 TERMS
+=head2 DB schema
+
+Refers to a single physical schema within an RDBMS. Synonymous with the terms
+'database', for MySQL; and 'schema', for most other RDBMS(s).
+
+In other words, it's the 'xyz' _thing_ you're connecting to when using any of
+the following L<DSN|DBI/connect>(s):
+
+ dbi:DriverName:xyz@hostname:port
+ dbi:DriverName:database=xyz;host=hostname;port=port
+
=head2 Inflation
The act of turning database row data into objects in
=item *
-Each method starts with a "head2" statement of it's name.
+Each method starts with a "head2" statement of its name.
+
+Just the plain method name, not an example of how to call it, or a link.
+This is to ensure easy linking to method documentation from other POD.
=item *
-The header is followed by a one-item list.
+The header is followed by a two-item list. This contains a description
+of the arguments the method is expected to take, and an indication of
+what the method returns.
-The single item provides a list of all possible values for the
+The first item provides a list of all possible values for the
arguments of the method in order, separated by C<, >, preceeded by the
text "Arguments: "
=item *
+%var - A hashref variable (list of key/value pairs) - rarely used in DBIx::Class.
+
+Reading an argument as a hash variable will consume all subsequent
+method arguments, use with caution.
+
+=item *
+
+@var - An array variable (list of values).
+
+Reading an argument as a array variable will consume all subsequent
+method arguments, use with caution.
+
+=item *
+
? - Optional, should be placed after the argument type and name.
+ ## Correct
+ \%myhashref|\@myarrayref?
+
+ ## Wrong
+ \%myhashref?|\@myarrayref
+
+Applies to the entire argument.
+
+Optional arguments can be left out of method calls, unless the caller
+needs to pass in any of the following arguments. In which case the
+caller should pass C<undef> in place of the missing argument.
+
=item *
-| - Alternate argument types.
+| - Alternate argument content types.
+
+At least one of these must be supplied unless the argument is also
+marked optional.
=back
-NOTES:
+The second item starts with the text "Return value:". The remainder of
+the line is either the text "undefined", a text describing the result of
+the method, or a variable with a descriptive name.
-If several arguments are optional, it is always possible to pass
-C<undef> as one optional argument in order to skip it and provide a
-value for the following ones. This does not need to be indicated in
-the Arguments line, it is assumed.
+ ## Good examples
+ =item Return value: undefined
+ =item Return value: A schema object
+ =item Return value: $classname
-The C<?> for optional arguments always applies to the entire argument
-value, not a particular type or argument.
+ ## Bad examples
+ =item Return value: The names
+
+"undefined" means the method does not deliberately return a value, and
+the caller should not use or rely on anything it does return. (Perl
+functions always return something, usually the result of the last code
+statement, if there is no explicit return statement.)
=item *
The description paragraph is followed by another list. Each item in
the list explains one of the possible argument/type combinations.
+This list may be omitted if the author feels that the variable names are
+self-explanatory enough to not require it. Use best judgement.
+
=item *
The argument list is followed by some examples of how to use the
L<DBI> version 1.50 and L<DBD::Pg> 1.43 are known to work.
-=head2 ... Can't locate object method "source_name" via package ...
+=head2 Can't locate object method "source_name" via package
There's likely a syntax error in the table class referred to elsewhere
in this error message. In particular make sure that the package
my $position_column = $self->position_column;
- # FIXME this needs to be wrapped in a transaction
{
+ my $guard = $self->result_source->schema->txn_scope_guard;
+
my ($direction, @between);
if ( $from_position < $to_position ) {
$direction = -1;
}
my $new_pos_val = $self->_position_value ($to_position); # record this before the shift
- $self->_ordered_internal_update({ $position_column => $self->null_position_value }); # take the row out of the picture for a bit
+
+ # we need to null-position the moved row if the position column is part of a constraint
+ if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $self->result_source->unique_constraints }} ) ) ) {
+ $self->_ordered_internal_update({ $position_column => $self->null_position_value });
+ }
+
$self->_shift_siblings ($direction, @between);
$self->_ordered_internal_update({ $position_column => $new_pos_val });
+ $guard->commit;
+
return 1;
}
}
return $self->move_to ($to_position);
}
- # FIXME this needs to be wrapped in a transaction
{
+ my $guard = $self->result_source->schema->txn_scope_guard;
+
# Move to end of current group to adjust siblings
$self->move_last;
$self->_ordered_internal_update;
+ $guard->commit;
+
return 1;
}
}
return $self->next::method( \%changes, @_ );
}
- # FIXME this needs to be wrapped in a transaction
{
+ my $guard = $self->result_source->schema->txn_scope_guard;
+
# if any of our grouping columns have been changed
if (grep { exists $changes{$_} } ($self->_grouping_columns) ) {
$self->move_to(delete $changes{$position_column});
}
- return $self->next::method( \%changes, @_ );
+ my @res;
+ my $want = wantarray();
+ if (not defined $want) {
+ $self->next::method( \%changes, @_ );
+ }
+ elsif ($want) {
+ @res = $self->next::method( \%changes, @_ );
+ }
+ else {
+ $res[0] = $self->next::method( \%changes, @_ );
+ }
+
+ $guard->commit;
+ return $want ? @res : $res[0];
}
}
sub delete {
my $self = shift;
- # FIXME this needs to be wrapped in a transaction
- {
- $self->move_last;
- return $self->next::method( @_ );
+
+ my $guard = $self->result_source->schema->txn_scope_guard;
+
+ $self->move_last;
+
+ my @res;
+ my $want = wantarray();
+ if (not defined $want) {
+ $self->next::method( @_ );
+ }
+ elsif ($want) {
+ @res = $self->next::method( @_ );
}
+ else {
+ $res[0] = $self->next::method( @_ );
+ }
+
+ $guard->commit;
+ return $want ? @res : $res[0];
}
-=head1 Methods for extending Ordered
+=head1 METHODS FOR EXTENDING ORDERED
You would want to override the methods below if you use sparse
(non-linear) or non-numeric position values. This can be useful
my $num_pos = $item->_position;
-Returns the absolute numeric position of the current object, with the
+Returns the B<absolute numeric position> of the current object, with the
first object being at position 1, its sibling at position 2 and so on.
By default simply returns the value of L</position_column>.
my $pos_value = $item->_position_value ( $pos )
-Returns the value of L</position_column> of the object at numeric
+Returns the B<value> of L</position_column> of the object at numeric
position C<$pos>. By default simply returns C<$pos>.
=cut
__PACKAGE__->_initial_position_value(0);
-This method specifies a value of L</position_column> which is assigned
+This method specifies a B<value> of L</position_column> which is assigned
to the first inserted element of a group, if no value was supplied at
insertion time. All subsequent values are derived from this one by
L</_next_position_value> below. Defaults to 1.
my $new_value = $item->_next_position_value ( $position_value )
-Returns a position value that would be considered C<next> with
+Returns a position B<value> that would be considered C<next> with
regards to C<$position_value>. Can be pretty much anything, given
that C<< $position_value < $new_value >> where C<< < >> is the
SQL comparison operator (usually works fine on strings). The
$item->_shift_siblings ($direction, @between)
-Shifts all siblings with position in the range @between (inclusive)
-by one position as specified by $direction (left if < 0, right if > 0).
-By default simply increments/decrements each L<position_column> value
-by 1.
+Shifts all siblings with B<positions values> in the range @between
+(inclusive) by one position as specified by $direction (left if < 0,
+ right if > 0). By default simply increments/decrements each
+L<position_column> value by 1, doing so in a way as to not violate
+any existing constraints.
+
+Note that if you override this method and have unique constraints
+including the L<position_column> the shift is not a trivial task.
+Refer to the implementation source of the default method for more
+information.
=cut
sub _shift_siblings {
# position column is part of a unique constraint, and do a
# one-by-one update if this is the case
- my %uc = $self->result_source->unique_constraints;
- if (grep { $_ eq $position_column } ( map { @$_ } (values %uc) ) ) {
+ if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $self->result_source->unique_constraints }} ) ) ) {
my $rs = $shift_rs->search ({}, { order_by => { "-$ord", $position_column } } );
# FIXME - no need to inflate each row
=head2 _group_rs
-This method returns a resultset containing all memebers of the row
+This method returns a resultset containing all members of the row
group (including the row itself).
=cut
return 1;
}
+=head2 _ordered_internal_update
+
+This is a short-circuited method, that is used internally by this
+module to update positioning values in isolation (i.e. without
+triggering any of the positioning integrity code).
+
+Some day you might get confronted by datasets that have ambiguous
+positioning data (i.e. duplicate position values within the same group,
+in a table without unique constraints). When manually fixing such data
+keep in mind that you can not invoke L<DBIx::Class::Row/update> like
+you normally would, as it will get confused by the wrong data before
+having a chance to update the ill-defined row. If you really know what
+you are doing use this method which bypasses any hooks introduced by
+this module.
+
+=cut
+
sub _ordered_internal_update {
my $self = shift;
local $self->{_ORDERED_INTERNAL_UPDATE} = 1;
solution is to somehow automagically modify the objects that exist
in the current object's result set to have the new position value.
+=head2 Default Values
+
+Using a database defined default_value on one of your group columns
+could result in the position not being assigned correctly.
+
=head1 AUTHOR
-Aran Deltac <bluefeet@cpan.org>
+ Original code framework
+ Aran Deltac <bluefeet@cpan.org>
+
+ Constraints support and code generalisation
+ Peter Rabbitson <ribasushi@cpan.org>
=head1 LICENSE
$rel_info->{cond}, $rel, $self
);
if ($rel_info->{attrs}->{undef_on_null_fk}){
- return unless ref($cond) eq 'HASH';
- return if grep { not defined } values %$cond;
+ return undef unless ref($cond) eq 'HASH';
+ return undef if grep { not defined $_ } values %$cond;
}
my $val = $self->find_related($rel, {}, {});
- return unless $val;
+ return $val unless $val; # $val instead of undef so that null-objects can go through
+
return $self->{_relationship_data}{$rel} = $val;
}
};
if (ref $_ eq 'HASH') {
my $hash;
foreach my $key (keys %$_) {
- my $newkey = $key =~ /\./ ? "me.$key" : $key;
+ my $newkey = $key !~ /\./ ? "me.$key" : $key;
$hash->{$newkey} = $_->{$key};
}
$hash;
return 1;
}
-=head1 AUTHORS
+# Attempt to remove the POD so it (maybe) falls off the indexer
-Alexander Hartmaier <Alexander.Hartmaier@t-systems.at>
-
-Matt S. Trout <mst@shadowcatsystems.co.uk>
-
-=cut
+#=head1 AUTHORS
+#
+#Alexander Hartmaier <Alexander.Hartmaier@t-systems.at>
+#
+#Matt S. Trout <mst@shadowcatsystems.co.uk>
+#
+#=cut
1;
=head1 NAME
-DBIx::Class::ResultClass::HashRefInflator
+DBIx::Class::ResultClass::HashRefInflator - Get raw hashrefs from a resultset
=head1 SYNOPSIS
});
}
+=head3 Resolving conditions and attributes
+
+When a resultset is chained from another resultset, conditions and
+attributes with the same keys need resolving.
+
+L</join>, L</prefetch>, L</+select>, L</+as> attributes are merged
+into the existing ones from the original resultset.
+
+The L</where>, L</having> attribute, and any search conditions are
+merged with an SQL C<AND> to the existing condition from the original
+resultset.
+
+All other attributes are overridden by any new ones supplied in the
+search attributes.
+
=head2 Multiple queries
Since a resultset just defines a query, you can do all sorts of
sub search_rs {
my $self = shift;
+ # Special-case handling for (undef, undef).
+ if ( @_ == 2 && !defined $_[1] && !defined $_[0] ) {
+ pop(@_); pop(@_);
+ }
+
my $attrs = {};
$attrs = pop(@_) if @_ > 1 and ref $_[$#_] eq 'HASH';
my $our_attrs = { %{$self->{attrs}} };
my $new_attrs = { %{$our_attrs}, %{$attrs} };
# merge new attrs into inherited
- foreach my $key (qw/join prefetch +select +as/) {
+ foreach my $key (qw/join prefetch +select +as bind/) {
next unless exists $attrs->{$key};
$new_attrs->{$key} = $self->_merge_attr($our_attrs->{$key}, $attrs->{$key});
}
resultset query.
CAVEAT: C<search_literal> is provided for Class::DBI compatibility and should
-only be used in that context. There are known problems using C<search_literal>
-in chained queries; it can result in bind values in the wrong order. See
-L<DBIx::Class::Manual::Cookbook/Searching> and
+only be used in that context. C<search_literal> is a convenience method.
+It is equivalent to calling $schema->search(\[]), but if you want to ensure
+columns are bound correctly, use C<search>.
+
+Example of how to use C<search> instead of C<search_literal>
+
+ my @cds = $cd_rs->search_literal('cdid = ? AND (artist = ? OR artist = ?)', (2, 1, 2));
+ my @cds = $cd_rs->search(\[ 'cdid = ? AND (artist = ? OR artist = ?)', [ 'cdid', 2 ], [ 'artist', 1 ], [ 'artist', 2 ] ]);
+
+
+See L<DBIx::Class::Manual::Cookbook/Searching> and
L<DBIx::Class::Manual::FAQ/Searching> for searching techniques that do not
require C<search_literal>.
=cut
sub search_literal {
- my ($self, $cond, @vals) = @_;
- my $attrs = (ref $vals[$#vals] eq 'HASH' ? { %{ pop(@vals) } } : {});
- $attrs->{bind} = [ @{$self->{attrs}{bind}||[]}, @vals ];
- return $self->search(\$cond, $attrs);
+ my ($self, $sql, @bind) = @_;
+ my $attr;
+ if ( @bind && ref($bind[-1]) eq 'HASH' ) {
+ $attr = pop @bind;
+ }
+ return $self->search(\[ $sql, map [ __DUMMY__ => $_ ], @bind ], ($attr || () ));
}
=head2 find
For more information, see L<DBIx::Class::Manual::Cookbook>.
+This method is deprecated and will be removed in 0.09. Use L</search()>
+instead. An example conversion is:
+
+ ->search_like({ foo => 'bar' });
+
+ # Becomes
+
+ ->search({ foo => { like => 'bar' } });
+
=cut
sub search_like {
my $class = shift;
+ carp join ("\n",
+ 'search_like() is deprecated and will be removed in 0.09.',
+ 'Instead use ->search({ x => { -like => "y%" } })',
+ '(note the outer pair of {}s - they are important!)'
+ );
my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
my $query = ref $_[0] eq 'HASH' ? { %{shift()} }: {@_};
$query->{$_} = { 'like' => $query->{$_} } for keys %$query;
C<< result_source->result_class >> - which in most cases is the name of the
L<"table"|DBIx::Class::Manual::Glossary/"ResultSource"> class.
+Note that changing the result_class will also remove any components
+that were originally loaded in the source class via
+L<DBIx::Class::ResultSource/load_components>. Any overloaded methods
+in the original source class will not run.
+
=cut
sub result_class {
with to find the number of elements. If passed arguments, does a search
on the resultset and counts the results of that.
-Note: When using C<count> with C<group_by>, L<DBIx::Class> emulates C<GROUP BY>
-using C<COUNT( DISTINCT( columns ) )>. Some databases (notably SQLite) do
-not support C<DISTINCT> with multiple columns. If you are using such a
-database, you should only use columns from the main table in your C<group_by>
-clause.
-
=cut
sub count {
sub _count { # Separated out so pager can get the full count
my $self = shift;
- my $select = { count => '*' };
-
my $attrs = { %{$self->_resolved_attrs} };
- if (my $group_by = delete $attrs->{group_by}) {
- delete $attrs->{having};
- my @distinct = (ref $group_by ? @$group_by : ($group_by));
- # todo: try CONCAT for multi-column pk
- my @pk = $self->result_source->primary_columns;
- if (@pk == 1) {
- my $alias = $attrs->{alias};
- foreach my $column (@distinct) {
- if ($column =~ qr/^(?:\Q${alias}.\E)?$pk[0]$/) {
- @distinct = ($column);
- last;
- }
- }
- }
- $select = { count => { distinct => \@distinct } };
+ if (my $group_by = $attrs->{group_by}) {
+ delete $attrs->{order_by};
+
+ $attrs->{select} = $group_by;
+ $attrs->{from} = [ { 'mesub' => (ref $self)->new($self->result_source, $attrs)->cursor->as_query } ];
+ delete $attrs->{where};
}
- $attrs->{select} = $select;
+ $attrs->{select} = { count => '*' };
$attrs->{as} = [qw/count/];
- # offset, order by and page are not needed to count. record_filter is cdbi
- delete $attrs->{$_} for qw/rows offset order_by page pager record_filter/;
+ # offset, order by, group by, where and page are not needed to count. record_filter is cdbi
+ delete $attrs->{$_} for qw/rows offset order_by group_by page pager record_filter/;
my $tmp_rs = (ref $self)->new($self->result_source, $attrs);
my ($count) = $tmp_rs->cursor->next;
Return Value a L<Data::Page> object for the current resultset. Only makes
sense for queries with a C<page> attribute.
+To get the full count of entries for a paged resultset, call
+C<total_entries> on the L<Data::Page> object.
+
=cut
sub pager {
defined $self->{cond}
&& $self->{cond} eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION
) {
- %new = %{$self->{attrs}{related_objects}};
+ %new = %{ $self->{attrs}{related_objects} || {} }; # nothing might have been inserted yet
$new{-from_resultset} = [ keys %new ] if keys %new;
} else {
$self->throw_exception(
return \%unaliased;
}
-=head2 as_query
+=head2 as_query (EXPERIMENTAL)
=over 4
This is generally used as the RHS for a subquery.
+B<NOTE>: This feature is still experimental.
+
=cut
sub as_query { return shift->cursor->as_query(@_) }
return $self->create($cond);
}
+=head2 update_or_new
+
+=over 4
+
+=item Arguments: \%col_values, { key => $unique_constraint }?
+
+=item Return Value: $rowobject
+
+=back
+
+ $resultset->update_or_new({ col => $val, ... });
+
+First, searches for an existing row matching one of the unique constraints
+(including the primary key) on the source of this resultset. If a row is
+found, updates it with the other given column values. Otherwise, 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.
+
+Takes an optional C<key> attribute to search on a specific unique constraint.
+For example:
+
+ # In your application
+ my $cd = $schema->resultset('CD')->update_or_new(
+ {
+ artist => 'Massive Attack',
+ title => 'Mezzanine',
+ year => 1998,
+ },
+ { key => 'cd_artist_title' }
+ );
+
+ if ($cd->in_storage) {
+ # the cd was updated
+ }
+ else {
+ # the cd is not yet in the database, let's insert it
+ $cd->insert;
+ }
+
+See also L</find>, L</find_or_create> and L<find_or_new>.
+
+=cut
+
+sub update_or_new {
+ my $self = shift;
+ my $attrs = ( @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {} );
+ my $cond = ref $_[0] eq 'HASH' ? shift : {@_};
+
+ my $row = $self->find( $cond, $attrs );
+ if ( defined $row ) {
+ $row->update($cond);
+ return $row;
+ }
+
+ return $self->new_result($cond);
+}
+
=head2 get_cache
=over 4
my $self = shift;
return $self->{_attrs} if $self->{_attrs};
- my $attrs = { %{$self->{attrs}||{}} };
+ my $attrs = { %{ $self->{attrs} || {} } };
my $source = $self->result_source;
- my $alias = $attrs->{alias};
+ my $alias = $attrs->{alias};
$attrs->{columns} ||= delete $attrs->{cols} if exists $attrs->{cols};
- if ($attrs->{columns}) {
- delete $attrs->{as};
- } elsif (!$attrs->{select}) {
- $attrs->{columns} = [ $source->columns ];
+ my @colbits;
+
+ # build columns (as long as select isn't set) into a set of as/select hashes
+ unless ( $attrs->{select} ) {
+ @colbits = map {
+ ( ref($_) eq 'HASH' )
+ ? $_
+ : {
+ (
+ /^\Q${alias}.\E(.+)$/
+ ? "$1"
+ : "$_"
+ )
+ =>
+ (
+ /\./
+ ? "$_"
+ : "${alias}.$_"
+ )
+ }
+ } ( ref($attrs->{columns}) eq 'ARRAY' ) ? @{ delete $attrs->{columns}} : (delete $attrs->{columns} || $source->columns );
}
-
- $attrs->{select} =
- ($attrs->{select}
- ? (ref $attrs->{select} eq 'ARRAY'
- ? [ @{$attrs->{select}} ]
- : [ $attrs->{select} ])
- : [ map { m/\./ ? $_ : "${alias}.$_" } @{delete $attrs->{columns}} ]
- );
- $attrs->{as} =
- ($attrs->{as}
- ? (ref $attrs->{as} eq 'ARRAY'
- ? [ @{$attrs->{as}} ]
- : [ $attrs->{as} ])
- : [ map { m/^\Q${alias}.\E(.+)$/ ? $1 : $_ } @{$attrs->{select}} ]
+ # add the additional columns on
+ foreach ( 'include_columns', '+columns' ) {
+ push @colbits, map {
+ ( ref($_) eq 'HASH' )
+ ? $_
+ : { ( split( /\./, $_ ) )[-1] => ( /\./ ? $_ : "${alias}.$_" ) }
+ } ( ref($attrs->{$_}) eq 'ARRAY' ) ? @{ delete $attrs->{$_} } : delete $attrs->{$_} if ( $attrs->{$_} );
+ }
+
+ # start with initial select items
+ if ( $attrs->{select} ) {
+ $attrs->{select} =
+ ( ref $attrs->{select} eq 'ARRAY' )
+ ? [ @{ $attrs->{select} } ]
+ : [ $attrs->{select} ];
+ $attrs->{as} = (
+ $attrs->{as}
+ ? (
+ ref $attrs->{as} eq 'ARRAY'
+ ? [ @{ $attrs->{as} } ]
+ : [ $attrs->{as} ]
+ )
+ : [ map { m/^\Q${alias}.\E(.+)$/ ? $1 : $_ } @{ $attrs->{select} } ]
);
-
- my $adds;
- if ($adds = delete $attrs->{include_columns}) {
- $adds = [$adds] unless ref $adds eq 'ARRAY';
- push(@{$attrs->{select}}, @$adds);
- push(@{$attrs->{as}}, map { m/([^.]+)$/; $1 } @$adds);
}
- if ($adds = delete $attrs->{'+select'}) {
+ else {
+
+ # otherwise we intialise select & as to empty
+ $attrs->{select} = [];
+ $attrs->{as} = [];
+ }
+
+ # now add colbits to select/as
+ push( @{ $attrs->{select} }, map { values( %{$_} ) } @colbits );
+ push( @{ $attrs->{as} }, map { keys( %{$_} ) } @colbits );
+
+ my $adds;
+ if ( $adds = delete $attrs->{'+select'} ) {
$adds = [$adds] unless ref $adds eq 'ARRAY';
- push(@{$attrs->{select}},
- map { /\./ || ref $_ ? $_ : "${alias}.$_" } @$adds);
+ push(
+ @{ $attrs->{select} },
+ map { /\./ || ref $_ ? $_ : "${alias}.$_" } @$adds
+ );
}
- if (my $adds = delete $attrs->{'+as'}) {
+ if ( $adds = delete $attrs->{'+as'} ) {
$adds = [$adds] unless ref $adds eq 'ARRAY';
- push(@{$attrs->{as}}, @$adds);
+ push( @{ $attrs->{as} }, @$adds );
}
$attrs->{from} ||= [ { $self->{attrs}{alias} => $source->from } ];
- if (exists $attrs->{join} || exists $attrs->{prefetch}) {
+ if ( exists $attrs->{join} || exists $attrs->{prefetch} ) {
my $join = delete $attrs->{join} || {};
- if (defined $attrs->{prefetch}) {
- $join = $self->_merge_attr(
- $join, $attrs->{prefetch}
- );
-
+ if ( defined $attrs->{prefetch} ) {
+ $join = $self->_merge_attr( $join, $attrs->{prefetch} );
+
}
- $attrs->{from} = # have to copy here to avoid corrupting the original
+ $attrs->{from} = # have to copy here to avoid corrupting the original
[
- @{$attrs->{from}},
- $source->resolve_join($join, $alias, { %{$attrs->{seen_join}||{}} })
+ @{ $attrs->{from} },
+ $source->resolve_join(
+ $join, $alias, { %{ $attrs->{seen_join} || {} } }
+ )
];
}
- $attrs->{group_by} ||= $attrs->{select} if delete $attrs->{distinct};
- if ($attrs->{order_by}) {
- $attrs->{order_by} = (ref($attrs->{order_by}) eq 'ARRAY'
- ? [ @{$attrs->{order_by}} ]
- : [ $attrs->{order_by} ]);
- } else {
- $attrs->{order_by} = [];
+ $attrs->{group_by} ||= $attrs->{select}
+ if delete $attrs->{distinct};
+ if ( $attrs->{order_by} ) {
+ $attrs->{order_by} = (
+ ref( $attrs->{order_by} ) eq 'ARRAY'
+ ? [ @{ $attrs->{order_by} } ]
+ : [ $attrs->{order_by} ]
+ );
+ }
+ else {
+ $attrs->{order_by} = [];
}
my $collapse = $attrs->{collapse} || {};
- if (my $prefetch = delete $attrs->{prefetch}) {
- $prefetch = $self->_merge_attr({}, $prefetch);
+ if ( my $prefetch = delete $attrs->{prefetch} ) {
+ $prefetch = $self->_merge_attr( {}, $prefetch );
my @pre_order;
my $seen = { %{ $attrs->{seen_join} || {} } };
- foreach my $p (ref $prefetch eq 'ARRAY' ? @$prefetch : ($prefetch)) {
+ foreach my $p ( ref $prefetch eq 'ARRAY' ? @$prefetch : ($prefetch) ) {
+
# bring joins back to level of current class
- my @prefetch = $source->resolve_prefetch(
- $p, $alias, $seen, \@pre_order, $collapse
- );
- push(@{$attrs->{select}}, map { $_->[0] } @prefetch);
- push(@{$attrs->{as}}, map { $_->[1] } @prefetch);
+ my @prefetch =
+ $source->resolve_prefetch( $p, $alias, $seen, \@pre_order, $collapse );
+ push( @{ $attrs->{select} }, map { $_->[0] } @prefetch );
+ push( @{ $attrs->{as} }, map { $_->[1] } @prefetch );
}
- push(@{$attrs->{order_by}}, @pre_order);
+ push( @{ $attrs->{order_by} }, @pre_order );
}
$attrs->{collapse} = $collapse;
- if ($attrs->{page}) {
+ if ( $attrs->{page} ) {
$attrs->{offset} ||= 0;
- $attrs->{offset} += ($attrs->{rows} * ($attrs->{page} - 1));
+ $attrs->{offset} += ( $attrs->{rows} * ( $attrs->{page} - 1 ) );
}
return $self->{_attrs} = $attrs;
=over 4
-=item Value: ($order_by | \@order_by)
+=item Value: ( $order_by | \@order_by | \%order_by )
=back
-Which column(s) to order the results by. This is currently passed
-through directly to SQL, so you can give e.g. C<year DESC> for a
-descending order on the column `year'.
+Which column(s) to order the results by. If a single column name, or
+an arrayref of names is supplied, the argument is passed through
+directly to SQL. The hashref syntax allows for connection-agnostic
+specification of ordering direction:
+
+ For descending order:
+
+ order_by => { -desc => [qw/col1 col2 col3/] }
-Please note that if you have C<quote_char> enabled (see
-L<DBIx::Class::Storage::DBI/connect_info>) you will need to do C<\'year DESC' > to
-specify an order. (The scalar ref causes it to be passed as raw sql to the DB,
-so you will need to manually quote things as appropriate.)
+ For explicit ascending order:
-If your L<SQL::Abstract> version supports it (>=1.50), you can also use
-C<{-desc => 'year'}>, which takes care of the quoting for you. This is the
-recommended syntax.
+ order_by => { -asc => 'col' }
+
+The old scalarref syntax (i.e. order_by => \'year DESC') is still
+supported, although you are strongly encouraged to use the hashref
+syntax as outlined above.
=head2 columns
=back
-Shortcut to request a particular set of columns to be retrieved. Adds
-C<me.> onto the start of any column without a C<.> in it and sets C<select>
-from that, then auto-populates C<as> from C<select> as normal. (You may also
-use the C<cols> attribute, as in earlier versions of DBIC.)
+Shortcut to request a particular set of columns to be retrieved. Each
+column spec may be a string (a table column name), or a hash (in which
+case the key is the C<as> value, and the value is used as the C<select>
+expression). Adds C<me.> onto the start of any column without a C<.> in
+it and sets C<select> from that, then auto-populates C<as> from
+C<select> as normal. (You may also use the C<cols> attribute, as in
+earlier versions of DBIC.)
-=head2 include_columns
+=head2 +columns
=over 4
=back
-Shortcut to include additional columns in the returned results - for example
+Indicates additional columns to be selected from storage. Works the same
+as L</columns> but adds columns to the selection. (You may also use the
+C<include_columns> attribute, as in earlier versions of DBIC). For
+example:-
$schema->resultset('CD')->search(undef, {
- include_columns => ['artist.name'],
+ '+columns' => ['artist.name'],
join => ['artist']
});
column (or relationship) accessor, and 'name' is the name of the column
accessor in the related table.
+=head2 include_columns
+
+=over 4
+
+=item Value: \@columns
+
+=back
+
+Deprecated. Acts as a synonym for L</+columns> for backward compatibility.
+
=head2 select
=over 4
If L<rows> attribute is not specified it defualts to 10 rows per page.
+When you have a paged resultset, L</count> will only return the number
+of rows in the page. To get the total, use the L</pager> and call
+C<total_entries> on it.
+
=head2 rows
=over 4
$class = ref $class if ref $class;
my $new_parent_rs = $rs->search_rs; # we don't want to mess up the original, so clone it
my $attrs = $new_parent_rs->_resolved_attrs;
- $new_parent_rs->{attrs}->{$_} = undef for qw(prefetch include_columns +select +as); # prefetch, include_columns, +select, +as cause additional columns to be fetched
+ $new_parent_rs->{attrs}->{prefetch} = undef; # prefetch cause additional columns to be fetched
# If $column can be found in the 'as' list of the parent resultset, use the
# corresponding element of its 'select' list (to keep any custom column
return $new;
}
-=head2 as_query
+=head2 as_query (EXPERIMENTAL)
=over 4
This is generally used as the RHS for a subquery.
+B<NOTE>: This feature is still experimental.
+
=cut
sub as_query { return shift->_resultset->as_query }
=item default_value
Set this to the default value which will be inserted into a column
-by the database. Can contain either a value or a function. This is
-currently only used by L<DBIx::Class::Schema/deploy>.
+by the database. Can contain either a value or a function (use a
+reference to a scalar e.g. C<\'now()'> if you want a function). This
+is currently only used by L<DBIx::Class::Schema/deploy>.
+
+See the note on L<DBIx::Class::Row/new> for more information about possible
+issues related to db-side default values.
=item sequence
$seen ||= {};
$force_left ||= { force => 0 };
if (ref $join eq 'ARRAY') {
- return map { $self->resolve_join($_, $alias, $seen) } @$join;
+ return
+ map {
+ local $force_left->{force} = $force_left->{force};
+ $self->resolve_join($_, $alias, $seen, $force_left);
+ } @$join;
} elsif (ref $join eq 'HASH') {
return
map {
my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
- local $force_left->{force};
+ local $force_left->{force} = $force_left->{force};
(
$self->resolve_join($_, $alias, $seen, $force_left),
$self->related_source($_)->resolve_join(
#warn "$self $k $for $v";
unless ($for->has_column_loaded($v)) {
if ($for->in_storage) {
- $self->throw_exception("Column ${v} not loaded on ${for} trying to resolve relationship");
+ $self->throw_exception(
+ "Column ${v} not loaded or not passed to new() prior to insert()"
+ ." on ${for} trying to resolve relationship (maybe you forgot "
+ ."to call ->reload_from_storage to get defaults from the db)"
+ );
}
return $UNRESOLVABLE_CONDITION;
}
Deploying the view does B<not> translate it between different database
syntaxes, so be careful what you write in your view SQL.
-Virtual views (L</is_virtual> unset or false), are assumed to not
+Virtual views (L</is_virtual> true), are assumed to not
exist in your database as a real view. The L</view_definition> in this
case replaces the view name in a FROM clause in a subselect.
=over
-=item is_virtual set to true
+=item is_virtual set to false
$schema->resultset('Year2000CDs')->all();
SELECT cdid, artist, title FROM year2000cds me
-=item is_virtual set to false
+=item is_virtual set to true
$schema->resultset('Year2000CDs')->all();
Jess Robinson <castaway@desert-island.me.uk>
+Wallace Reis <wreis@cpan.org>
+
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
=head1 NAME
-DBIx::Class::ResultSourceHandle
+DBIx::Class::ResultSourceHandle - Decouple Rows/ResultSets objects from their Source objects
=head1 DESCRIPTION
use Scalar::Util ();
use Scope::Guard;
+###
+### Internal method
+### Do not use
+###
BEGIN {
*MULTICREATE_DEBUG =
$ENV{DBIC_MULTICREATE_DEBUG}
For a more involved explanation, see L<DBIx::Class::ResultSet/create>.
+Please note that if a value is not passed to new, no value will be sent
+in the SQL INSERT call, and the column will therefore assume whatever
+default value was specified in your database. While DBIC will retrieve the
+value of autoincrement columns, it will never make an explicit database
+trip to retrieve default values assigned by the RDBMS. You can explicitly
+request that all values be fetched back from the database by calling
+L</discard_changes>, or you can supply an explicit C<undef> to columns
+with NULL as the default, and save yourself a SELECT.
+
+ CAVEAT:
+
+ The behavior described above will backfire if you use a foreign key column
+ with a database-defined default. If you call the relationship accessor on
+ an object that doesn't have a set value for the FK column, DBIC will throw
+ an exception, as it has no way of knowing the PK of the related object (if
+ there is one).
+
=cut
## It needs to store the new objects somewhere, and call insert on that list later when insert is called on this object. We may need an accessor for these so the user can retrieve them, if just doing ->new().
Reblessing can also be done more easily by setting C<result_class> in
your Result class. See L<DBIx::Class::ResultSource/result_class>.
+Different types of results can also be created from a particular
+L<DBIx::Class::ResultSet>, see L<DBIx::Class::ResultSet/result_class>.
+
=cut
sub inflate_result {
$fetched = $pre_source->result_class->inflate_result(
$pre_source, @{$pre_val});
}
- $new->related_resultset($pre)->set_cache([ $fetched ]);
my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
$class->throw_exception("No accessor for prefetched $pre")
unless defined $accessor;
} else {
$class->throw_exception("Prefetch not supported with accessor '$accessor'");
}
+ $new->related_resultset($pre)->set_cache([ $fetched ]);
}
}
return $new;
return $name;
}
+# Finds all modules in the supplied namespace, or if omitted in the
+# namespace of $class. Untaints all findings as they can be assumed
+# to be safe
+sub _findallmod {
+ my $proto = shift;
+ my $ns = shift || ref $proto || $proto;
+
+ my @mods = Module::Find::findallmod($ns);
+
+ # try to untaint module names. mods where this fails
+ # are left alone so we don't have to change the old behavior
+ no locale; # localized \w doesn't untaint expression
+ return map { $_ =~ m/^( (?:\w+::)* \w+ )$/x ? $1 : $_ } @mods;
+}
+
# returns a hash of $shortname => $fullname for every package
# found in the given namespaces ($shortname is with the $fullname's
# namespace stripped off)
push(
@results_hash,
map { (substr($_, length "${namespace}::"), $_) }
- Module::Find::findallmod($namespace)
+ $class->_findallmod($namespace)
);
}
}
} else {
my @comp = map { substr $_, length "${class}::" }
- Module::Find::findallmod($class);
+ $class->_findallmod;
$comps_for{$class} = \@comp;
}
foreach my $prefix (keys %comps_for) {
foreach my $comp (@{$comps_for{$prefix}||[]}) {
my $comp_class = "${prefix}::${comp}";
- { # try to untaint module name. mods where this fails
- # are left alone so we don't have to change the old behavior
- no locale; # localized \w doesn't untaint expression
- if ( $comp_class =~ m/^( (?:\w+::)* \w+ )$/x ) {
- $comp_class = $1;
- }
- }
$class->ensure_class_loaded($comp_class);
my $snsub = $comp_class->can('source_name');
C<connect> does not. C<connect> wraps it's arguments in an arrayref
before passing them to C<connect_info>.
+=head3 Overloading
+
+C<connect> is a convenience method. It is equivalent to calling
+$schema->clone->connection(@connectinfo). To write your own overloaded
+version, overload L</connection> instead.
+
=cut
sub connect { shift->clone->connection(@_) }
$self->storage->txn_do(@_);
}
-=head2 txn_scope_guard (EXPERIMENTAL)
+=head2 txn_scope_guard
Runs C<txn_scope_guard> on the schema's storage. See
L<DBIx::Class::Storage/txn_scope_guard>.
data in-place on the Schema class. You should probably be calling
L</connect> to get a proper Schema object instead.
+=head3 Overloading
+
+Overload C<connection> to change the behaviour of C<connect>.
=cut
See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
-produced include a DROP TABLE statement for each table created.
+produced include a DROP TABLE statement for each table created. For quoting
+purposes use C<producer_options> value with C<quote_table_names> and
+C<quote_field_names>.
Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash
ref or an array ref, containing a list of source to deploy. If present, then
sub _register_source {
my ($self, $moniker, $source, $params) = @_;
+ my $orig_source = $source;
+
$source = $source->new({ %$source, source_name => $moniker });
+ $source->schema($self);
+ weaken($source->{schema}) if ref($self);
+
+ my $rs_class = $source->result_class;
my %reg = %{$self->source_registrations};
$reg{$moniker} = $source;
$self->source_registrations(\%reg);
- $source->schema($self);
- weaken($source->{schema}) if ref($self);
return if ($params->{extra});
-
- if ($source->result_class) {
- my %map = %{$self->class_mappings};
- if (exists $map{$source->result_class}) {
- warn $source->result_class . ' already has a source, use register_extra_source for additional sources';
- }
- $map{$source->result_class} = $moniker;
- $self->class_mappings(\%map);
+ return unless defined($rs_class) && $rs_class->can('result_source_instance');
+
+ my %map = %{$self->class_mappings};
+ if (
+ exists $map{$rs_class}
+ and
+ $map{$rs_class} ne $moniker
+ and
+ $rs_class->result_source_instance ne $orig_source
+ ) {
+ carp "$rs_class already has a source, use register_extra_source for additional sources";
}
+ $map{$rs_class} = $moniker;
+ $self->class_mappings(\%map);
}
sub _unregister_source {
$db_tr->producer($db);
my $dbic_tr = SQL::Translator->new;
$dbic_tr->parser('SQL::Translator::Parser::DBIx::Class');
- $dbic_tr = $self->storage->configure_sqlt($dbic_tr, $db);
$dbic_tr->data($self);
$dbic_tr->producer($db);
=head1 AUTHORS
-Jess Robinson <castaway@desert-island.demon.co.uk>
+Jess Robinson <castaway@desert-island.me.uk>
Luke Saunders <luke@shadowcatsystems.co.uk>
=head1 LICENSE
=for comment
-=head2 txn_scope_guard (EXPERIMENTAL)
+=head2 txn_scope_guard
-An alternative way of using transactions to C<txn_do>:
+An alternative way of transaction handling based on
+L<DBIx::Class::Storage::TxnScopeGuard>:
- my $txn = $storage->txn_scope_guard;
+ my $txn_guard = $storage->txn_scope_guard;
$row->col1("val1");
$row->update;
- $txn->commit;
+ $txn_guard->commit;
-If a exception occurs, the transaction will be rolled back. This is still very
-experiemental, and we are not 100% sure it is working right when nested. The
-onus is on you as the user to make sure you dont forget to call
-$C<$txn->commit>.
+If an exception occurs, or the guard object otherwise leaves the scope
+before C<< $txn_guard->commit >> is called, the transaction will be rolled
+back by an explicit L</txn_rollback> call. In essence this is akin to
+using a L</txn_begin>/L</txn_commit> pair, without having to worry
+about calling L</txn_rollback> at the right places. Note that since there
+is no defined code closure, there will be no retries and other magic upon
+database disconnection. If you need such functionality see L</txn_do>.
=cut
sub select {
my ($self, $table, $fields, $where, $order, @rest) = @_;
+ local $self->{having_bind} = [];
+ local $self->{from_bind} = [];
+
if (ref $table eq 'SCALAR') {
$table = $$table;
}
@rest = (-1) unless defined $rest[0];
die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
# and anyway, SQL::Abstract::Limit will cause a barf if we don't first
- local $self->{having_bind} = [];
- my ($sql, @ret) = $self->SUPER::select(
+ my ($sql, @where_bind) = $self->SUPER::select(
$table, $self->_recurse_fields($fields), $where, $order, @rest
);
$sql .=
) :
''
;
- return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
+ return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}) : $sql;
}
sub insert {
}
sub _bind_to_sql {
- my $self = shift;
- my $arr = shift;
- my $sql = shift @$$arr;
- $sql =~ s/\?/$self->_quote((shift @$$arr)->[1])/eg;
- return $sql
+ my ($self, $arr) = @_;
+ my ($sql, @bind) = @{${$arr}};
+ push (@{$self->{from_bind}}, @bind);
+ return $sql;
}
sub _make_as {
sub _dbh_execute {
my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
-
+
my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
$self->_query_start( $sql, @$bind );
my $ident = $source->from;
my $bind_attributes = $self->source_bind_attributes($source);
+ my $updated_cols = {};
+
$self->ensure_connected;
foreach my $col ( $source->columns ) {
if ( !defined $to_insert->{$col} ) {
my $col_info = $source->column_info($col);
if ( $col_info->{auto_nextval} ) {
- $to_insert->{$col} = $self->_sequence_fetch( 'nextval', $col_info->{sequence} || $self->_dbh_get_autoinc_seq($self->dbh, $source) );
+ $updated_cols->{$col} = $to_insert->{$col} = $self->_sequence_fetch( 'nextval', $col_info->{sequence} || $self->_dbh_get_autoinc_seq($self->dbh, $source) );
}
}
}
$self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
- return $to_insert;
+ return $updated_cols;
}
## Still not quite perfect, and EXPERIMENTAL
my ($self, $ident, $select, $condition, $attrs) = @_;
my $order = $attrs->{order_by};
- if (ref $condition eq 'SCALAR') {
- my $unwrap = ${$condition};
- if ($unwrap =~ s/ORDER BY (.*)$//i) {
- $order = $1;
- $condition = \$unwrap;
- }
- }
-
my $for = delete $attrs->{for};
my $sql_maker = $self->sql_maker;
$sql_maker->{for} = $for;
=cut
sub _dbh_last_insert_id {
- my ($self, $dbh, $source, $col) = @_;
- # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
- $dbh->func('last_insert_rowid');
+ # All Storage's need to register their own _dbh_last_insert_id
+ # the old SQLite-based method was highly inappropriate
+
+ my $self = shift;
+ my $class = ref $self;
+ $self->throw_exception (<<EOE);
+
+No _dbh_last_insert_id() method found in $class.
+Since the method of obtaining the autoincrement id of the last insert
+operation varies greatly between different databases, this method must be
+individually implemented for every storage class.
+EOE
}
sub last_insert_id {
foreach my $db (@$databases) {
$sqlt->reset();
- $sqlt = $self->configure_sqlt($sqlt, $db);
$sqlt->{schema} = $sqlt_schema;
$sqlt->producer($db);
$t->debug( 0 );
$t->trace( 0 );
$t->parser( $db ) or die $t->error;
- $t = $self->configure_sqlt($t, $db);
my $out = $t->translate( $prefilename ) or die $t->error;
$source_schema = $t->schema;
unless ( $source_schema->name ) {
$t->debug( 0 );
$t->trace( 0 );
$t->parser( $db ) or die $t->error;
- $t = $self->configure_sqlt($t, $db);
my $out = $t->translate( $filename ) or die $t->error;
$dest_schema = $t->schema;
$dest_schema->name( $filename )
}
}
-sub configure_sqlt() {
- my $self = shift;
- my $tr = shift;
- my $db = shift || $self->sqlt_type;
- if ($db eq 'PostgreSQL') {
- $tr->quote_table_names(0);
- $tr->quote_field_names(0);
- }
- return $tr;
-}
-
=head2 deployment_statements
=over 4
$type ||= $self->sqlt_type;
$version ||= $schema->schema_version || '1.x';
$dir ||= './';
- my $filename = $schema->ddl_filename($type, $dir, $version);
+ my $filename = $schema->ddl_filename($type, $version, $dir);
if(-f $filename)
{
my $file;
+++ /dev/null
-package DBIx::Class::Storage::DBI::MultiDistinctEmulation;
-
-use strict;
-use warnings;
-
-use base qw/DBIx::Class::Storage::DBI/;
-
-sub _select {
- my ($self, $ident, $select, $condition, $attrs) = @_;
-
- # hack to make count distincts with multiple columns work in SQLite and Oracle
- if (ref $select eq 'ARRAY') {
- @{$select} = map {$self->replace_distincts($_)} @{$select};
- } else {
- $select = $self->replace_distincts($select);
- }
-
- return $self->next::method($ident, $select, $condition, $attrs);
-}
-
-sub replace_distincts {
- my ($self, $select) = @_;
-
- $select->{count}->{distinct} = join("||", @{$select->{count}->{distinct}})
- if (ref $select eq 'HASH' && $select->{count} && ref $select->{count} eq 'HASH' &&
- $select->{count}->{distinct} && ref $select->{count}->{distinct} eq 'ARRAY');
-
- return $select;
-}
-
-1;
-
-=head1 NAME
-
-DBIx::Class::Storage::DBI::MultiDistinctEmulation - Some databases can't handle count distincts with multiple cols. They should use base on this.
-
-=head1 SYNOPSIS
-
-=head1 DESCRIPTION
-
-This class allows count distincts with multiple columns for retarded databases (Oracle and SQLite)
-
-=head1 AUTHORS
-
-Luke Saunders <luke.saunders@gmail.com>
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
sub _prep_for_execute {
my $self = shift;
+
+ my ($op, $extra_bind, $ident) = @_;
+
my ($sql, $bind) = $self->next::method(@_);
# stringify args, quote via $dbh, and manually insert
my $new_sql;
foreach my $bound (@$bind) {
- shift @$bound;
+ my $col = shift @$bound;
+ my $datatype = 'FIXME!!!';
foreach my $data (@$bound) {
if(ref $data) {
$data = ''.$data;
}
- $new_sql .= shift(@sql_part) . $self->_dbh->quote($data);
+ $data = $self->_dbh->quote($data);
+ $new_sql .= shift(@sql_part) . $data;
}
}
$new_sql .= join '', @sql_part;
use strict;\r
use warnings;\r
\r
-use Data::Dump qw( dump );\r
-\r
use DBI;\r
use base qw/DBIx::Class::Storage::DBI/;\r
\r
use Carp::Clan qw/^DBIx::Class/;
-use base qw/DBIx::Class::Storage::DBI::MultiDistinctEmulation/;
+use base qw/DBIx::Class::Storage::DBI/;
# __PACKAGE__->load_components(qw/PK::Auto/);
reload_row
_prep_for_execute
- configure_sqlt
/],
);
use File::Copy;
use File::Spec;
-use base qw/DBIx::Class::Storage::DBI::MultiDistinctEmulation/;
+use base qw/DBIx::Class::Storage::DBI/;
sub _dbh_last_insert_id {
my ($self, $dbh, $source, $col) = @_;
return $backupfile;
}
-sub disconnect {
-
- # As described in this node http://www.perlmonks.org/?node_id=666210
- # there seems to be no sane way to ->disconnect a SQLite database with
- # cached statement handles. As per mst we just zap the cache and
- # proceed as normal.
-
- my $self = shift;
- if ($self->connected) {
- $self->_dbh->{CachedKids} = {};
- $self->next::method (@_);
- }
-}
-
-
1;
=head1 NAME
-package # Hide from pause for now - till we get it working
- DBIx::Class::Storage::TxnScopeGuard;
+package DBIx::Class::Storage::TxnScopeGuard;
use strict;
use warnings;
=head1 NAME
-DBIx::Class::Storage::TxnScopeGuard - Experimental
+DBIx::Class::Storage::TxnScopeGuard - Scope-based transaction handling
=head1 SYNOPSIS
=head2 new
-Creating an instance of this class will start a new transaction. Expects a
+Creating an instance of this class will start a new transaction (by
+implicitly calling L<DBIx::Class::Storage/txn_begin>. Expects a
L<DBIx::Class::Storage> object as its only argument.
=head2 commit
Commit the transaction, and stop guarding the scope. If this method is not
-called (i.e. an exception is thrown) and this object goes out of scope then
-the transaction is rolled back.
+called and this object goes out of scope (i.e. an exception is thrown) then
+the transaction is rolled back, via L<DBIx::Class::Storage/txn_rollback>
=cut
if ($source->result_class->can('sqlt_deploy_hook')) {
$source->result_class->sqlt_deploy_hook($view);
}
+
+ $source->_invoke_sqlt_deploy_hook($view);
}
if ($dbicschema->can('sqlt_deploy_hook')) {
interrogates the columns, and stuffs it all in an $sqlt_schema object.
It's primary use is in deploying database layouts described as a set
-of L<DBIx::Class> classes, to a database. To do this, see the
-L<DBIx::Class::Schema/deploy> method.
+of L<DBIx::Class> classes, to a database. To do this, see
+L<DBIx::Class::Schema/deploy>.
This can also be achieved by having DBIx::Class export the schema as a
set of SQL files ready for import into your database, or passed to
other machines that need to have your application installed but don't
-have SQL::Translator installed. To do this see the
-L<DBIx::Class::Schema/create_ddl_dir> method.
+have SQL::Translator installed. To do this see
+L<DBIx::Class::Schema/create_ddl_dir>.
=head1 SEE ALSO
qw(setup_connection_class)
]
},
+ 'DBIx::Class::Storage::DBI::Sybase' => {
+ ignore => [
+ qw/should_quote_data_type/,
+ ]
+ },
'DBIx::Class::CDBICompat::AccessorMapping' => { skip => 1 },
'DBIx::Class::CDBICompat::AbstractSearch' => {
ignore => [qw(search_where)]
'DBIx::Class::Storage::DBI' => { skip => 1 },
'DBIx::Class::Storage::DBI::DB2' => { skip => 1 },
'DBIx::Class::Storage::DBI::MSSQL' => { skip => 1 },
- 'DBIx::Class::Storage::DBI::MultiDistinctEmulation' => { skip => 1 },
'DBIx::Class::Storage::DBI::ODBC400' => { skip => 1 },
'DBIx::Class::Storage::DBI::ODBC::DB2_400_SQL' => { skip => 1 },
'DBIx::Class::Storage::DBI::Oracle' => { skip => 1 },
use strict;
use Test::More tests => 2;
+use MRO::Compat;
{
package AAA;
__PACKAGE__->inject_base( __PACKAGE__, 'DBIx::Class::Core' );
}
-eval { Class::C3::calculateMRO('BBB'); };
+eval { mro::get_linear_isa('BBB'); };
ok (! $@, "Correctly skipped injecting a direct parent of class BBB");
-eval { Class::C3::calculateMRO('CCC'); };
+eval { mro::get_linear_isa('CCC'); };
ok (! $@, "Correctly skipped injecting an indirect parent of class BBB");
use base qw/DBIx::Class::ResultSource::Table/;
}
-plan tests => 3;
+plan tests => 4;
my $schema = DBICTest->init_schema();
my $artist_source = $schema->source('Artist');
}
{
+ my $source = $schema->source('DBICTest::Artist');
+ $schema->register_source($source->source_name, $source);
+ is($warn, '', "re-registering an existing source under the same name causes no errors");
+}
+
+{
my $new_source_name = 'Artist->preview(artist_preview)';
$schema->register_source( $new_source_name => $new_source );
use_ok('DBIC::DebugObj');
my $schema = DBICTest->init_schema();
-diag('Testing against ' . join(' ', map { $schema->storage->dbh->get_info($_) } qw/17 18/));
+#diag('Testing against ' . join(' ', map { $schema->storage->dbh->get_info($_) } qw/17 18/));
$schema->storage->sql_maker->quote_char('`');
$schema->storage->sql_maker->name_sep('.');
my $schema = DBICTest->init_schema();
-diag('Testing against ' . join(' ', map { $schema->storage->dbh->get_info($_) } qw/17 18/));
+#diag('Testing against ' . join(' ', map { $schema->storage->dbh->get_info($_) } qw/17 18/));
my $dsn = $schema->storage->_dbi_connect_info->[0];
$schema->connection(
# Disconnect the dbh, and be sneaky about it
# Also test if DBD::SQLite finaly knows how to ->disconnect properly
-TODO: {
- local $TODO = 'SQLite is evil/braindead. Once this test starts passing, remove the related atrocity from DBIx::Class::Storage::DBI::SQLite';
- my $w;
- local $SIG{__WARN__} = sub { $w = shift };
- $schema->storage->_dbh->disconnect;
- ok ($w !~ /active statement handles/, 'SQLite can disconnect properly \o/');
+{
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ $schema->storage->_dbh->disconnect;
+ ok ($w !~ /active statement handles/, 'SQLite can disconnect properly');
}
# Try the operation again - What should happen here is:
use strict;
use warnings;
-use Test::More;
use lib 't/lib';
-
-plan tests => 4;
+use Test::More tests => 8;
sub _chk_warning {
- defined $_[0]?
- $_[0] !~ qr/We found ResultSet class '([^']+)' for '([^']+)', but it seems that you had already set '([^']+)' to use '([^']+)' instead/ :
- 1
+ defined $_[0]?
+ $_[0] !~ qr/We found ResultSet class '([^']+)' for '([^']+)', but it seems that you had already set '([^']+)' to use '([^']+)' instead/ :
+ 1
+}
+
+sub _chk_extra_sources_warning {
+ my $p = qr/already has a source, use register_extra_source for additional sources/;
+ defined $_[0]? $_[0] !~ /$p/ : 1;
+}
+
+sub _verify_sources {
+ my @monikers = @_;
+ is_deeply (
+ [ sort DBICNSTest::RtBug41083->sources ],
+ \@monikers,
+ 'List of resultsource registrations',
+ );
}
-my $warnings;
-eval {
+{
+ my $warnings;
+ eval {
local $SIG{__WARN__} = sub { $warnings .= shift };
package DBICNSTest::RtBug41083;
use base 'DBIx::Class::Schema';
__PACKAGE__->load_namespaces(
- result_namespace => 'Schema_A',
- resultset_namespace => 'ResultSet_A',
- default_resultset_class => 'ResultSet'
+ result_namespace => 'Schema_A',
+ resultset_namespace => 'ResultSet_A',
+ default_resultset_class => 'ResultSet'
);
-};
-ok(!$@) or diag $@;
-ok(_chk_warning($warnings), 'expected no complaint');
+ };
-eval {
+ ok(!$@) or diag $@;
+ ok(_chk_warning($warnings), 'expected no resultset complaint');
+ ok(_chk_extra_sources_warning($warnings), 'expected no extra sources complaint') or diag($warnings);
+
+ _verify_sources (qw/A A::Sub/);
+}
+
+{
+ my $warnings;
+ eval {
local $SIG{__WARN__} = sub { $warnings .= shift };
package DBICNSTest::RtBug41083;
use base 'DBIx::Class::Schema';
__PACKAGE__->load_namespaces(
- result_namespace => 'Schema',
- resultset_namespace => 'ResultSet',
- default_resultset_class => 'ResultSet'
+ result_namespace => 'Schema',
+ resultset_namespace => 'ResultSet',
+ default_resultset_class => 'ResultSet'
);
-};
-ok(!$@) or diag $@;
-ok(_chk_warning($warnings), 'expected no complaint') or diag $warnings;
+ };
+ ok(!$@) or diag $@;
+ ok(_chk_warning($warnings), 'expected no resultset complaint') or diag $warnings;
+ ok(_chk_extra_sources_warning($warnings), 'expected no extra sources complaint') or diag($warnings);
+
+ _verify_sources (qw/A A::Sub Foo Foo::Sub/);
+}
use Test::More;
use lib qw(t/lib);
-use DBICTest;
+use DBIC::SqlMakerTest;
+
+use_ok('DBICTest');
my $schema = DBICTest->init_schema;
eval "use DBD::SQLite";
plan $@
? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 7 );
+ : ( tests => 9 );
}
-### $schema->storage->debug(1);
-
my $where_bind = {
where => \'name like ?',
bind => [ 'Cat%' ],
$new_source->source_name('Complex');
$new_source->name(\<<'');
-( select a.*, cd.cdid as cdid, cd.title as title, cd.year as year
- from artist a
- join cd on cd.artist=a.artistid
- where cd.year=?)
+( SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year
+ FROM artist a
+ JOIN cd ON cd.artist = a.artistid
+ WHERE cd.year = ?)
$schema->register_extra_source('Complex' => $new_source);
->search({ 'artistid' => 1 });
is ( $rs->count, 1, '...cookbook (bind first) + chained search' );
-TODO: {
- # not sure what causes an uninit warning here, please remove when the TODO starts to pass,
- # so the real reason for the warning can be found and fixed
- local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /uninitialized/ };
+{
+ $rs = $schema->resultset('Complex')->search({}, { bind => [ 1999 ] })->search({}, { where => \"title LIKE ?", bind => [ 'Spoon%' ] });
+ my ($sql, @bind) = @${$rs->as_query};
+ is_same_sql_bind(
+ $sql, \@bind,
+ "(SELECT me.artistid, me.name, me.rank, me.charfield FROM (SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year FROM artist a JOIN cd ON cd.artist = a.artistid WHERE cd.year = ?) WHERE title LIKE ?)",
+ [
+ [ '!!dummy' => '1999' ],
+ [ '!!dummy' => 'Spoon%' ]
+ ],
+ 'got correct SQL'
+);
+}
+
+TODO: {
local $TODO = 'bind args order needs fixing (semifor)';
$rs = $schema->resultset('Complex')->search({}, { bind => [ 1999 ] })
->search({ 'artistid' => 1 }, {
use strict;
use warnings;
-our @plan;
+use Test::More;
+BEGIN { plan tests => 7 }
-BEGIN {
- eval "require Module::Find;";
- @plan = $@ ? ( skip_all => 'Could not load Module::Find' )
- : ( tests => 2 );
-}
+package DBICTest::Taint::Classes;
-package DBICTest::Plain;
-
-# Use the Plain test class namespace to avoid the need for a
-# new test infrastructure. If invalid classes will be introduced to
-# 't/lib/DBICTest/Plain/' someday, this has to be reworked.
+use Test::More;
+use Test::Exception;
use lib qw(t/lib);
+use base qw/DBIx::Class::Schema/;
+
+lives_ok (sub {
+ __PACKAGE__->load_classes(qw/Manual/);
+ ok( __PACKAGE__->source('Manual'), 'The Classes::Manual source has been registered' );
+ __PACKAGE__->_unregister_source (qw/Manual/);
+}, 'Loading classes with explicit load_classes worked in taint mode' );
+
+lives_ok (sub {
+ __PACKAGE__->load_classes();
+ ok( __PACKAGE__->source('Auto'), 'The Classes::Auto source has been registered' );
+ ok( __PACKAGE__->source('Auto'), 'The Classes::Manual source has been re-registered' );
+}, 'Loading classes with Module::Find/load_classes worked in taint mode' );
-use Test::More @plan;
+package DBICTest::Taint::Namespaces;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
use base qw/DBIx::Class::Schema/;
-eval{ __PACKAGE__->load_classes() };
-cmp_ok( $@, 'eq', '',
- 'Loading classes with Module::Find worked in taint mode' );
-ok( __PACKAGE__->source('Test'), 'The Plain::Test source has been registered' );
+lives_ok (sub {
+ __PACKAGE__->load_namespaces();
+ ok( __PACKAGE__->source('Test'), 'The Namespaces::Test source has been registered' );
+}, 'Loading classes with Module::Find/load_namespaces worked in taint mode' );
1;
my $schema = DBICTest->init_schema();
-plan tests => 90;
+plan tests => 96;
eval { require DateTime::Format::MySQL };
my $NO_DTFM = $@ ? 1 : 0;
my @art = $schema->resultset("Artist")->search({ }, { order_by => 'name DESC'});
-cmp_ok(@art, '==', 3, "Three artists returned");
+is(@art, 3, "Three artists returned");
my $art = $art[0];
is($art->name, 'We Are In Rehab', "Accessor update ok");
my %dirty = $art->get_dirty_columns();
-cmp_ok(scalar(keys(%dirty)), '==', 1, '1 dirty column');
+is(scalar(keys(%dirty)), 1, '1 dirty column');
ok(grep($_ eq 'name', keys(%dirty)), 'name is dirty');
is($art->get_column("name"), 'We Are In Rehab', 'And via get_column');
ok($art->update, 'Update run');
my %not_dirty = $art->get_dirty_columns();
-cmp_ok(scalar(keys(%not_dirty)), '==', 0, 'Nothing is dirty');
+is(scalar(keys(%not_dirty)), 0, 'Nothing is dirty');
eval {
my $ret = $art->make_column_dirty('name2');
ok(defined($@), 'Failed to make non-existent column dirty');
$art->make_column_dirty('name');
my %fake_dirty = $art->get_dirty_columns();
-cmp_ok(scalar(keys(%fake_dirty)), '==', 1, '1 fake dirty column');
+is(scalar(keys(%fake_dirty)), 1, '1 fake dirty column');
ok(grep($_ eq 'name', keys(%fake_dirty)), 'name is fake dirty');
my $record_jp = $schema->resultset("Artist")->search(undef, { join => 'cds' })->search(undef, { prefetch => 'cds' })->next;
@art = $schema->resultset("Artist")->search({ name => 'We Are In Rehab' });
-cmp_ok(@art, '==', 1, "Changed artist returned by search");
+is(@art, 1, "Changed artist returned by search");
-cmp_ok($art[0]->artistid, '==', 3,'Correct artist too');
+is($art[0]->artistid, 3,'Correct artist too');
lives_ok (sub { $art->delete }, 'Cascading delete on Ordered has_many works' ); # real test in ordered.t
@art = $schema->resultset("Artist")->search({ });
-cmp_ok(@art, '==', 2, 'And then there were two');
+is(@art, 2, 'And then there were two');
ok(!$art->in_storage, "It knows it's dead");
@art = $schema->resultset("Artist")->search({ });
-cmp_ok(@art, '==', 3, 'And now there are three again');
+is(@art, 3, 'And now there are three again');
my $new = $schema->resultset("Artist")->create({ artistid => 4 });
-cmp_ok($new->artistid, '==', 4, 'Create produced record ok');
+is($new->artistid, 4, 'Create produced record ok');
@art = $schema->resultset("Artist")->search({ });
-cmp_ok(@art, '==', 4, "Oh my god! There's four of them!");
+is(@art, 4, "Oh my god! There's four of them!");
$new->set_column('name' => 'Man With A Fork');
my $cd = $schema->resultset("CD")->find(1);
my %cols = $cd->get_columns;
-cmp_ok(keys %cols, '==', 6, 'get_columns number of columns ok');
+is(keys %cols, 6, 'get_columns number of columns ok');
is($cols{title}, 'Spoonful of bees', 'get_columns values ok');
is($cd->title, 'Spoonful of bees', 'Correct CD returned with include');
is($cd->get_column('name'), 'Caterwauler McCrae', 'Additional column returned');
+# check if new syntax +columns also works for this
+$cd = $schema->resultset("CD")->search(undef, { '+columns' => [ 'artist.name' ], join => [ 'artist' ] })->find(1);
+
+is($cd->title, 'Spoonful of bees', 'Correct CD returned with include');
+is($cd->get_column('name'), 'Caterwauler McCrae', 'Additional column returned');
+
+# check if new syntax for +columns select specifiers works for this
+$cd = $schema->resultset("CD")->search(undef, { '+columns' => [ {artist_name => 'artist.name'} ], join => [ 'artist' ] })->find(1);
+
+is($cd->title, 'Spoonful of bees', 'Correct CD returned with include');
+is($cd->get_column('artist_name'), 'Caterwauler McCrae', 'Additional column returned');
+
# update_or_insert
$new = $schema->resultset("Track")->new( {
trackid => 100,
my( $or_rs ) = $schema->resultset("CD")->search_rs($search, { join => 'tags',
order_by => 'cdid' });
-cmp_ok($or_rs->count, '==', 5, 'Search with OR ok');
+is($or_rs->count, 5, 'Search with OR ok');
my $distinct_rs = $schema->resultset("CD")->search($search, { join => 'tags', distinct => 1 });
-cmp_ok($distinct_rs->all, '==', 4, 'DISTINCT search with OR ok');
+is($distinct_rs->all, 4, 'DISTINCT search with OR ok');
SKIP: {
- skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
+ skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 2
if $is_broken_sqlite;
- my $tcount = $schema->resultset("Track")->search(
+ my $tcount = $schema->resultset('Track')->search(
{},
- {
- select => {count => {distinct => ['position', 'title']}},
- as => ['count']
+ {
+ select => [ qw/position title/ ],
+ distinct => 1,
}
);
- cmp_ok($tcount->next->get_column('count'), '==', 13, 'multiple column COUNT DISTINCT ok');
+ is($tcount->count, 13, 'multiple column COUNT DISTINCT ok');
+ $tcount = $schema->resultset('Track')->search(
+ {},
+ {
+ columns => [ qw/position title/ ],
+ distinct => 1,
+ }
+ );
+ is($tcount->count, 13, 'multiple column COUNT DISTINCT ok');
+
+ $tcount = $schema->resultset('Track')->search(
+ {},
+ {
+ group_by => [ qw/position title/ ]
+ }
+ );
+ is($tcount->count, 13, 'multiple column COUNT DISTINCT using column syntax ok');
}
+
my $tag_rs = $schema->resultset('Tag')->search(
[ { 'me.tag' => 'Cheesy' }, { 'me.tag' => 'Blue' } ]);
my $rel_rs = $tag_rs->search_related('cd');
-cmp_ok($rel_rs->count, '==', 5, 'Related search ok');
+is($rel_rs->count, 5, 'Related search ok');
-cmp_ok($or_rs->next->cdid, '==', $rel_rs->next->cdid, 'Related object ok');
+is($or_rs->next->cdid, $rel_rs->next->cdid, 'Related object ok');
$or_rs->reset;
$rel_rs->reset;
my $tag = $schema->resultset('Tag')->search(
[ { 'me.tag' => 'Blue' } ], { cols=>[qw/tagid/] } )->next;
-cmp_ok($tag->has_column_loaded('tagid'), '==', 1, 'Has tagid loaded');
-cmp_ok($tag->has_column_loaded('tag'), '==', 0, 'Has not tag loaded');
+ok($tag->has_column_loaded('tagid'), 'Has tagid loaded');
+ok(!$tag->has_column_loaded('tag'), 'Has not tag loaded');
ok($schema->storage(), 'Storage available');
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");
+ is(@artsn, 4, "Four artists returned");
# make sure subclasses that don't set source_name are ok
ok($schema->source('ArtistSubclass'), 'ArtistSubclass exists');
{
my $art_del = $schema->resultset("Artist")->find({ artistid => 1 });
lives_ok (sub { $art_del->delete }, 'Cascading delete on Ordered has_many works' ); # real test in ordered.t
- cmp_ok( $schema->resultset("CD")->search({artist => 1}), '==', 0, 'Cascading through has_many top level.');
- cmp_ok( $schema->resultset("CD_to_Producer")->search({cd => 1}), '==', 0, 'Cascading through has_many children.');
+ is( $schema->resultset("CD")->search({artist => 1}), 0, 'Cascading through has_many top level.');
+ is( $schema->resultset("CD_to_Producer")->search({cd => 1}), 0, 'Cascading through has_many children.');
}
# test column_info
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More tests => 2;
use lib qw(t/lib);
use DBICTest;
use DBICTest::Schema;
use DBICTest::Schema::Artist;
DBICTest::Schema::Artist->source_name('MyArtist');
-{
- my $w;
- local $SIG{__WARN__} = sub { $w = shift };
- DBICTest::Schema->register_class('FooA', 'DBICTest::Schema::Artist');
- like ($w, qr/use register_extra_source/, 'Complain about using register_class on an already-registered class');
-}
+DBICTest::Schema->register_class('FooA', 'DBICTest::Schema::Artist');
my $schema = DBICTest->init_schema();
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Exception tests => 1;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::Schema;
+use DBIx::Class::ResultSource::Table;
+
+my $schema = DBICTest->init_schema();
+
+my $foo = DBIx::Class::ResultSource::Table->new({ name => "foo" });
+my $bar = DBIx::Class::ResultSource::Table->new({ name => "bar" });
+
+lives_ok {
+ $schema->register_source(foo => $foo);
+ $schema->register_source(bar => $bar);
+} 'multiple classless sources can be registered';
'rank' => {
'data_type' => 'integer',
'is_nullable' => 0,
+ 'default_value' => '13',
+ },
+ 'charfield' => {
+ 'data_type' => 'char',
+ 'is_nullable' => 1,
},
},
'Correctly retrieve column info (mixed null and non-null columns)'
my $schema = DBICTest->init_schema();
-plan tests => 69;
+plan tests => 74;
# has_a test
my $cd = $schema->resultset("CD")->find(4);
if ($INC{'DBICTest/HelperRels.pm'}) {
$artist->add_to_cds({ title => 'Big Flop', year => 2005 });
} else {
- $artist->create_related( 'cds', {
+ my $big_flop = $artist->create_related( 'cds', {
title => 'Big Flop',
year => 2005,
} );
+
+ SKIP:{
+ skip "Can't fix right now", 1 if $DBIx::Class::VERSION < 0.09;
+ lives_ok { $big_flop->genre} "Don't throw exception when col is not loaded after insert";
+ };
}
my $big_flop_cd = ($artist->search_related('cds'))[3];
is($newartist->name, 'Random Boy Band Two', 'find_or_new_related new artist record with id');
is($newartist->id, 200, 'find_or_new_related new artist id set');
+lives_ok(
+ sub {
+ my $new_bookmark = $schema->resultset("Bookmark")->new_result( {} );
+ my $new_related_link = $new_bookmark->new_related( 'link', {} );
+ },
+ 'No back rel'
+);
+
+
TODO: {
local $TODO = "relationship checking needs fixing";
# try to add a bogus relationship using the wrong cols
my $rs_overridden = $schema->source('ForceForeign');
my $relinfo_with_attr = $rs_overridden->relationship_info ('cd_3');
cmp_ok($relinfo_with_attr->{attrs}{is_foreign_key_constraint}, '==', 0, "is_foreign_key_constraint defined for belongs_to relationships with attr.");
+
+# check that relationships below left join relationships are forced to left joins
+# when traversing multiple belongs_to
+my $cds = $schema->resultset("CD")->search({ 'me.cdid' => 5 }, { join => { single_track => 'cd' } });
+is($cds->count, 1, "subjoins under left joins force_left (string)");
+
+$cds = $schema->resultset("CD")->search({ 'me.cdid' => 5 }, { join => { single_track => ['cd'] } });
+is($cds->count, 1, "subjoins under left joins force_left (arrayref)");
+
+$cds = $schema->resultset("CD")->search({ 'me.cdid' => 5 }, { join => { single_track => { cd => {} } } });
+is($cds->count, 1, "subjoins under left joins force_left (hashref)");
is ($track->get_column ($col), $datahashref->{cds}{tracks}{$col}, "Correct track '$col'");
}
}
+
+# check for same query as above but using extended columns syntax
+$rs_hashrefinf = $schema->resultset ('Artist')->search ({ 'me.artistid' => 1}, {
+ join => { cds => 'tracks' },
+ columns => {name => 'name', 'cds.tracks.title' => 'tracks.title', 'cds.tracks.cd' => 'tracks.cd'},
+ order_by => [qw/cds.cdid tracks.trackid/],
+});
+$rs_hashrefinf->result_class('DBIx::Class::ResultClass::HashRefInflator');
+is_deeply [$rs_hashrefinf->all], \@hashrefinf, 'Check query using extended columns syntax';
=> 'Created an artist resultset of undef';
TODO: {
- $TODO = "need to fix the row count =1 when select * from table where pk IS NULL problem";
+ local $TODO = "need to fix the row count =1 when select * from table where pk IS NULL problem";
is $artist2_rs->count, 0
=> 'got no rows';
}
__PACKAGE__->load_components(qw/Core/);
__PACKAGE__->table('testschema.casecheck');
- __PACKAGE__->add_columns(qw/id name NAME uc_name/);
+ __PACKAGE__->add_columns(qw/id name NAME uc_name storecolumn/);
__PACKAGE__->column_info_from_storage(1);
__PACKAGE__->set_primary_key('id');
+ sub store_column {
+ my ($self, $name, $value) = @_;
+ $value = '#'.$value if($name eq "storecolumn");
+ $self->maybe::next::method($name, $value);
+ }
}
{
unless ($dsn && $user);
-plan tests => 37;
+plan tests => 39;
DBICTest::Schema->load_classes( 'Casecheck', 'ArrayTest' );
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
$dbh->do("CREATE SEQUENCE pkid1_seq START 1 MAXVALUE 999999 MINVALUE 0");
$dbh->do("CREATE SEQUENCE pkid2_seq START 10 MAXVALUE 999999 MINVALUE 0");
$dbh->do("CREATE SEQUENCE nonpkid_seq START 20 MAXVALUE 999999 MINVALUE 0");
- ok ( $dbh->do('CREATE TABLE testschema.casecheck (id serial PRIMARY KEY, "name" VARCHAR(1), "NAME" VARCHAR(2), "UC_NAME" VARCHAR(3));'), 'Creation of casecheck table');
+ ok ( $dbh->do('CREATE TABLE testschema.casecheck (id serial PRIMARY KEY, "name" VARCHAR(1), "NAME" VARCHAR(2), "UC_NAME" VARCHAR(3), "storecolumn" VARCHAR(10));'), 'Creation of casecheck table');
ok ( $dbh->do('CREATE TABLE testschema.array_test (id serial PRIMARY KEY, arrayfield INTEGER[]);'), 'Creation of array_test table');
}
+# store_column is called once for create() for non sequence columns
+
+ok(my $storecolumn = $schema->resultset('Casecheck')->create({'storecolumn' => 'a'}));
+
+is($storecolumn->storecolumn, '#a'); # was '##a'
+
+
# This is in Core now, but it's here just to test that it doesn't break
$schema->class('Artist')->load_components('PK::Auto');
is_deeply($type_info, $test_type_info,
'columns_info_for - column data types');
-SKIP: {
- skip "SQL::Abstract < 1.49 does not pass through arrayrefs", 4
- if $SQL::Abstract::VERSION < 1.49;
-
+{
lives_ok {
$schema->resultset('ArrayTest')->create({
arrayfield => [1, 2],
my $count;
lives_ok {
$count = $schema->resultset('ArrayTest')->search({
- arrayfield => \[ '= ?' => [arrayfield => [3, 4]] ], #TODO anything less ugly than this?
+ arrayfield => \[ '= ?' => [arrayfield => [3, 4]] ], #Todo anything less ugly than this?
})->count;
} 'comparing arrayref to pg array data does not blow up';
is($count, 1, 'comparing arrayref to pg array data gives correct result');
});
}
-SKIP: {
- skip "Oracle Auto-PK tests are broken", 16;
-
- # test auto increment using sequences WITHOUT triggers
- for (1..5) {
+for (1..5) {
my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
is($st->pkid1, $_, "Oracle Auto-PK without trigger: First primary key");
is($st->pkid2, $_ + 9, "Oracle Auto-PK without trigger: Second primary key");
is($st->nonpkid, $_ + 19, "Oracle Auto-PK without trigger: Non-primary key");
- }
- my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
- is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually");
}
+my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
+is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually");
+
END {
if($dbh) {
$dbh->do("DROP SCHEMA testschema;");
}
}
-
' as well as following sequences: \'pkid1_seq\', \'pkid2_seq\' and \'nonpkid_seq\''
unless ($dsn && $user && $pass);
-plan tests => 24;
+plan tests => 26;
DBICTest::Schema->load_classes('ArtistFQN');
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
# check count distinct with multiple columns
my $other_track = $schema->resultset('Track')->create({ trackid => 2, cd => 1, position => 1, title => 'Track2' });
+
my $tcount = $schema->resultset('Track')->search(
- {},
- {
- select => [{count => {distinct => ['position', 'title']}}],
- as => ['count']
- }
- );
+ {},
+ {
+ select => [ qw/position title/ ],
+ distinct => 1,
+ }
+);
+is($tcount->count, 2, 'multiple column COUNT DISTINCT ok');
+
+$tcount = $schema->resultset('Track')->search(
+ {},
+ {
+ columns => [ qw/position title/ ],
+ distinct => 1,
+ }
+);
+is($tcount->count, 2, 'multiple column COUNT DISTINCT ok');
-is($tcount->next->get_column('count'), 2, "multiple column select distinct ok");
+$tcount = $schema->resultset('Track')->search(
+ {},
+ {
+ group_by => [ qw/position title/ ]
+ }
+);
+is($tcount->count, 2, 'multiple column COUNT DISTINCT using column syntax ok');
# test LIMIT support
for (1..6) {
# Test LIMIT
for (1..6) {
- $schema->resultset('Artist')->create( { name => 'Artist ' . $_ } );
+ $schema->resultset('Artist')->create( { name => 'Artist ' . $_, rank => $_ } );
}
my $it = $schema->resultset('Artist')->search( { },
use Test::Exception;
use lib qw(t/lib);
use DBICTest;
+use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
-plan tests => 12;
+plan tests => 24;
my $rs = $schema->resultset('CD')->search({},
{
lives_ok(sub { $rs->first->get_column('count') }, 'multiple +select/+as columns, 1st rscolumn present');
lives_ok(sub { $rs->first->get_column('addedtitle') }, 'multiple +select/+as columns, 2nd rscolumn present');
+# Tests a regression in ResultSetColumn wrt +select
+$rs = $schema->resultset('CD')->search(undef,
+ {
+ '+select' => [ \'COUNT(*) AS year_count' ],
+ order_by => 'year_count'
+ }
+);
+my @counts = $rs->get_column('cdid')->all;
+ok(scalar(@counts), 'got rows from ->all using +select');
+
$rs = $schema->resultset('CD')->search({},
{
'+select' => [ \ 'COUNT(*)', 'title' ],
is ($subsel->next->title, $cds->next->title, 'Second CD title match');
is($schema->resultset('CD')->current_source_alias, "me", '$rs->current_source_alias returns "me"');
+
+
+
+$rs = $schema->resultset('CD')->search({},
+ {
+ 'join' => 'artist',
+ 'columns' => ['cdid', 'title', 'artist.name'],
+ }
+);
+
+my ($sql, @bind) = @${$rs->as_query};
+is_same_sql_bind (
+ $sql,
+ \@bind,
+ '(SELECT me.cdid, me.title, artist.name FROM cd me JOIN artist artist ON artist.artistid = me.artist)',
+ [],
+ 'Use of columns attribute results in proper sql'
+);
+
+lives_ok(sub {
+ $rs->first->get_column('cdid')
+}, 'columns 1st rscolumn present');
+
+lives_ok(sub {
+ $rs->first->get_column('title')
+}, 'columns 2nd rscolumn present');
+
+lives_ok(sub {
+ $rs->first->artist->get_column('name')
+}, 'columns 3rd rscolumn present');
+
+
+
+$rs = $schema->resultset('CD')->search({},
+ {
+ 'join' => 'artist',
+ '+columns' => ['cdid', 'title', 'artist.name'],
+ }
+);
+
+($sql, @bind) = @${$rs->as_query};
+is_same_sql_bind (
+ $sql,
+ \@bind,
+ '(SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, me.cdid, me.title, artist.name FROM cd me JOIN artist artist ON artist.artistid = me.artist)',
+ [],
+ 'Use of columns attribute results in proper sql'
+);
+
+lives_ok(sub {
+ $rs->first->get_column('cdid')
+}, 'columns 1st rscolumn present');
+
+lives_ok(sub {
+ $rs->first->get_column('title')
+}, 'columns 2nd rscolumn present');
+
+lives_ok(sub {
+ $rs->first->artist->get_column('name')
+}, 'columns 3rd rscolumn present');
+
+
+$rs = $schema->resultset('CD')->search({'tracks.position' => { -in => [2] } },
+ {
+ join => 'tracks',
+ columns => [qw/me.cdid me.title/],
+ '+select' => ['tracks.position'],
+ '+as' => ['track_position'],
+
+ # get a hashref of CD1 only (the first with a second track)
+ result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+ order_by => 'cdid',
+ rows => 1,
+ }
+);
+
+is_deeply (
+ $rs->single,
+ {
+ cdid => 1,
+ track_position => 2,
+ title => 'Spoonful of bees',
+ },
+ 'limited prefetch via column works on a multi-relationship',
+);
+
+my $sub_rs = $rs->search ({},
+ {
+ columns => [qw/artist tracks.trackid/], # columns should not be merged but override $rs columns
+ '+select' => ['tracks.title'],
+ '+as' => ['tracks.title'],
+ }
+);
+
+is_deeply (
+ $sub_rs->single,
+ {
+ artist => 1,
+ track_position => 2,
+ tracks =>
+ {
+ trackid => 17,
+ title => 'Apiary',
+ },
+ },
+ 'columns/select/as fold properly on sub-searches',
+);
+
+TODO: {
+ local $TODO = "Multi-collapsing still doesn't work right - HRI should be getting an arrayref, not an individual hash";
+ is_deeply (
+ $sub_rs->single,
+ {
+ artist => 1,
+ track_position => 2,
+ tracks => [
+ {
+ trackid => 17,
+ title => 'Apiary',
+ },
+ ],
+ },
+ 'columns/select/as fold properly on sub-searches',
+ );
+}
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-use Test::Exception;
-use lib qw(t/lib);
-use DBICTest;
-use Data::Dumper;
-
-my $schema = DBICTest->init_schema();
-
-my $orig_debug = $schema->storage->debug;
-
-use IO::File;
-
-BEGIN {
- eval "use DBD::SQLite";
- plan $@
- ? ( skip_all => 'needs DBD::SQLite for testing' )
- : ( tests => 68 );
-}
-
-# 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
-my $is_broken_sqlite = 0;
-my ($sqlite_major_ver,$sqlite_minor_ver,$sqlite_patch_ver) =
- split /\./, $schema->storage->dbh->get_info(18);
-if( $schema->storage->dbh->get_info(17) eq 'SQLite' &&
- ( ($sqlite_major_ver < 3) ||
- ($sqlite_major_ver == 3 && $sqlite_minor_ver < 2) ||
- ($sqlite_major_ver == 3 && $sqlite_minor_ver == 2 && $sqlite_patch_ver < 6) ) ) {
- $is_broken_sqlite = 1;
-}
-
-# 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);
-
-my $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');
-
-# A search() with prefetch seems to pollute an already joined resultset
-# in a way that offsets future joins (adapted from a test case by Debolaz)
-{
- my ($cd_rs, $attrs);
-
- # test a real-life case - rs is obtained by an implicit m2m join
- $cd_rs = $schema->resultset ('Producer')->first->cds;
- $attrs = Dumper $cd_rs->{attrs};
-
- $cd_rs->search ({})->all;
- is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search');
-
- lives_ok (sub {
- $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
- is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch');
- }, 'first prefetching search ok');
-
- lives_ok (sub {
- $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
- is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch')
- }, 'second prefetching search ok');
-
-
- # test a regular rs with an empty seen_join injected - it should still work!
- $cd_rs = $schema->resultset ('CD');
- $cd_rs->{attrs}{seen_join} = {};
- $attrs = Dumper $cd_rs->{attrs};
-
- $cd_rs->search ({})->all;
- is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search');
-
- lives_ok (sub {
- $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
- is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch');
- }, 'first prefetching search ok');
-
- lives_ok (sub {
- $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
- is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch')
- }, 'second prefetching search ok');
-}
-
-
-my $queries = 0;
-$schema->storage->debugcb(sub { $queries++; });
-$schema->storage->debug(1);
-
-my @cd = $rs->all;
-
-is($cd[0]->title, 'Spoonful of bees', 'First record returned ok');
-
-ok(!defined $cd[0]->liner_notes, 'No prefetch for NULL LEFT join');
-
-is($cd[1]->{_relationship_data}{liner_notes}->notes, 'Buy Whiskey!', 'Prefetch for present LEFT JOIN');
-
-is(ref $cd[1]->liner_notes, 'DBICTest::LinerNotes', 'Prefetch returns correct class');
-
-is($cd[2]->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'Prefetch on parent object ok');
-
-is($queries, 1, 'prefetch ran only 1 select statement');
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
-
-# test for partial prefetch via columns attr
-my $cd = $schema->resultset('CD')->find(1,
- {
- columns => [qw/title artist artist.name/],
- join => { 'artist' => {} }
- }
-);
-ok(eval { $cd->artist->name eq 'Caterwauler McCrae' }, 'single related column prefetched');
-
-# start test for nested prefetch SELECT count
-$queries = 0;
-$schema->storage->debugcb(sub { $queries++ });
-$schema->storage->debug(1);
-
-$rs = $schema->resultset('Tag')->search(
- {},
- {
- prefetch => { cd => 'artist' }
- }
-);
-
-my $tag = $rs->first;
-
-is( $tag->cd->title, 'Spoonful of bees', 'step 1 ok for nested prefetch' );
-
-is( $tag->cd->artist->name, 'Caterwauler McCrae', 'step 2 ok for nested prefetch');
-
-# count the SELECTs
-#$selects++ if /SELECT(?!.*WHERE 1=0.*)/;
-is($queries, 1, 'nested prefetch ran exactly 1 select statement (excluding column_info)');
-
-$queries = 0;
-
-is($tag->search_related('cd')->search_related('artist')->first->name,
- 'Caterwauler McCrae',
- 'chained belongs_to->belongs_to search_related ok');
-
-is($queries, 0, 'chained search_related after belontgs_to->belongs_to prefetch ran no queries');
-
-$queries = 0;
-
-$cd = $schema->resultset('CD')->find(1, { prefetch => 'artist' });
-
-is($cd->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'artist prefetched correctly on find');
-
-is($queries, 1, 'find with prefetch ran exactly 1 select statement (excluding column_info)');
-
-$queries = 0;
-
-$schema->storage->debugcb(sub { $queries++; });
-
-$cd = $schema->resultset('CD')->find(1, { prefetch => { cd_to_producer => 'producer' } });
-
-is($cd->producers->first->name, 'Matt S Trout', 'many_to_many accessor ok');
-
-is($queries, 1, 'many_to_many accessor with nested prefetch ran exactly 1 query');
-
-$queries = 0;
-
-my $producers = $cd->search_related('cd_to_producer')->search_related('producer');
-
-is($producers->first->name, 'Matt S Trout', 'chained many_to_many search_related ok');
-
-is($queries, 0, 'chained search_related after many_to_many prefetch ran no queries');
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
-
-$rs = $schema->resultset('Tag')->search(
- {},
- {
- join => { cd => 'artist' },
- prefetch => { cd => 'artist' }
- }
-);
-
-cmp_ok( $rs->count, '>=', 0, 'nested prefetch does not duplicate joins' );
-
-my ($artist) = $schema->resultset("Artist")->search({ 'cds.year' => 2001 },
- { order_by => 'artistid DESC', join => 'cds' });
-
-is($artist->name, 'Random Boy Band', "Join search by object ok");
-
-my @cds = $schema->resultset("CD")->search({ 'liner_notes.notes' => 'Buy Merch!' },
- { join => 'liner_notes' });
-
-cmp_ok(scalar @cds, '==', 1, "Single CD retrieved via might_have");
-
-is($cds[0]->title, "Generic Manufactured Singles", "Correct CD retrieved");
-
-my @artists = $schema->resultset("Artist")->search({ 'tags.tag' => 'Shiny' },
- { join => { 'cds' => 'tags' } });
-
-cmp_ok( @artists, '==', 2, "two-join search ok" );
-
-$rs = $schema->resultset("CD")->search(
- {},
- { group_by => [qw/ title me.cdid /] }
-);
-
-SKIP: {
- skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
- if $is_broken_sqlite;
- cmp_ok( $rs->count, '==', 5, "count() ok after group_by on main pk" );
-}
-
-cmp_ok( scalar $rs->all, '==', 5, "all() returns same count as count() after group_by on main pk" );
-
-$rs = $schema->resultset("CD")->search(
- {},
- { join => [qw/ artist /], group_by => [qw/ artist.name /] }
-);
-
-SKIP: {
- skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
- if $is_broken_sqlite;
- cmp_ok( $rs->count, '==', 3, "count() ok after group_by on related column" );
-}
-
-$rs = $schema->resultset("Artist")->search(
- {},
- { join => [qw/ cds /], group_by => [qw/ me.name /], having =>{ 'MAX(cds.cdid)'=> \'< 5' } }
-);
-
-cmp_ok( $rs->all, '==', 2, "results ok after group_by on related column with a having" );
-
-$rs = $rs->search( undef, { having =>{ 'count(*)'=> \'> 2' }});
-
-cmp_ok( $rs->all, '==', 1, "count() ok after group_by on related column with a having" );
-
-$rs = $schema->resultset("Artist")->search(
- { 'cds.title' => 'Spoonful of bees',
- 'cds_2.title' => 'Forkful of bees' },
- { join => [ 'cds', 'cds' ] });
-
-SKIP: {
- skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
- if $is_broken_sqlite;
- cmp_ok($rs->count, '==', 1, "single artist returned from multi-join");
-}
-
-is($rs->next->name, 'Caterwauler McCrae', "Correct artist returned");
-
-$cd = $schema->resultset('Artist')->first->create_related('cds',
- {
- title => 'Unproduced Single',
- year => 2007
-});
-
-my $left_join = $schema->resultset('CD')->search(
- { 'me.cdid' => $cd->cdid },
- { prefetch => { cd_to_producer => 'producer' } }
-);
-
-cmp_ok($left_join, '==', 1, 'prefetch with no join record present');
-
-$queries = 0;
-$schema->storage->debugcb(sub { $queries++ });
-$schema->storage->debug(1);
-
-my $tree_like =
- $schema->resultset('TreeLike')->find(5,
- { join => { parent => { parent => 'parent' } },
- prefetch => { parent => { parent => 'parent' } } });
-
-is($tree_like->name, 'quux', 'Bottom of tree ok');
-$tree_like = $tree_like->parent;
-is($tree_like->name, 'baz', 'First level up ok');
-$tree_like = $tree_like->parent;
-is($tree_like->name, 'bar', 'Second level up ok');
-$tree_like = $tree_like->parent;
-is($tree_like->name, 'foo', 'Third level up ok');
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
-
-cmp_ok($queries, '==', 1, 'Only one query run');
-
-$tree_like = $schema->resultset('TreeLike')->search({'me.id' => 2});
-$tree_like = $tree_like->search_related('children')->search_related('children')->search_related('children')->first;
-is($tree_like->name, 'quux', 'Tree search_related ok');
-
-$tree_like = $schema->resultset('TreeLike')->search_related('children',
- { 'children.id' => 3, 'children_2.id' => 4 },
- { prefetch => { children => 'children' } }
- )->first;
-is(eval { $tree_like->children->first->children->first->name }, 'quux',
- 'Tree search_related with prefetch ok');
-
-$tree_like = eval { $schema->resultset('TreeLike')->search(
- { 'children.id' => 3, 'children_2.id' => 6 },
- { join => [qw/children children/] }
- )->search_related('children', { 'children_4.id' => 7 }, { prefetch => 'children' }
- )->first->children->first; };
-is(eval { $tree_like->name }, 'fong', 'Tree with multiple has_many joins ok');
-
-# test that collapsed joins don't get a _2 appended to the alias
-
-my $sql = '';
-$schema->storage->debugcb(sub { $sql = $_[1] });
-$schema->storage->debug(1);
-
-eval {
- my $row = $schema->resultset('Artist')->search_related('cds', undef, {
- join => 'tracks',
- prefetch => 'tracks',
- })->search_related('tracks')->first;
-};
-
-like( $sql, qr/^SELECT tracks_2\.trackid/, "join not collapsed for search_related" );
-
-$schema->storage->debug($orig_debug);
-$schema->storage->debugobj->callback(undef);
-
-$rs = $schema->resultset('Artist');
-$rs->create({ artistid => 4, name => 'Unknown singer-songwriter' });
-$rs->create({ artistid => 5, name => 'Emo 4ever' });
-@artists = $rs->search(undef, { prefetch => 'cds', order_by => 'artistid' });
-is(scalar @artists, 5, 'has_many prefetch with adjacent empty rows ok');
-
-# -------------
-#
-# Tests for multilevel has_many prefetch
-
-# artist resultsets - with and without prefetch
-my $art_rs = $schema->resultset('Artist');
-my $art_rs_pr = $art_rs->search(
- {},
- {
- join => [ { cds => ['tracks'] } ],
- prefetch => [ { cds => ['tracks'] } ],
- cache => 1 # last test needs this
- }
-);
-
-# This test does the same operation twice - once on a
-# set of items fetched from the db with no prefetch of has_many rels
-# The second prefetches 2 levels of has_many
-# We check things are the same by comparing the name or title
-# we build everything into a hash structure and compare the one
-# from each rs to see what differs
-
-sub make_hash_struc {
- my $rs = shift;
-
- my $struc = {};
- foreach my $art ( $rs->all ) {
- foreach my $cd ( $art->cds ) {
- foreach my $track ( $cd->tracks ) {
- $struc->{ $art->name }{ $cd->title }{ $track->title }++;
- }
- }
- }
- return $struc;
-}
-
-$queries = 0;
-$schema->storage->debugcb(sub { $queries++ });
-$schema->storage->debug(1);
-
-my $prefetch_result = make_hash_struc($art_rs_pr);
-
-is($queries, 1, 'nested prefetch across has_many->has_many ran exactly 1 query');
-
-my $nonpre_result = make_hash_struc($art_rs);
-
-is_deeply( $prefetch_result, $nonpre_result,
- 'Compare 2 level prefetch result to non-prefetch result' );
-
-$queries = 0;
-
-is($art_rs_pr->search_related('cds')->search_related('tracks')->first->title,
- 'Fowlin',
- 'chained has_many->has_many search_related ok'
- );
-
-is($queries, 0, 'chained search_related after has_many->has_many prefetch ran no queries');
-
-# once the following TODO is complete, remove the 2 warning tests immediately after the TODO block
-# (the TODO block itself contains tests ensuring that the warns are removed)
-TODO: {
- local $TODO = 'Prefetch of multiple has_many rels at the same level (currently warn to protect the clueless git)';
-
- #( 1 -> M + M )
- my $cd_rs = $schema->resultset('CD')->search ({ 'me.title' => 'Forkful of bees' });
- my $pr_cd_rs = $cd_rs->search ({}, {
- prefetch => [qw/tracks tags/],
- });
-
- my $tracks_rs = $cd_rs->first->tracks;
- my $tracks_count = $tracks_rs->count;
-
- my ($pr_tracks_rs, $pr_tracks_count);
-
- $queries = 0;
- $schema->storage->debugcb(sub { $queries++ });
- $schema->storage->debug(1);
-
- my $o_mm_warn;
- {
- local $SIG{__WARN__} = sub { $o_mm_warn = shift };
- $pr_tracks_rs = $pr_cd_rs->first->tracks;
- };
- $pr_tracks_count = $pr_tracks_rs->count;
-
- ok(! $o_mm_warn, 'no warning on attempt to prefetch several same level has_many\'s (1 -> M + M)');
-
- is($queries, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query');
- is($pr_tracks_count, $tracks_count, 'equal count of prefetched relations over several same level has_many\'s (1 -> M + M)');
-
- for ($pr_tracks_rs, $tracks_rs) {
- $_->result_class ('DBIx::Class::ResultClass::HashRefInflator');
- }
-
- is_deeply ([$pr_tracks_rs->all], [$tracks_rs->all], 'same structure returned with and without prefetch over several same level has_many\'s (1 -> M + M)');
-
- #( M -> 1 -> M + M )
- my $note_rs = $schema->resultset('LinerNotes')->search ({ notes => 'Buy Whiskey!' });
- my $pr_note_rs = $note_rs->search ({}, {
- prefetch => {
- cd => [qw/tags tracks/]
- },
- });
-
- my $tags_rs = $note_rs->first->cd->tags;
- my $tags_count = $tags_rs->count;
-
- my ($pr_tags_rs, $pr_tags_count);
-
- $queries = 0;
- $schema->storage->debugcb(sub { $queries++ });
- $schema->storage->debug(1);
-
- my $m_o_mm_warn;
- {
- local $SIG{__WARN__} = sub { $m_o_mm_warn = shift };
- $pr_tags_rs = $pr_note_rs->first->cd->tags;
- };
- $pr_tags_count = $pr_tags_rs->count;
-
- ok(! $m_o_mm_warn, 'no warning on attempt to prefetch several same level has_many\'s (M -> 1 -> M + M)');
-
- is($queries, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query');
-
- is($pr_tags_count, $tags_count, 'equal count of prefetched relations over several same level has_many\'s (M -> 1 -> M + M)');
-
- for ($pr_tags_rs, $tags_rs) {
- $_->result_class ('DBIx::Class::ResultClass::HashRefInflator');
- }
-
- is_deeply ([$pr_tags_rs->all], [$tags_rs->all], 'same structure returned with and without prefetch over several same level has_many\'s (M -> 1 -> M + M)');
-};
-
-# remove this closure once the TODO above is working
-my $w;
-{
- local $SIG{__WARN__} = sub { $w = shift };
-
- my $track = $schema->resultset('CD')->search ({ 'me.title' => 'Forkful of bees' }, { prefetch => [qw/tracks tags/] })->first->tracks->first;
- like ($w, qr/will currently disrupt both the functionality of .rs->count\(\), and the amount of objects retrievable via .rs->next\(\)/,
- 'warning on attempt to prefetch several same level has_many\'s (1 -> M + M)');
- my $tag = $schema->resultset('LinerNotes')->search ({ notes => 'Buy Whiskey!' }, { prefetch => { cd => [qw/tags tracks/] } })->first->cd->tags->first;
- like ($w, qr/will currently disrupt both the functionality of .rs->count\(\), and the amount of objects retrievable via .rs->next\(\)/,
- 'warning on attempt to prefetch several same level has_many\'s (M -> 1 -> M + M)');
-}
my $schema = DBICTest->init_schema();
-plan tests => 45;
+plan tests => 49;
# Check the defined unique constraints
is_deeply(
ok($cd->in_storage, 'find correctly grepped the key across a relationship');
is($cd->cdid, 1, 'cdid is correct');
}
+
+# Test update_or_new
+{
+ my $cd1 = $schema->resultset('CD')->update_or_new(
+ {
+ artist => $artistid,
+ title => "SuperHits $$",
+ year => 2007,
+ },
+ { key => 'cd_artist_title' }
+ );
+
+ ok(!$cd1->in_storage, 'CD is not in storage yet after update_or_new');
+ $cd1->insert;
+ ok($cd1->in_storage, 'CD got added to strage after update_or_new && insert');
+
+ my $cd2 = $schema->resultset('CD')->update_or_new(
+ {
+ artist => $artistid,
+ title => "SuperHits $$",
+ year => 2008,
+ },
+ { key => 'cd_artist_title' }
+ );
+ ok($cd2->in_storage, 'Updating year using update_or_new was successful');
+ is($cd2->id, $cd1->id, 'Got the same CD using update_or_new');
+}
\ No newline at end of file
ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
- eval {
+ lives_ok (sub {
my $w;
local $SIG{__WARN__} = sub { $w = shift };
outer($schema, 0);
like ($w, qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or an error/, 'Out of scope warning detected');
- };
-
- local $TODO = "Work out how this should work";
- is($@, "Not sure what we want here, but something", "Rollback okay");
-
- ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+ ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+ }, 'rollback successful withot exception');
sub outer {
my ($schema) = @_;
-
+
my $guard = $schema->txn_scope_guard;
$schema->resultset('Artist')->create({
name => 'Death Cab for Cutie',
});
inner(@_);
- $guard->commit;
}
sub inner {
my ($schema, $fatal) = @_;
- my $guard = $schema->txn_scope_guard;
+
+ my $inner_guard = $schema->txn_scope_guard;
+ is($schema->storage->transaction_depth, 2, "Correct transaction depth");
my $artist = $artist_rs->find({ name => 'Death Cab for Cutie' });
- is($schema->storage->transaction_depth, 2, "Correct transaction depth");
- undef $@;
eval {
$artist->cds->create({
title => 'Plans',
die $@;
}
- # See what happens if we dont $guard->commit;
+ # inner guard should commit without consequences
+ $inner_guard->commit;
}
}
my $group_3 = $employees->search({group_id=>3});
my $to_group = 1;
my $to_pos = undef;
-while (my $employee = $group_3->next) {
- $employee->discard_changes; # since we are effective shift()ing the $rs
- $employee->move_to_group($to_group, $to_pos);
- $to_pos++;
- $to_group = $to_group==1 ? 2 : 1;
+# now that we have transactions we need to work around stupid sqlite
+{
+ my @empl = $group_3->all;
+ while (my $employee = shift @empl) {
+ $employee->discard_changes; # since we are effective shift()ing the $rs while doing this
+ $employee->move_to_group($to_group, $to_pos);
+ $to_pos++;
+ $to_group = $to_group==1 ? 2 : 1;
+ }
}
foreach my $group_id (1..4) {
my $group_employees = $employees->search({group_id=>$group_id});
my $to_group_2_base = 7;
my $to_group_2 = 1;
$to_pos = undef;
-while (my $employee = $group_4->next) {
- $employee->move_to_group({group_id_2=>$to_group, group_id_3=>$to_group_2}, $to_pos);
- $to_pos++;
+
+# now that we have transactions we need to work around stupid sqlite
+{
+ my @empl = $group_3->all;
+ while (my $employee = shift @empl) {
+ $employee->move_to_group({group_id_2=>$to_group, group_id_3=>$to_group_2}, $to_pos);
+ $to_pos++;
$to_group = ($to_group % 3) + 1;
$to_group_2_base++;
$to_group_2 = (ceil($to_group_2_base/3.0) %3) +1
+ }
}
foreach my $group_id_2 (1..4) {
foreach my $group_id_3 (1..4) {
plan tests => $tests_per_run * @json_backends;
-use JSON::Any;
for my $js (@json_backends) {
eval {JSON::Any->import ($js) };
use lib qw(t/lib);
use DBICTest;
+{
+ local $SIG{__WARN__} = sub { warn @_ if $_[0] !~ /extra \=\> .+? has been deprecated/ };
+ DBICTest::Schema->load_classes('EventTZDeprecated');
+}
+
my $schema = DBICTest->init_schema();
eval { require DateTime::Format::MySQL };
plan skip_all => "Need DateTime::Format::MySQL for inflation tests" if $@;
-plan tests => 32;
+plan tests => 50;
# inflation test
my $event = $schema->resultset("Event")->find(1);
# Test "timezone" parameter
-my $event_tz = $schema->resultset('EventTZ')->create({
- starts_at => DateTime->new(year=>2007, month=>12, day=>31, time_zone => "America/Chicago" ),
- created_on => DateTime->new(year=>2006, month=>1, day=>31,
- hour => 13, minute => 34, second => 56, time_zone => "America/New_York" ),
-});
-is ($event_tz->starts_at->day_name, "Montag", 'Locale de_DE loaded: day_name');
-is ($event_tz->starts_at->month_name, "Dezember", 'Locale de_DE loaded: month_name');
-is ($event_tz->created_on->day_name, "Tuesday", 'Default locale loaded: day_name');
-is ($event_tz->created_on->month_name, "January", 'Default locale loaded: month_name');
-
-my $starts_at = $event_tz->starts_at;
-is("$starts_at", '2007-12-31T00:00:00', 'Correct date/time using timezone');
-
-my $created_on = $event_tz->created_on;
-is("$created_on", '2006-01-31T12:34:56', 'Correct timestamp using timezone');
-is($event_tz->created_on->time_zone->name, "America/Chicago", "Correct timezone");
-
-my $loaded_event = $schema->resultset('EventTZ')->find( $event_tz->id );
-
-isa_ok($loaded_event->starts_at, 'DateTime', 'DateTime returned');
-$starts_at = $loaded_event->starts_at;
-is("$starts_at", '2007-12-31T00:00:00', 'Loaded correct date/time using timezone');
-is($starts_at->time_zone->name, 'America/Chicago', 'Correct timezone');
-
-isa_ok($loaded_event->created_on, 'DateTime', 'DateTime returned');
-$created_on = $loaded_event->created_on;
-is("$created_on", '2006-01-31T12:34:56', 'Loaded correct timestamp using timezone');
-is($created_on->time_zone->name, 'America/Chicago', 'Correct timezone');
-
-# Test floating timezone warning
-# We expect one warning
-SKIP: {
- skip "ENV{DBIC_FLOATING_TZ_OK} was set, skipping", 1 if $ENV{DBIC_FLOATING_TZ_OK};
- local $SIG{__WARN__} = sub {
- like(
- shift,
- qr/You're using a floating timezone, please see the documentation of DBIx::Class::InflateColumn::DateTime for an explanation/,
- 'Floating timezone warning'
- );
- };
- my $event_tz_floating = $schema->resultset('EventTZ')->create({
- starts_at => DateTime->new(year=>2007, month=>12, day=>31, ),
- created_on => DateTime->new(year=>2006, month=>1, day=>31,
- hour => 13, minute => 34, second => 56, ),
- });
- delete $SIG{__WARN__};
-};
-
-# This should fail to set
-my $prev_str = "$created_on";
-$loaded_event->update({ created_on => '0000-00-00' });
-is("$created_on", $prev_str, "Don't update invalid dates");
-
-my $invalid = $schema->resultset('Event')->create({
- starts_at => '0000-00-00',
- created_on => $created_on
-});
-
-is( $invalid->get_column('starts_at'), '0000-00-00', "Invalid date stored" );
-is( $invalid->starts_at, undef, "Inflate to undef" );
-
-$invalid->created_on('0000-00-00');
-$invalid->update;
-
-{
- local $@;
- eval { $invalid->created_on };
- like( $@, qr/invalid date format/i, "Invalid date format exception");
+foreach my $tbl (qw/EventTZ EventTZDeprecated/) {
+ my $event_tz = $schema->resultset($tbl)->create({
+ starts_at => DateTime->new(year=>2007, month=>12, day=>31, time_zone => "America/Chicago" ),
+ created_on => DateTime->new(year=>2006, month=>1, day=>31,
+ hour => 13, minute => 34, second => 56, time_zone => "America/New_York" ),
+ });
+
+ is ($event_tz->starts_at->day_name, "Montag", 'Locale de_DE loaded: day_name');
+ is ($event_tz->starts_at->month_name, "Dezember", 'Locale de_DE loaded: month_name');
+ is ($event_tz->created_on->day_name, "Tuesday", 'Default locale loaded: day_name');
+ is ($event_tz->created_on->month_name, "January", 'Default locale loaded: month_name');
+
+ my $starts_at = $event_tz->starts_at;
+ is("$starts_at", '2007-12-31T00:00:00', 'Correct date/time using timezone');
+
+ my $created_on = $event_tz->created_on;
+ is("$created_on", '2006-01-31T12:34:56', 'Correct timestamp using timezone');
+ is($event_tz->created_on->time_zone->name, "America/Chicago", "Correct timezone");
+
+ my $loaded_event = $schema->resultset($tbl)->find( $event_tz->id );
+
+ isa_ok($loaded_event->starts_at, 'DateTime', 'DateTime returned');
+ $starts_at = $loaded_event->starts_at;
+ is("$starts_at", '2007-12-31T00:00:00', 'Loaded correct date/time using timezone');
+ is($starts_at->time_zone->name, 'America/Chicago', 'Correct timezone');
+
+ isa_ok($loaded_event->created_on, 'DateTime', 'DateTime returned');
+ $created_on = $loaded_event->created_on;
+ is("$created_on", '2006-01-31T12:34:56', 'Loaded correct timestamp using timezone');
+ is($created_on->time_zone->name, 'America/Chicago', 'Correct timezone');
+
+ # Test floating timezone warning
+ # We expect one warning
+ SKIP: {
+ skip "ENV{DBIC_FLOATING_TZ_OK} was set, skipping", 1 if $ENV{DBIC_FLOATING_TZ_OK};
+ local $SIG{__WARN__} = sub {
+ like(
+ shift,
+ qr/You're using a floating timezone, please see the documentation of DBIx::Class::InflateColumn::DateTime for an explanation/,
+ 'Floating timezone warning'
+ );
+ };
+ my $event_tz_floating = $schema->resultset($tbl)->create({
+ starts_at => DateTime->new(year=>2007, month=>12, day=>31, ),
+ created_on => DateTime->new(year=>2006, month=>1, day=>31,
+ hour => 13, minute => 34, second => 56, ),
+ });
+ delete $SIG{__WARN__};
+ };
+
+ # This should fail to set
+ my $prev_str = "$created_on";
+ $loaded_event->update({ created_on => '0000-00-00' });
+ is("$created_on", $prev_str, "Don't update invalid dates");
+
+ my $invalid = $schema->resultset('Event')->create({
+ starts_at => '0000-00-00',
+ created_on => $created_on
+ });
+
+ is( $invalid->get_column('starts_at'), '0000-00-00', "Invalid date stored" );
+ is( $invalid->starts_at, undef, "Inflate to undef" );
+
+ $invalid->created_on('0000-00-00');
+ $invalid->update;
+
+ {
+ local $@;
+ eval { $invalid->created_on };
+ like( $@, qr/invalid date format/i, "Invalid date format exception");
+ }
}
## varchar field using inflate_date => 1
my @cds = $schema->resultset('CD')->search( { artist => 1, cdid => { -between => [ 1, 3 ] }, } );
is_same_sql_bind(
$sql, [],
- "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( artist = ? AND cdid BETWEEN ? AND ? ): '1', '1', '3'", [],
+ "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( artist = ? AND (cdid BETWEEN ? AND ?) ): '1', '1', '3'", [],
'got correct SQL with all bind parameters (debugcb)'
);
@cds = $schema->resultset('CD')->search( { artist => 1, cdid => { -between => [ 1, 3 ] }, } );
is_same_sql_bind(
$sql, \@bind,
- "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( artist = ? AND cdid BETWEEN ? AND ? )", ["'1'", "'1'", "'3'"],
+ "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( artist = ? AND (cdid BETWEEN ? AND ?) )", ["'1'", "'1'", "'3'"],
'got correct SQL with all bind parameters (debugobj)'
);
}
## Delete the old database files
$replicated->cleanup;
-
-use Data::Dump qw/dump/;
-#warn dump $replicated->schema->storage->read_handler;
-
-
-
-
-
-
my $sql_maker = $schema->storage->sql_maker;
-SKIP: {
- skip "SQL::Abstract < 1.49 does not pass through arrayrefs", 2
- if $SQL::Abstract::VERSION < 1.49;
-
+{
my ($sql, @bind) = $sql_maker->insert(
'lottery',
{
'scalar ORDER BY okay (multiple values)'
);
-SKIP: {
- skip "SQL::Abstract < 1.49 does not support hashrefs in order_by", 2
- if $SQL::Abstract::VERSION < 1.49;
-
+{
($sql, @bind) = $sql_maker->select(
[
{
'quoted table names for UPDATE'
);
-SKIP: {
- skip "select attr with star does not work in SQL::Abstract < 1.49", 1
- if $SQL::Abstract::VERSION < 1.49;
-
+{
($sql, @bind) = $sql_maker->select(
[
{
+++ /dev/null
-# Test to ensure we get a consistent result set wether or not we use the
-# prefetch option in combination rows (LIMIT).
-use strict;
-use warnings;
-
-use Test::More;
-use lib qw(t/lib);
-use DBICTest;
-
-plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 2);
-
-my $schema = DBICTest->init_schema();
-my $no_prefetch = $schema->resultset('Artist')->search(
- undef,
- { rows => 3 }
-);
-
-my $use_prefetch = $schema->resultset('Artist')->search(
- undef,
- {
- prefetch => 'cds',
- rows => 3
- }
-);
-
-my $no_prefetch_count = 0;
-my $use_prefetch_count = 0;
-
-is($no_prefetch->count, $use_prefetch->count, '$no_prefetch->count == $use_prefetch->count');
-
-TODO: {
- local $TODO = "This is a difficult bug to fix, workaround is not to use prefetch with rows";
- $no_prefetch_count++ while $no_prefetch->next;
- $use_prefetch_count++ while $use_prefetch->next;
- is(
- $no_prefetch_count,
- $use_prefetch_count,
- "manual row count confirms consistency"
- . " (\$no_prefetch_count == $no_prefetch_count, "
- . " \$use_prefetch_count == $use_prefetch_count)"
- );
-}
BEGIN {
- eval "use DBD::mysql; use SQL::Translator 0.09003;";
+ eval "use SQL::Translator 0.09003;";
if ($@) {
- plan skip_all => 'needs DBD::mysql and SQL::Translator 0.09003 for testing';
+ plan skip_all => 'needs SQL::Translator 0.09003 for testing';
}
}
use strict;
use Test::More;
+use lib 't/cdbi/testlib';
BEGIN {
eval "use DBIx::Class::CDBICompat;";
#-----------------------------------------------------------------------
package State;
-use base 'DBIx::Class::Test::SQLite';
+use base 'DBIC::Test::SQLite';
State->table('State');
State->columns(Essential => qw/Abbreviation Name/);
package City;
-use base 'DBIx::Class::Test::SQLite';
+use base 'DBIC::Test::SQLite';
City->table('City');
City->columns(All => qw/Name State Population/);
#-------------------------------------------------------------------------
package CD;
-use base 'DBIx::Class::Test::SQLite';
+use base 'DBIC::Test::SQLite';
CD->table('CD');
CD->columns('All' => qw/artist title length/);
# Multi-column search
{
- my @films = $blrunner->search_like(title => "Bladerunner%", rating => '15');
+ my @films = $blrunner->search (title => { -like => "Bladerunner%"}, rating => '15');
is @films, 1, "Only one Bladerunner is a 15";
}
is($films[0]->id, $gone->id, ' ... the correct one');
# Find all films which were directed by Bob
-@films = Film->search_like('Director', 'Bob %');
+@films = Film->search ( { 'Director' => { -like => 'Bob %' } });
is(scalar @films, 3, ' search_like returns 3 films');
ok(
eq_array(
sub Class::DBI::sheep { ok 0; }
}
+# Install the deprecation warning intercept here for the rest of the 08 dev cycle
+local $SIG{__WARN__} = sub {
+ warn @_ unless (DBIx::Class->VERSION < 0.09 and $_[0] =~ /Query returned more than one row/);
+};
+
sub Film::mutator_name {
my ($class, $col) = @_;
return "set_sheep" if lc $col eq "numexplodingsheep";
like $@, qr/film/, "no hasa film";
eval {
- local $SIG{__WARN__} = sub {
- warn @_ unless $_[0] =~ /Query returned more than one row/;
- };
ok my $f = $ac->movie, "hasa movie";
isa_ok $f, "Film";
is $f->id, $bt->id, " - Bad Taste";
my $abigail = eval { Film->create({ title => "Abigail's Party" }) };
like $@, qr/read only/, "Or create new films";
- $sandl->discard_changes;
+ $_->discard_changes for ($naked, $sandl);
}
eval { require Time::Piece::MySQL };
plan skip_all => "Need Time::Piece::MySQL for this test" if $@;
+use lib 't/cdbi/testlib';
eval { require 't/cdbi/testlib/Log.pm' };
plan skip_all => "Need MySQL for this test" if $@;
use strict;
use Test::More;
+use lib 't/cdbi/testlib';
BEGIN {
eval "use DBIx::Class::CDBICompat;";
{
package Thing;
- use base 'DBIx::Class::Test::SQLite';
+ use base 'DBIC::Test::SQLite';
Thing->columns(TEMP => qw[foo bar]);
Thing->columns(All => qw[thing_id yarrow flower]);
package # hide from PAUSE
MyFilm;
- use base 'DBIx::Class::Test::SQLite';
+ use base 'DBIC::Test::SQLite';
use strict;
__PACKAGE__->set_table('Movies');
use strict;
use Test::More;
+use lib 't/cdbi/testlib';
BEGIN {
eval "use DBIx::Class::CDBICompat;";
{
package Thing;
- use base 'DBIx::Class::Test::SQLite';
+ use base 'DBIC::Test::SQLite';
Thing->columns(TEMP => qw[foo bar baz]);
Thing->columns(All => qw[some real stuff]);
use strict;
use Test::More;
+use lib 't/cdbi/testlib';
BEGIN {
eval "use DBIx::Class::CDBICompat;";
{
package Thing;
- use base 'DBIx::Class::Test::SQLite';
+ use base 'DBIC::Test::SQLite';
Thing->columns(All => qw[thing_id this that date]);
}
use strict;
use Test::More;
use Test::Exception;
+use lib 't/cdbi/testlib';
BEGIN {
eval "use DBIx::Class::CDBICompat;";
{
package Thing;
- use base 'DBIx::Class::Test::SQLite';
+ use base 'DBIC::Test::SQLite';
Thing->columns(All => qw[thing_id this that date]);
}
use strict;
use warnings;
-use base 'DBIx::Class::Test::SQLite';
+use base 'DBIC::Test::SQLite';
__PACKAGE__->set_table('Actor');
use strict;
use warnings;
-use base 'DBIx::Class::Test::SQLite';
+use base 'DBIC::Test::SQLite';
__PACKAGE__->set_table( 'ActorAlias' );
Blurb;
use strict;
-use base 'DBIx::Class::Test::SQLite';
+use base 'DBIC::Test::SQLite';
__PACKAGE__->set_table('Blurbs');
__PACKAGE__->columns('Primary', 'Title');
CDBase;
use strict;
-use base qw(DBIx::Class::Test::SQLite);
+use base qw(DBIC::Test::SQLite);
1;
-package DBIx::Class::Test::SQLite;
+package # hide from PAUSE
+ DBIC::Test::SQLite;
=head1 NAME
Director;
use strict;
-use base 'DBIx::Class::Test::SQLite';
+use base 'DBIC::Test::SQLite';
__PACKAGE__->set_table('Directors');
__PACKAGE__->columns('All' => qw/ Name Birthday IsInsane /);
package # hide from PAUSE
Film;
-use base 'DBIx::Class::Test::SQLite';
+use base 'DBIC::Test::SQLite';
use strict;
__PACKAGE__->set_table('Movies');
package # hide from PAUSE
Lazy;
-use base 'DBIx::Class::Test::SQLite';
+use base 'DBIC::Test::SQLite';
use strict;
__PACKAGE__->set_table("Lazy");
use vars qw/$dbh/;
-# temporary, might get switched to the new test framework someday
-my @connect = ("dbi:mysql:test", "", "", { PrintError => 0});
-
+my @connect = (@ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}, { PrintError => 0});
$dbh = DBI->connect(@connect) or die DBI->errstr;
my @table;
Order;
use strict;
-use base 'DBIx::Class::Test::SQLite';
+use base 'DBIC::Test::SQLite';
__PACKAGE__->set_table('orders');
__PACKAGE__->table_alias('orders');
package OtherThing;
-use base 'DBIx::Class::Test::SQLite';
+use base 'DBIC::Test::SQLite';
OtherThing->set_table("other_thing");
OtherThing->columns(All => qw(id));
package Thing;
-use base 'DBIx::Class::Test::SQLite';
+use base 'DBIC::Test::SQLite';
Thing->set_table("thing");
Thing->columns(All => qw(id that_thing));
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema();
+
+eval "use DBD::SQLite";
+plan skip_all => 'needs DBD::SQLite for testing' if $@;
+plan tests => 13;
+
+my $in_rs = $schema->resultset('Tag')->search({ tag => [ 'Blue', 'Shiny' ] });
+my $rs;
+
+$rs = $schema->resultset('Tag')->search({ tag => 'Blue' });
+is($rs->count, 4, 'Count without DISTINCT');
+
+$rs = $schema->resultset('Tag')->search({ tag => [ 'Blue', 'Shiny' ] }, { group_by => 'tag' });
+is($rs->count, 2, 'Count with single column group_by');
+
+$rs = $schema->resultset('Tag')->search({ tag => 'Blue' }, { group_by => [ qw/tag cd/ ]});
+is($rs->count, 4, 'Count with multiple column group_by');
+
+$rs = $schema->resultset('Tag')->search({ tag => 'Blue' }, { distinct => 1 });
+is($rs->count, 4, 'Count with single column distinct');
+
+$rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->get_column('tag')->as_query } });
+is($rs->count, 4, 'Count with IN subquery');
+
+$rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->get_column('tag')->as_query } }, { group_by => 'tag' });
+is($rs->count, 1, 'Count with IN subquery with outside group_by');
+
+$rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->get_column('tag')->as_query } }, { distinct => 1 });
+is($rs->count, 4, 'Count with IN subquery with outside distinct');
+
+$rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->get_column('tag')->as_query } }, { distinct => 1, select => 'tag' }),
+is($rs->count, 1, 'Count with IN subquery with outside distinct on a single column');
+
+$rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->search({}, { group_by => 'tag' })->get_column('tag')->as_query } });
+is($rs->count, 4, 'Count with IN subquery with single group_by');
+
+$rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->search({}, { group_by => [ qw/tag cd/ ] })->get_column('tag')->as_query } });
+is($rs->count, 4, 'Count with IN subquery with multiple group_by');
+
+$rs = $schema->resultset('Tag')->search({ tag => \"= 'Blue'" });
+is($rs->count, 4, 'Count without DISTINCT, using literal SQL');
+
+$rs = $schema->resultset('Tag')->search({ tag => \" IN ('Blue', 'Shiny')" }, { group_by => 'tag' });
+is($rs->count, 2, 'Count with literal SQL and single group_by');
+
+$rs = $schema->resultset('Tag')->search({ tag => \" IN ('Blue', 'Shiny')" }, { group_by => [ qw/tag cd/ ] });
+is($rs->count, 6, 'Count with literal SQL and multiple group_by');
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+
+use DBICTest;
+
+plan tests => 1;
+
+my $schema = DBICTest->init_schema();
+
+TODO: {
+ local $TODO = 'TODO until we figure out what we really want';
+ my $cds = $schema->resultset("CD")->search({ cdid => 1 }, { join => { cd_to_producer => 'producer' } });
+ is($cds->count, 1, "extra joins do not explode single entity count");
+}
--- /dev/null
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More;
+
+BEGIN {
+ eval "use SQL::Abstract 1.49";
+ plan $@
+ ? ( skip_all => "Needs SQLA 1.49+" )
+ : ( tests => 8 );
+}
+
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema();
+my $art_rs = $schema->resultset('Artist');
+my $cdrs = $schema->resultset('CD');
+
+{
+ my $cdrs2 = $cdrs->search({
+ artist_id => { 'in' => $art_rs->search({}, { rows => 1 })->get_column( 'id' )->as_query },
+ });
+
+ my $arr = $cdrs2->as_query;
+ my ($query, @bind) = @{$$arr};
+ is_same_sql_bind(
+ $query, \@bind,
+ "(SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE artist_id IN ( SELECT id FROM artist me LIMIT 1 ))",
+ [],
+ );
+}
+
+{
+ my $rs = $art_rs->search(
+ {},
+ {
+ 'select' => [
+ $cdrs->search({}, { rows => 1 })->get_column('id')->as_query,
+ ],
+ },
+ );
+
+ my $arr = $rs->as_query;
+ my ($query, @bind) = @{$$arr};
+ is_same_sql_bind(
+ $query, \@bind,
+ "(SELECT (SELECT id FROM cd me LIMIT 1) FROM artist me)",
+ [],
+ );
+}
+
+{
+ my $rs = $art_rs->search(
+ {},
+ {
+ '+select' => [
+ $cdrs->search({}, { rows => 1 })->get_column('id')->as_query,
+ ],
+ },
+ );
+
+ my $arr = $rs->as_query;
+ my ($query, @bind) = @{$$arr};
+ is_same_sql_bind(
+ $query, \@bind,
+ "(SELECT me.artistid, me.name, me.rank, me.charfield, (SELECT id FROM cd me LIMIT 1) FROM artist me)",
+ [],
+ );
+}
+
+# simple from
+{
+ my $rs = $cdrs->search(
+ {},
+ {
+ alias => 'cd2',
+ from => [
+ { cd2 => $cdrs->search({ id => { '>' => 20 } })->as_query },
+ ],
+ },
+ );
+
+ my $arr = $rs->as_query;
+ my ($query, @bind) = @{$$arr};
+ is_same_sql_bind(
+ $query, \@bind,
+ "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE ( id > ? ) ) cd2)",
+ [
+ [ 'id', 20 ]
+ ],
+ );
+}
+
+# nested from
+{
+ my $art_rs2 = $schema->resultset('Artist')->search({},
+ {
+ from => [ { 'me' => 'artist' },
+ [ { 'cds' => $cdrs->search({},{ 'select' => [\'me.artist as cds_artist' ]})->as_query },
+ { 'me.artistid' => 'cds_artist' } ] ]
+ });
+
+ my $arr = $art_rs2->as_query;
+ my ($query, @bind) = @{$$arr};
+ is_same_sql_bind(
+ $query, \@bind,
+ "(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me JOIN (SELECT me.artist as cds_artist FROM cd me) cds ON me.artistid = cds_artist)",
+ []
+ );
+
+
+}
+
+# nested subquery in from
+{
+ my $rs = $cdrs->search(
+ {},
+ {
+ alias => 'cd2',
+ from => [
+ { cd2 => $cdrs->search(
+ { id => { '>' => 20 } },
+ {
+ alias => 'cd3',
+ from => [
+ { cd3 => $cdrs->search( { id => { '<' => 40 } } )->as_query }
+ ],
+ }, )->as_query },
+ ],
+ },
+ );
+
+ my $arr = $rs->as_query;
+ my ($query, @bind) = @{$$arr};
+ is_same_sql_bind(
+ $query, \@bind,
+ "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track
+ FROM
+ (SELECT cd3.cdid,cd3.artist,cd3.title,cd3.year,cd3.genreid,cd3.single_track
+ FROM
+ (SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track
+ FROM cd me WHERE ( id < ? ) ) cd3
+ WHERE ( id > ? ) ) cd2)",
+ [
+ [ 'id', 40 ],
+ [ 'id', 20 ]
+ ],
+ );
+
+}
+
+{
+ my $rs = $cdrs->search({
+ year => {
+ '=' => $cdrs->search(
+ { artistid => { '=' => \'me.artistid' } },
+ { alias => 'inner' }
+ )->get_column('year')->max_rs->as_query,
+ },
+ });
+ my $arr = $rs->as_query;
+ my ($query, @bind) = @{$$arr};
+ is_same_sql_bind(
+ $query, \@bind,
+ "(SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE year = (SELECT MAX(inner.year) FROM cd inner WHERE artistid = me.artistid))",
+ [],
+ );
+}
+
+{
+ my $rs = $cdrs->search(
+ {},
+ {
+ alias => 'cd2',
+ from => [
+ { cd2 => $cdrs->search({ title => 'Thriller' })->as_query },
+ ],
+ },
+ );
+
+ my $arr = $rs->as_query;
+ my ($query, @bind) = @{$$arr};
+ is_same_sql_bind(
+ $query, \@bind,
+ "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE ( title = ? ) ) cd2)",
+ [ [ 'title', 'Thriller' ] ],
+ );
+}
+
+__END__
+++ /dev/null
-package # hide from PAUSE
- DBICNGTest::Schema;
-
- use Moose;
- use Path::Class::File;
- extends 'DBIx::Class::Schema', 'Moose::Object';
-
-
-=head1 NAME
-
-DBICNGTest::Schema; Schema Base For Testing Moose Roles, Traits, etc.
-
-=head1 SYNOPSIS
-
- my $schema = DBICNGTest::Schema->connect($dsn);
-
- ## Do anything you would as with a normal $schema object.
-
-=head1 DESCRIPTION
-
-Defines the base case for loading DBIC Schemas. We add in some additional
-helpful functions for administering you schemas. This namespace is dedicated
-to integration of Moose based development practices.
-
-=head1 PACKAGE METHODS
-
-The following is a list of package methods declared with this class.
-
-=head2 load_namespaces
-
-Automatically load the classes and resultsets from their default namespaces.
-
-=cut
-
-__PACKAGE__->load_namespaces(
- default_resultset_class => 'ResultSet',
-);
-
-
-=head1 ATTRIBUTES
-
-This class defines the following attributes.
-
-=head1 METHODS
-
-This module declares the following methods
-
-=head2 new
-
-overload new to make sure we get a good meta object and that the attributes all
-get properly setup. This is done so that our instances properly get a L<Moose>
-meta class.
-
-=cut
-
-sub new
-{
- my $class = shift @_;
- my $obj = $class->SUPER::new(@_);
-
- return $class->meta->new_object(
- __INSTANCE__ => $obj, @_
- );
-}
-
-
-=head2 connect_and_setup
-
-Creates a schema, deploys a database and sets the testing data.
-
-=cut
-
-sub connect_and_setup {
- my $class = shift @_;
- my $db_file = shift @_;
-
- my ($dsn, $user, $pass) = (
- $ENV{DBICNG_DSN} || "dbi:SQLite:${db_file}",
- $ENV{DBICNG_USER} || '',
- $ENV{DBICNG_PASS} || '',
- );
-
- return $class
- ->connect($dsn, $user, $pass, { AutoCommit => 1 })
- ->setup;
-}
-
-
-=head2 setup
-
-deploy a database and populate it with the initial data
-
-=cut
-
-sub setup {
- my $self = shift @_;
- $self->deploy();
- $self->initial_populate(@_);
-
- return $self;
-}
-
-
-=head2 initial_populate
-
-initializing the startup database information
-
-=cut
-
-sub initial_populate {
- my $self = shift @_;
-
- my @genders = $self->populate('Gender' => [
- [qw(gender_id label)],
- [qw(1 female)],
- [qw(2 male)],
- [qw(3 transgender)],
- ]);
-
- my @persons = $self->populate('Person' => [
- [ qw(person_id fk_gender_id name age) ],
- [ qw(1 1 john 25) ],
- [ qw(2 1 dan 35) ],
- [ qw(3 2 mary 15) ],
- [ qw(4 2 jane 95) ],
- [ qw(5 3 steve 40) ],
- ]);
-
- my @friends = $self->populate('FriendList' => [
- [ qw(fk_person_id fk_friend_id) ],
- [ qw(1 2) ],
- [ qw(1 3) ],
- [ qw(2 3) ],
- [ qw(3 2) ],
- ]);
-}
-
-
-=head2 job_handler_echo
-
-This is a method to test the job handler role.
-
-=cut
-
-sub job_handler_echo {
- my ($schema, $job, $alert) = @_;
- return $alert;
-}
-
-
-=head1 AUTHORS
-
-See L<DBIx::Class> for more information regarding authors.
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
-
-
-1;
+++ /dev/null
-package # hide from PAUSE
- DBICNGTest::Schema::Result;
-
- use Moose;
- extends 'DBIx::Class', 'Moose::Object';
-
-=head1 NAME
-
-DBICNGTest::Schema::Result; Base Class for result and class objects
-
-=head1 SYNOPSIS
-
- package DBICNGTest::Schema::Result::Member;
-
- use Moose;
- extends 'DBICNGTest::Schema::Result';
-
- ## Rest of the class definition.
-
-=head1 DESCRIPTION
-
-Defines the base case for loading DBIC Schemas. We add in some additional
-helpful functions for administering you schemas. This namespace is dedicated
-to integration of Moose based development practices
-
-=head1 PACKAGE METHODS
-
-The following is a list of package methods declared with this class.
-
-=head2 load_components
-
-Components to preload.
-
-=cut
-
-__PACKAGE__->load_components(qw/
- PK::Auto
- InflateColumn::DateTime
- Core
-/);
-
-
-=head1 ATTRIBUTES
-
-This class defines the following attributes.
-
-=head1 METHODS
-
-This module declares the following methods
-
-=head2 new
-
-overload new to make sure we get a good meta object and that the attributes all
-get properly setup. This is done so that our instances properly get a L<Moose>
-meta class.
-
-=cut
-
-sub new
-{
- my $class = shift @_;
- my $attrs = shift @_;
-
- my $obj = $class->SUPER::new($attrs);
-
- return $class->meta->new_object(
- __INSTANCE__ => $obj, %$attrs
- );
-}
-
-
-=head1 AUTHORS
-
-See L<DBIx::Class> for more information regarding authors.
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
-
-
-1;
\ No newline at end of file
+++ /dev/null
-package #hide from pause
- DBICNGTest::Schema::Result::FriendList;
-
- use Moose;
- extends 'DBICNGTest::Schema::Result';
-
-
-=head1 NAME
-
-Zoomwit::tlib::DBIC::Schema::Result::FriendList; An example Friends Class;
-
-=head1 VERSION
-
-0.01
-
-=cut
-
-our $VERSION = '0.01';
-
-
-=head1 DESCRIPTION
-
-A Person can have zero or more friends
-A Person can't be their own friend
-A Person over 18 can't be friends with Persons under 18 and vis versa.
-A Person can have friendships that are not mutual.
-
-=head1 ATTRIBUTES
-
-This class defines the following attributes.
-
-=head1 PACKAGE METHODS
-
-This module defines the following package methods
-
-=head2 table
-
-Name of the Physical table in the database
-
-=cut
-
-__PACKAGE__
- ->table('friend_list');
-
-
-=head2 add_columns
-
-Add columns and meta information
-
-=head3 fk_person_id
-
-ID of the person with friends
-
-=head3 fk_friend_id
-
-Who is the friend?
-
-=cut
-
-__PACKAGE__
- ->add_columns(
- fk_person_id => {
- data_type=>'integer',
- },
- fk_friend_id => {
- data_type=>'integer',
- },
-);
-
-
-=head2 primary_key
-
-Sets the Primary keys for this table
-
-=cut
-
-__PACKAGE__
- ->set_primary_key(qw/fk_person_id fk_friend_id/);
-
-
-=head2 befriender
-
-The person that 'owns' the friendship (list)
-
-=cut
-
-__PACKAGE__
- ->belongs_to( befriender => 'DBICNGTest::Schema::Result::Person', {
- 'foreign.person_id' => 'self.fk_person_id' });
-
-
-=head2 friendee
-
-The actual friend that befriender is listing
-
-=cut
-
-__PACKAGE__
- ->belongs_to( friendee => 'DBICNGTest::Schema::Result::Person', {
- 'foreign.person_id' => 'self.fk_friend_id' });
-
-
-=head1 METHODS
-
-This module defines the following methods.
-
-=head1 AUTHORS
-
-See L<DBIx::Class> for more information regarding authors.
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
-
-
-1;
+++ /dev/null
-package #hide from pause
- DBICNGTest::Schema::Result::Gender;
-
- use Moose;
- extends 'DBICNGTest::Schema::Result';
-
-
-=head1 NAME
-
-DBICNGTest::Schema::Result::Gender; An example Gender Class;
-
-=head1 DESCRIPTION
-
-Tests for this type of FK relationship
-
-=head1 ATTRIBUTES
-
-This class defines the following attributes.
-
-=head2 label
-
-example of using an attribute to add constraints on a table insert
-
-=cut
-
-has 'label' =>(is=>'rw', required=>1, isa=>'Str');
-
-
-=head1 PACKAGE METHODS
-
-This module defines the following package methods
-
-=head2 table
-
-Name of the Physical table in the database
-
-=cut
-
-__PACKAGE__
- ->table('gender');
-
-
-=head2 add_columns
-
-Add columns and meta information
-
-=head3 gender_id
-
-Primary Key which is an auto generated UUID
-
-=head3 label
-
-Text label of the gender (ie, 'male', 'female', 'transgender', etc.).
-
-=cut
-
-__PACKAGE__
- ->add_columns(
- gender_id => {
- data_type=>'integer',
- },
- label => {
- data_type=>'varchar',
- size=>12,
- },
- );
-
-
-=head2 primary_key
-
-Sets the Primary keys for this table
-
-=cut
-
-__PACKAGE__
- ->set_primary_key(qw/gender_id/);
-
-
-=head2
-
-Marks the unique columns
-
-=cut
-
-__PACKAGE__
- ->add_unique_constraint('gender_label_unique' => [ qw/label/ ]);
-
-
-=head2 people
-
-A resultset of people with this gender
-
-=cut
-
-__PACKAGE__
- ->has_many(
- people => 'DBICNGTest::Schema::Result::Person',
- {'foreign.fk_gender_id' => 'self.gender_id'}
- );
-
-
-=head1 METHODS
-
-This module defines the following methods.
-
-=head1 AUTHORS
-
-See L<DBIx::Class> for more information regarding authors.
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
-
-
-1;
+++ /dev/null
-package #hide from pause
- DBICNGTest::Schema::Result::Person;
-
- use Moose;
- use DateTime;
- extends 'DBICNGTest::Schema::Result';
-
-
-=head1 NAME
-
-DBICNGTest::Schema::Result::Person; An example Person Class;
-
-=head1 DESCRIPTION
-
-Tests for this type of FK relationship
-
-=head1 ATTRIBUTES
-
-This class defines the following attributes.
-
-=head2 created
-
-attribute for the created column
-
-=cut
-
-has 'created' => (
- is=>'ro',
- isa=>'DateTime',
- required=>1,
- default=>sub {
- DateTime->now;
- },
-);
-
-
-=head1 PACKAGE METHODS
-
-This module defines the following package methods
-
-=head2 table
-
-Name of the Physical table in the database
-
-=cut
-
-__PACKAGE__
- ->table('person');
-
-
-=head2 add_columns
-
-Add columns and meta information
-
-=head3 person_id
-
-Primary Key which is an auto generated autoinc
-
-=head3 fk_gender_id
-
-foreign key to the Gender table
-
-=head3 name
-
-Just an ordinary name
-
-=head3 age
-
-The person's age
-
-head3 created
-
-When the person was added to the database
-
-=cut
-
-__PACKAGE__
- ->add_columns(
- person_id => {
- data_type=>'integer',
- },
- fk_gender_id => {
- data_type=>'integer',
- },
- name => {
- data_type=>'varchar',
- size=>32,
- },
- age => {
- data_type=>'integer',
- default_value=>25,
- },
- created => {
- data_type=>'datetime',
- default_value=>'date("now")',
- });
-
-
-=head2 primary_key
-
-Sets the Primary keys for this table
-
-=cut
-
-__PACKAGE__
- ->set_primary_key(qw/person_id/);
-
-
-=head2 friendlist
-
-Each Person might have a resultset of friendlist
-
-=cut
-
-__PACKAGE__
- ->has_many(
- friendlist => 'DBICNGTest::Schema::Result::FriendList',
- {'foreign.fk_person_id' => 'self.person_id'});
-
-
-=head2 gender
-
-This person's gender
-
-=cut
-
-__PACKAGE__
- ->belongs_to( gender => 'DBICNGTest::Schema::Result::Gender', {
- 'foreign.gender_id' => 'self.fk_gender_id' });
-
-
-=head2 fanlist
-
-A resultset of the people listing me as a friend (if any)
-
-=cut
-
-__PACKAGE__
- ->belongs_to( fanlist => 'DBICNGTest::Schema::Result::FriendList', {
- 'foreign.fk_friend_id' => 'self.person_id' });
-
-
-=head2 friends
-
-A resultset of Persons who are in my FriendList
-
-=cut
-
-__PACKAGE__
- ->many_to_many( friends => 'friendlist', 'friend' );
-
-
-=head2 fans
-
-A resultset of people that have me in their friendlist
-
-=cut
-
-__PACKAGE__
- ->many_to_many( fans => 'fanlist', 'befriender' );
-
-
-=head1 METHODS
-
-This module defines the following methods.
-
-=head1 AUTHORS
-
-See L<DBIx::Class> for more information regarding authors.
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
-
-
-1;
+++ /dev/null
-package # hide from PAUSE
- DBICNGTest::Schema::ResultSet;
-
- use Moose;
- extends 'DBIx::Class::ResultSet', 'Moose::Object';
-
-=head1 NAME
-
-DBICNGTest::Schema::ResultSet; A base ResultSet Class
-
-=head1 SYNOPSIS
-
- package DBICNGTest::Schema::ResultSet::Member;
-
- use Moose;
- extends 'DBICNGTest::Schema::ResultSet';
-
- ## Rest of the class definition.
-
-=head1 DESCRIPTION
-
-All ResultSet classes will inherit from this. This provides some base function
-for all your resultsets and it is also the default resultset if you don't
-bother to declare a custom resultset in the resultset namespace
-
-=head1 PACKAGE METHODS
-
-The following is a list of package methods declared with this class.
-
-=head1 ATTRIBUTES
-
-This class defines the following attributes.
-
-=head1 METHODS
-
-This module declares the following methods
-
-=head2 new
-
-overload new to make sure we get a good meta object and that the attributes all
-get properly setup. This is done so that our instances properly get a L<Moose>
-meta class.
-
-=cut
-
-sub new
-{
- my $class = shift @_;
- my $obj = $class->SUPER::new(@_);
-
- return $class->meta->new_object(
- __INSTANCE__ => $obj, @_
- );
-}
-
-
-=head1 AUTHORS
-
-See L<DBIx::Class> for more information regarding authors.
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
-
-
-1;
\ No newline at end of file
+++ /dev/null
-package # hide from pause
- DBICNGTest::Schema::ResultSet::Person;
-
- use Moose;
- extends 'DBICNGTest::Schema::ResultSet';
-
-
-=head1 NAME
-
-DBICNGTest::Schema::ResultSet:Person; Example Resultset
-
-=head1 VERSION
-
-0.01
-
-=cut
-
-our $VERSION = '0.01';
-
-
-=head1 SYNOPSIS
-
- ##Example Usage
-
-See Tests for more example usage.
-
-=head1 DESCRIPTION
-
-Resultset Methods for the Person Source
-
-=head1 ATTRIBUTES
-
-This class defines the following attributes.
-
-=head2 literal
-
-a literal attribute for testing
-
-=cut
-
-has 'literal' => (is=>'ro', isa=>'Str', required=>1, lazy=>1, default=>'hi');
-
-
-=head2 available_genders
-
-A resultset of the genders people can have. Keep in mind this get's run once
-only at the first compile, so it's only good for stuff that doesn't change
-between reboots.
-
-=cut
-
-has 'available_genders' => (
- is=>'ro',
- isa=>'DBICNGTest::Schema::ResultSet',
- required=>1,
- lazy=>1,
- default=> sub {
- shift
- ->result_source
- ->schema
- ->resultset('Gender');
- }
-);
-
-
-=head1 METHODS
-
-This module defines the following methods.
-
-=head2 older_than($int)
-
-Only people over a given age
-
-=cut
-
-sub older_than
-{
- my ($self, $age) = @_;
-
- return $self->search({age=>{'>'=>$age}});
-}
-
-
-=head1 AUTHORS
-
-See L<DBIx::Class> for more information regarding authors.
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
-
-
-1;
});
# in case this is a single-cd it promotes a track from another cd
-__PACKAGE__->belongs_to( single_track => 'DBICTest::Schema::Track' );
+__PACKAGE__->belongs_to( single_track => 'DBICTest::Schema::Track', 'single_track',
+ { join_type => 'left'}
+);
__PACKAGE__->has_many( tracks => 'DBICTest::Schema::Track' );
__PACKAGE__->has_many(
},
);
-
-#__PACKAGE__->add_relationship('genre', 'DBICTest::Schema::Genre',
-# { 'foreign.genreid' => 'self.genreid' },
-# { 'accessor' => 'single' }
-#);
-
1;
__PACKAGE__->add_columns(
id => { data_type => 'integer', is_auto_increment => 1 },
- starts_at => { data_type => 'datetime', extra => { timezone => "America/Chicago", locale => 'de_DE' } },
- created_on => { data_type => 'timestamp', extra => { timezone => "America/Chicago", floating_tz_ok => 1 } },
+ starts_at => { data_type => 'datetime', timezone => "America/Chicago", locale => 'de_DE' },
+ created_on => { data_type => 'timestamp', timezone => "America/Chicago", floating_tz_ok => 1 },
);
__PACKAGE__->set_primary_key('id');
--- /dev/null
+package DBICTest::Schema::EventTZDeprecated;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Core/;
+
+__PACKAGE__->load_components(qw/InflateColumn::DateTime/);
+
+__PACKAGE__->table('event');
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ starts_at => { data_type => 'datetime', extra => { timezone => "America/Chicago", locale => 'de_DE' } },
+ created_on => { data_type => 'timestamp', extra => { timezone => "America/Chicago", floating_tz_ok => 1 } },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Taint::Classes::Auto;
+
+use base 'DBIx::Class::Core';
+__PACKAGE__->table('test');
+
+1;
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Taint::Classes::Manual;
+
+use base 'DBIx::Class::Core';
+__PACKAGE__->table('test');
+
+1;
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Taint::Namespaces::Result::Test;
+
+use base 'DBIx::Class::Core';
+__PACKAGE__->table('test');
+
+1;
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Sun Feb 22 00:15:06 2009
+-- Created on Thu Apr 30 10:04:57 2009
--
--- /dev/null
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+use Data::Dumper;
+
+my $schema = DBICTest->init_schema();
+
+my $orig_debug = $schema->storage->debug;
+
+use IO::File;
+
+BEGIN {
+ eval "use DBD::SQLite";
+ plan $@
+ ? ( skip_all => 'needs DBD::SQLite for testing' )
+ : ( tests => 3 );
+}
+
+# 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
+my $is_broken_sqlite = 0;
+my ($sqlite_major_ver,$sqlite_minor_ver,$sqlite_patch_ver) =
+ split /\./, $schema->storage->dbh->get_info(18);
+if( $schema->storage->dbh->get_info(17) eq 'SQLite' &&
+ ( ($sqlite_major_ver < 3) ||
+ ($sqlite_major_ver == 3 && $sqlite_minor_ver < 2) ||
+ ($sqlite_major_ver == 3 && $sqlite_minor_ver == 2 && $sqlite_patch_ver < 6) ) ) {
+ $is_broken_sqlite = 1;
+}
+
+# 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);
+
+my $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');
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+use Data::Dumper;
+
+my $schema = DBICTest->init_schema();
+
+my $orig_debug = $schema->storage->debug;
+
+use IO::File;
+
+BEGIN {
+ eval "use DBD::SQLite";
+ plan $@
+ ? ( skip_all => 'needs DBD::SQLite for testing' )
+ : ( tests => 16 );
+}
+
+# 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
+my $is_broken_sqlite = 0;
+my ($sqlite_major_ver,$sqlite_minor_ver,$sqlite_patch_ver) =
+ split /\./, $schema->storage->dbh->get_info(18);
+if( $schema->storage->dbh->get_info(17) eq 'SQLite' &&
+ ( ($sqlite_major_ver < 3) ||
+ ($sqlite_major_ver == 3 && $sqlite_minor_ver < 2) ||
+ ($sqlite_major_ver == 3 && $sqlite_minor_ver == 2 && $sqlite_patch_ver < 6) ) ) {
+ $is_broken_sqlite = 1;
+}
+
+# once the following TODO is complete, remove the 2 warning tests immediately
+# after the TODO block
+# (the TODO block itself contains tests ensuring that the warns are removed)
+TODO: {
+ local $TODO = 'Prefetch of multiple has_many rels at the same level (currently warn to protect the clueless git)';
+
+ #( 1 -> M + M )
+ my $cd_rs = $schema->resultset('CD')->search ({ 'me.title' => 'Forkful of bees' });
+ my $pr_cd_rs = $cd_rs->search ({}, {
+ prefetch => [qw/tracks tags/],
+ });
+
+ my $tracks_rs = $cd_rs->first->tracks;
+ my $tracks_count = $tracks_rs->count;
+
+ my ($pr_tracks_rs, $pr_tracks_count);
+
+ my $queries = 0;
+ $schema->storage->debugcb(sub { $queries++ });
+ $schema->storage->debug(1);
+
+ my $o_mm_warn;
+ {
+ local $SIG{__WARN__} = sub { $o_mm_warn = shift };
+ $pr_tracks_rs = $pr_cd_rs->first->tracks;
+ };
+ $pr_tracks_count = $pr_tracks_rs->count;
+
+ ok(! $o_mm_warn, 'no warning on attempt to prefetch several same level has_many\'s (1 -> M + M)');
+
+ is($queries, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query');
+ is($pr_tracks_count, $tracks_count, 'equal count of prefetched relations over several same level has_many\'s (1 -> M + M)');
+
+ for ($pr_tracks_rs, $tracks_rs) {
+ $_->result_class ('DBIx::Class::ResultClass::HashRefInflator');
+ }
+
+ is_deeply ([$pr_tracks_rs->all], [$tracks_rs->all], 'same structure returned with and without prefetch over several same level has_many\'s (1 -> M + M)');
+
+ #( M -> 1 -> M + M )
+ my $note_rs = $schema->resultset('LinerNotes')->search ({ notes => 'Buy Whiskey!' });
+ my $pr_note_rs = $note_rs->search ({}, {
+ prefetch => {
+ cd => [qw/tags tracks/]
+ },
+ });
+
+ my $tags_rs = $note_rs->first->cd->tags;
+ my $tags_count = $tags_rs->count;
+
+ my ($pr_tags_rs, $pr_tags_count);
+
+ $queries = 0;
+ $schema->storage->debugcb(sub { $queries++ });
+ $schema->storage->debug(1);
+
+ my $m_o_mm_warn;
+ {
+ local $SIG{__WARN__} = sub { $m_o_mm_warn = shift };
+ $pr_tags_rs = $pr_note_rs->first->cd->tags;
+ };
+ $pr_tags_count = $pr_tags_rs->count;
+
+ ok(! $m_o_mm_warn, 'no warning on attempt to prefetch several same level has_many\'s (M -> 1 -> M + M)');
+
+ is($queries, 1, 'prefetch one->(has_many,has_many) ran exactly 1 query');
+
+ is($pr_tags_count, $tags_count, 'equal count of prefetched relations over several same level has_many\'s (M -> 1 -> M + M)');
+
+ for ($pr_tags_rs, $tags_rs) {
+ $_->result_class ('DBIx::Class::ResultClass::HashRefInflator');
+ }
+
+ is_deeply ([$pr_tags_rs->all], [$tags_rs->all], 'same structure returned with and without prefetch over several same level has_many\'s (M -> 1 -> M + M)');
+}
+
+# remove this closure once the TODO above is working
+my $w;
+{
+ local $SIG{__WARN__} = sub { $w = shift };
+
+ my $rs = $schema->resultset('CD')->search ({ 'me.title' => 'Forkful of bees' }, { prefetch => [qw/tracks tags/] });
+ for (qw/all count next first/) {
+ undef $w;
+ my @stuff = $rs->search()->$_;
+ like ($w, qr/will currently disrupt both the functionality of .rs->count\(\), and the amount of objects retrievable via .rs->next\(\)/,
+ "warning on ->$_ attempt prefetching several same level has_manys (1 -> M + M)");
+ }
+ my $rs2 = $schema->resultset('LinerNotes')->search ({ notes => 'Buy Whiskey!' }, { prefetch => { cd => [qw/tags tracks/] } });
+ for (qw/all count next first/) {
+ undef $w;
+ my @stuff = $rs2->search()->$_;
+ like ($w, qr/will currently disrupt both the functionality of .rs->count\(\), and the amount of objects retrievable via .rs->next\(\)/,
+ "warning on ->$_ attempt prefetching several same level has_manys (M -> 1 -> M + M)");
+ }
+}
+
+__END__
+The solution is to rewrite ResultSet->_collapse_result() and
+ResultSource->resolve_prefetch() to focus on the final results from the collapse
+of the data. Right now, the code doesn't treat the columns from the various
+tables as grouped entities. While there is a concept of hierarchy (so that
+prefetching down relationships does work as expected), there is no idea of what
+the final product should look like and how the various columns in the row would
+play together. So, the actual prefetch datastructure from the search would be
+very useful in working through this problem. We already have access to the PKs
+and sundry for those. So, when collapsing the search result, we know we are
+looking for 1 cd object. We also know we're looking for tracks and tags records
+-independently- of each other. So, we can grab the data for tracks and data for
+tags separately, uniqueing on the PK as appropriate. Then, when we're done with
+the given cd object's datastream, we know we're good. This should work for all
+the various scenarios.
+
+My reccommendation is the row's data is preprocessed first, breaking it up into
+the data for each of the component tables. (This could be done in the single
+table case, too, but probably isn't necessary.) So, starting with something
+like:
+ my $row = {
+ t1.col1 => 1,
+ t1.col2 => 2,
+ t2.col1 => 3,
+ t2.col2 => 4,
+ t3.col1 => 5,
+ t3.col2 => 6,
+ };
+it is massaged to look something like:
+ my $row_massaged = {
+ t1 => { col1 => 1, col2 => 2 },
+ t2 => { col1 => 3, col2 => 4 },
+ t3 => { col1 => 5, col2 => 6 },
+ };
+At this point, find the stuff that's different is easy enough to do and slotting
+things into the right spot is, likewise, pretty straightforward. Instead of
+storing things in a AoH, store them in a HoH keyed on the PKs of the the table,
+then convert to an AoH after all collapsing is done.
+
+This implies that the collapse attribute can probably disappear or, at the
+least, be turned into a boolean (which is how it's used in every other place).
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+use Data::Dumper;
+
+my $schema = DBICTest->init_schema();
+
+my $orig_debug = $schema->storage->debug;
+
+use IO::File;
+
+BEGIN {
+ eval "use DBD::SQLite";
+ plan $@
+ ? ( skip_all => 'needs DBD::SQLite for testing' )
+ : ( tests => 10 );
+}
+
+# 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
+my $is_broken_sqlite = 0;
+my ($sqlite_major_ver,$sqlite_minor_ver,$sqlite_patch_ver) =
+ split /\./, $schema->storage->dbh->get_info(18);
+if( $schema->storage->dbh->get_info(17) eq 'SQLite' &&
+ ( ($sqlite_major_ver < 3) ||
+ ($sqlite_major_ver == 3 && $sqlite_minor_ver < 2) ||
+ ($sqlite_major_ver == 3 && $sqlite_minor_ver == 2 && $sqlite_patch_ver < 6) ) ) {
+ $is_broken_sqlite = 1;
+}
+
+# A search() with prefetch seems to pollute an already joined resultset
+# in a way that offsets future joins (adapted from a test case by Debolaz)
+{
+ my ($cd_rs, $attrs);
+
+ # test a real-life case - rs is obtained by an implicit m2m join
+ $cd_rs = $schema->resultset ('Producer')->first->cds;
+ $attrs = Dumper $cd_rs->{attrs};
+
+ $cd_rs->search ({})->all;
+ is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search');
+
+ lives_ok (sub {
+ $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
+ is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch');
+ }, 'first prefetching search ok');
+
+ lives_ok (sub {
+ $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
+ is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch')
+ }, 'second prefetching search ok');
+
+
+ # test a regular rs with an empty seen_join injected - it should still work!
+ $cd_rs = $schema->resultset ('CD');
+ $cd_rs->{attrs}{seen_join} = {};
+ $attrs = Dumper $cd_rs->{attrs};
+
+ $cd_rs->search ({})->all;
+ is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search');
+
+ lives_ok (sub {
+ $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
+ is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch');
+ }, 'first prefetching search ok');
+
+ lives_ok (sub {
+ $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
+ is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch')
+ }, 'second prefetching search ok');
+}
--- /dev/null
+# Test to ensure we get a consistent result set wether or not we use the
+# prefetch option in combination rows (LIMIT).
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 2);
+
+my $schema = DBICTest->init_schema();
+my $no_prefetch = $schema->resultset('Artist')->search(
+ undef,
+ { rows => 3 }
+);
+
+my $use_prefetch = $schema->resultset('Artist')->search(
+ undef,
+ {
+ prefetch => 'cds',
+ rows => 3
+ }
+);
+
+my $no_prefetch_count = 0;
+my $use_prefetch_count = 0;
+
+is($no_prefetch->count, $use_prefetch->count, '$no_prefetch->count == $use_prefetch->count');
+
+TODO: {
+ local $TODO = "This is a difficult bug to fix, workaround is not to use prefetch with rows";
+ $no_prefetch_count++ while $no_prefetch->next;
+ $use_prefetch_count++ while $use_prefetch->next;
+ is(
+ $no_prefetch_count,
+ $use_prefetch_count,
+ "manual row count confirms consistency"
+ . " (\$no_prefetch_count == $no_prefetch_count, "
+ . " \$use_prefetch_count == $use_prefetch_count)"
+ );
+}
+
+__END__
+The fix is to, when using prefetch, take the query and put it into a subquery
+joined to the tables we're prefetching from. This might result in the same
+table being joined once in the main subquery and once in the main query. This
+may actually resolve other, unknown edgecase bugs. It is also the right way
+to do prefetching. Optimizations can come later.
+
+This means that:
+ $foo_rs->search(
+ { ... },
+ {
+ prefetch => 'bar',
+ ...
+ },
+ );
+
+becomes:
+ my $temp = $foo_rs->search(
+ { ... },
+ {
+ join => 'bar',
+ ...
+ },
+ );
+ $foo_rs->storage->schema->resultset('foo')->search(
+ undef,
+ {
+ from => [
+ { me => $temp->as_query },
+ ],
+ prefetch => 'bar',
+ },
+ );
+
+Problem:
+ * The prefetch->join change needs to happen ONLY IF there are conditions
+ that depend on bar being joined.
+ * How will this work when the $rs is further searched on? Those clauses
+ need to be added to the subquery, not the outer one. This is particularly
+ true if rows is added in the attribute later per the Pager.
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+use Data::Dumper;
+
+my $schema = DBICTest->init_schema();
+
+my $orig_debug = $schema->storage->debug;
+
+use IO::File;
+
+BEGIN {
+ eval "use DBD::SQLite";
+ plan $@
+ ? ( skip_all => 'needs DBD::SQLite for testing' )
+ : ( tests => 45 );
+}
+
+# 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
+my $is_broken_sqlite = 0;
+my ($sqlite_major_ver,$sqlite_minor_ver,$sqlite_patch_ver) =
+ split /\./, $schema->storage->dbh->get_info(18);
+if( $schema->storage->dbh->get_info(17) eq 'SQLite' &&
+ ( ($sqlite_major_ver < 3) ||
+ ($sqlite_major_ver == 3 && $sqlite_minor_ver < 2) ||
+ ($sqlite_major_ver == 3 && $sqlite_minor_ver == 2 && $sqlite_patch_ver < 6) ) ) {
+ $is_broken_sqlite = 1;
+}
+
+my $queries = 0;
+$schema->storage->debugcb(sub { $queries++; });
+$schema->storage->debug(1);
+
+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);
+
+my $rs = $schema->resultset("CD")->search($search, $attr);
+my @cd = $rs->all;
+
+is($cd[0]->title, 'Spoonful of bees', 'First record returned ok');
+
+ok(!defined $cd[0]->liner_notes, 'No prefetch for NULL LEFT join');
+
+is($cd[1]->{_relationship_data}{liner_notes}->notes, 'Buy Whiskey!', 'Prefetch for present LEFT JOIN');
+
+is(ref $cd[1]->liner_notes, 'DBICTest::LinerNotes', 'Prefetch returns correct class');
+
+is($cd[2]->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'Prefetch on parent object ok');
+
+is($queries, 1, 'prefetch ran only 1 select statement');
+
+$schema->storage->debug($orig_debug);
+$schema->storage->debugobj->callback(undef);
+
+# test for partial prefetch via columns attr
+my $cd = $schema->resultset('CD')->find(1,
+ {
+ columns => [qw/title artist artist.name/],
+ join => { 'artist' => {} }
+ }
+);
+ok(eval { $cd->artist->name eq 'Caterwauler McCrae' }, 'single related column prefetched');
+
+# start test for nested prefetch SELECT count
+$queries = 0;
+$schema->storage->debugcb(sub { $queries++ });
+$schema->storage->debug(1);
+
+$rs = $schema->resultset('Tag')->search(
+ {},
+ {
+ prefetch => { cd => 'artist' }
+ }
+);
+
+my $tag = $rs->first;
+
+is( $tag->cd->title, 'Spoonful of bees', 'step 1 ok for nested prefetch' );
+
+is( $tag->cd->artist->name, 'Caterwauler McCrae', 'step 2 ok for nested prefetch');
+
+# count the SELECTs
+#$selects++ if /SELECT(?!.*WHERE 1=0.*)/;
+is($queries, 1, 'nested prefetch ran exactly 1 select statement (excluding column_info)');
+
+$queries = 0;
+
+is($tag->search_related('cd')->search_related('artist')->first->name,
+ 'Caterwauler McCrae',
+ 'chained belongs_to->belongs_to search_related ok');
+
+is($queries, 0, 'chained search_related after belontgs_to->belongs_to prefetch ran no queries');
+
+$queries = 0;
+
+$cd = $schema->resultset('CD')->find(1, { prefetch => 'artist' });
+
+is($cd->{_inflated_column}{artist}->name, 'Caterwauler McCrae', 'artist prefetched correctly on find');
+
+is($queries, 1, 'find with prefetch ran exactly 1 select statement (excluding column_info)');
+
+$queries = 0;
+
+$schema->storage->debugcb(sub { $queries++; });
+
+$cd = $schema->resultset('CD')->find(1, { prefetch => { cd_to_producer => 'producer' } });
+
+is($cd->producers->first->name, 'Matt S Trout', 'many_to_many accessor ok');
+
+is($queries, 1, 'many_to_many accessor with nested prefetch ran exactly 1 query');
+
+$queries = 0;
+
+my $producers = $cd->search_related('cd_to_producer')->search_related('producer');
+
+is($producers->first->name, 'Matt S Trout', 'chained many_to_many search_related ok');
+
+is($queries, 0, 'chained search_related after many_to_many prefetch ran no queries');
+
+$schema->storage->debug($orig_debug);
+$schema->storage->debugobj->callback(undef);
+
+$rs = $schema->resultset('Tag')->search(
+ {},
+ {
+ join => { cd => 'artist' },
+ prefetch => { cd => 'artist' }
+ }
+);
+
+cmp_ok( $rs->count, '>=', 0, 'nested prefetch does not duplicate joins' );
+
+my ($artist) = $schema->resultset("Artist")->search({ 'cds.year' => 2001 },
+ { order_by => 'artistid DESC', join => 'cds' });
+
+is($artist->name, 'Random Boy Band', "Join search by object ok");
+
+my @cds = $schema->resultset("CD")->search({ 'liner_notes.notes' => 'Buy Merch!' },
+ { join => 'liner_notes' });
+
+cmp_ok(scalar @cds, '==', 1, "Single CD retrieved via might_have");
+
+is($cds[0]->title, "Generic Manufactured Singles", "Correct CD retrieved");
+
+my @artists = $schema->resultset("Artist")->search({ 'tags.tag' => 'Shiny' },
+ { join => { 'cds' => 'tags' } });
+
+cmp_ok( @artists, '==', 2, "two-join search ok" );
+
+$rs = $schema->resultset("CD")->search(
+ {},
+ { group_by => [qw/ title me.cdid /] }
+);
+
+SKIP: {
+ skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
+ if $is_broken_sqlite;
+ cmp_ok( $rs->count, '==', 5, "count() ok after group_by on main pk" );
+}
+
+cmp_ok( scalar $rs->all, '==', 5, "all() returns same count as count() after group_by on main pk" );
+
+$rs = $schema->resultset("CD")->search(
+ {},
+ { join => [qw/ artist /], group_by => [qw/ artist.name /] }
+);
+
+SKIP: {
+ skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
+ if $is_broken_sqlite;
+ cmp_ok( $rs->count, '==', 3, "count() ok after group_by on related column" );
+}
+
+$rs = $schema->resultset("Artist")->search(
+ {},
+ { join => [qw/ cds /], group_by => [qw/ me.name /], having =>{ 'MAX(cds.cdid)'=> \'< 5' } }
+);
+
+cmp_ok( $rs->all, '==', 2, "results ok after group_by on related column with a having" );
+
+$rs = $rs->search( undef, { having =>{ 'count(*)'=> \'> 2' }});
+
+cmp_ok( $rs->all, '==', 1, "count() ok after group_by on related column with a having" );
+
+$rs = $schema->resultset("Artist")->search(
+ { 'cds.title' => 'Spoonful of bees',
+ 'cds_2.title' => 'Forkful of bees' },
+ { join => [ 'cds', 'cds' ] });
+
+SKIP: {
+ skip "SQLite < 3.2.6 doesn't understand COUNT(DISTINCT())", 1
+ if $is_broken_sqlite;
+ cmp_ok($rs->count, '==', 1, "single artist returned from multi-join");
+}
+
+is($rs->next->name, 'Caterwauler McCrae', "Correct artist returned");
+
+$cd = $schema->resultset('Artist')->first->create_related('cds',
+ {
+ title => 'Unproduced Single',
+ year => 2007
+});
+
+my $left_join = $schema->resultset('CD')->search(
+ { 'me.cdid' => $cd->cdid },
+ { prefetch => { cd_to_producer => 'producer' } }
+);
+
+cmp_ok($left_join, '==', 1, 'prefetch with no join record present');
+
+$queries = 0;
+$schema->storage->debugcb(sub { $queries++ });
+$schema->storage->debug(1);
+
+my $tree_like =
+ $schema->resultset('TreeLike')->find(5,
+ { join => { parent => { parent => 'parent' } },
+ prefetch => { parent => { parent => 'parent' } } });
+
+is($tree_like->name, 'quux', 'Bottom of tree ok');
+$tree_like = $tree_like->parent;
+is($tree_like->name, 'baz', 'First level up ok');
+$tree_like = $tree_like->parent;
+is($tree_like->name, 'bar', 'Second level up ok');
+$tree_like = $tree_like->parent;
+is($tree_like->name, 'foo', 'Third level up ok');
+
+$schema->storage->debug($orig_debug);
+$schema->storage->debugobj->callback(undef);
+
+cmp_ok($queries, '==', 1, 'Only one query run');
+
+$tree_like = $schema->resultset('TreeLike')->search({'me.id' => 2});
+$tree_like = $tree_like->search_related('children')->search_related('children')->search_related('children')->first;
+is($tree_like->name, 'quux', 'Tree search_related ok');
+
+$tree_like = $schema->resultset('TreeLike')->search_related('children',
+ { 'children.id' => 3, 'children_2.id' => 4 },
+ { prefetch => { children => 'children' } }
+ )->first;
+is(eval { $tree_like->children->first->children->first->name }, 'quux',
+ 'Tree search_related with prefetch ok');
+
+$tree_like = eval { $schema->resultset('TreeLike')->search(
+ { 'children.id' => 3, 'children_2.id' => 6 },
+ { join => [qw/children children/] }
+ )->search_related('children', { 'children_4.id' => 7 }, { prefetch => 'children' }
+ )->first->children->first; };
+is(eval { $tree_like->name }, 'fong', 'Tree with multiple has_many joins ok');
+
+# test that collapsed joins don't get a _2 appended to the alias
+
+my $sql = '';
+$schema->storage->debugcb(sub { $sql = $_[1] });
+$schema->storage->debug(1);
+
+eval {
+ my $row = $schema->resultset('Artist')->search_related('cds', undef, {
+ join => 'tracks',
+ prefetch => 'tracks',
+ })->search_related('tracks')->first;
+};
+
+like( $sql, qr/^SELECT tracks_2\.trackid/, "join not collapsed for search_related" );
+
+$schema->storage->debug($orig_debug);
+$schema->storage->debugobj->callback(undef);
+
+$rs = $schema->resultset('Artist');
+$rs->create({ artistid => 4, name => 'Unknown singer-songwriter' });
+$rs->create({ artistid => 5, name => 'Emo 4ever' });
+@artists = $rs->search(undef, { prefetch => 'cds', order_by => 'artistid' });
+is(scalar @artists, 5, 'has_many prefetch with adjacent empty rows ok');
+
+# -------------
+#
+# Tests for multilevel has_many prefetch
+
+# artist resultsets - with and without prefetch
+my $art_rs = $schema->resultset('Artist');
+my $art_rs_pr = $art_rs->search(
+ {},
+ {
+ join => [ { cds => ['tracks'] } ],
+ prefetch => [ { cds => ['tracks'] } ],
+ cache => 1 # last test needs this
+ }
+);
+
+# This test does the same operation twice - once on a
+# set of items fetched from the db with no prefetch of has_many rels
+# The second prefetches 2 levels of has_many
+# We check things are the same by comparing the name or title
+# we build everything into a hash structure and compare the one
+# from each rs to see what differs
+
+sub make_hash_struc {
+ my $rs = shift;
+
+ my $struc = {};
+ foreach my $art ( $rs->all ) {
+ foreach my $cd ( $art->cds ) {
+ foreach my $track ( $cd->tracks ) {
+ $struc->{ $art->name }{ $cd->title }{ $track->title }++;
+ }
+ }
+ }
+ return $struc;
+}
+
+$queries = 0;
+$schema->storage->debugcb(sub { $queries++ });
+$schema->storage->debug(1);
+
+my $prefetch_result = make_hash_struc($art_rs_pr);
+
+is($queries, 1, 'nested prefetch across has_many->has_many ran exactly 1 query');
+
+my $nonpre_result = make_hash_struc($art_rs);
+
+is_deeply( $prefetch_result, $nonpre_result,
+ 'Compare 2 level prefetch result to non-prefetch result' );
+
+$queries = 0;
+
+is($art_rs_pr->search_related('cds')->search_related('tracks')->first->title,
+ 'Fowlin',
+ 'chained has_many->has_many search_related ok'
+ );
+
+is($queries, 0, 'chained search_related after has_many->has_many prefetch ran no queries');
+
use Test::More;
-BEGIN {
- eval "use SQL::Abstract 1.49";
- plan $@
- ? ( skip_all => "Needs SQLA 1.49+" )
- : ( tests => 4 );
-}
+plan ( tests => 5 );
use lib qw(t/lib);
use DBICTest;
);
}
+{
+ my $rs = $schema->resultset("CD")->search(
+ { 'artist.name' => 'Caterwauler McCrae' },
+ { join => [qw/artist/]}
+ );
+ my $subsel_rs = $schema->resultset("CD")->search( { cdid => { IN => $rs->get_column('cdid')->as_query } } );
+ cmp_ok($subsel_rs->count, '==', $rs->count, 'Subselect on PK got the same row count');
+}
+
__END__
use Test::More;
-BEGIN {
- eval "use SQL::Abstract 1.49";
- plan $@
- ? ( skip_all => "Needs SQLA 1.49+" )
- : ( tests => 8 );
-}
+plan ( tests => 8 );
use lib qw(t/lib);
use DBICTest;
my ($query, @bind) = @{$$arr};
is_same_sql_bind(
$query, \@bind,
- "SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE artist_id IN ( SELECT id FROM artist me LIMIT 1 )",
+ "( SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE artist_id IN ( SELECT id FROM artist me LIMIT 1 ) )",
[],
);
}
my ($query, @bind) = @{$$arr};
is_same_sql_bind(
$query, \@bind,
- "SELECT (SELECT id FROM cd me LIMIT 1) FROM artist me",
+ "( SELECT (SELECT id FROM cd me LIMIT 1) FROM artist me )",
[],
);
}
my ($query, @bind) = @{$$arr};
is_same_sql_bind(
$query, \@bind,
- "SELECT me.artistid, me.name, me.rank, me.charfield, (SELECT id FROM cd me LIMIT 1) FROM artist me",
+ "( SELECT me.artistid, me.name, me.rank, me.charfield, (SELECT id FROM cd me LIMIT 1) FROM artist me )",
[],
);
}
my ($query, @bind) = @{$$arr};
is_same_sql_bind(
$query, \@bind,
- "SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE id > 20) cd2",
- [],
+ "( SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE id > ?) cd2 )",
+ [
+ [ 'id', 20 ]
+ ],
);
}
my ($query, @bind) = @{$$arr};
is_same_sql_bind(
$query, \@bind,
- "SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me JOIN (SELECT me.artist as cds_artist FROM cd me) cds ON me.artistid = cds_artist", []
+ "( SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me JOIN (SELECT me.artist as cds_artist FROM cd me) cds ON me.artistid = cds_artist )", []
);
my ($query, @bind) = @{$$arr};
is_same_sql_bind(
$query, \@bind,
- "SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track
+ "( SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track
FROM
(SELECT cd3.cdid,cd3.artist,cd3.title,cd3.year,cd3.genreid,cd3.single_track
FROM
(SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track
- FROM cd me WHERE id < 40) cd3
- WHERE id > 20) cd2",
- [],
+ FROM cd me WHERE id < ?) cd3
+ WHERE id > ?) cd2
+ )",
+ [
+ [ 'id', 40 ],
+ [ 'id', 20 ]
+ ],
);
}
my ($query, @bind) = @{$$arr};
is_same_sql_bind(
$query, \@bind,
- "SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE year = (SELECT MAX(inner.year) FROM cd inner WHERE artistid = me.artistid)",
+ "( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE year = (SELECT MAX(inner.year) FROM cd inner WHERE artistid = me.artistid) )",
[],
);
}
my ($query, @bind) = @{$$arr};
is_same_sql_bind(
$query, \@bind,
- "SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE title = 'Thriller') cd2",
- [],
+ "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (SELECT me.cdid,me.artist,me.title,me.year,me.genreid,me.single_track FROM cd me WHERE title = ?) cd2)",
+ ['Thriller'],
);
}
projects / dbsrgits/DBIx-Class.git / commitdiff