From: Peter Rabbitson Date: Thu, 14 Feb 2013 04:58:09 +0000 (+0100) Subject: Merge branch 'master' into topic/constructor_rewrite X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0077982b2edc8273ab4b6ea59921177667008cb3;hp=977f88cb4a2a252c91a6b4233bc4de59b702b9c1;p=dbsrgits%2FDBIx-Class-Historic.git Merge branch 'master' into topic/constructor_rewrite --- diff --git a/.gitignore b/.gitignore index e019e8a..80fc61d 100644 --- a/.gitignore +++ b/.gitignore @@ -9,9 +9,12 @@ Makefile.old _build/ blib/ inc/ -lib/DBIx/Class/Optional/Dependencies.pod DBIx-Class-*/ DBIx-Class-*.tar.* pm_to_blib t/var/ .*.sw? +*# +.#* +*~ +maint/.Generated_Pod diff --git a/.mailmap b/.mailmap index c6795db..02a82d5 100644 --- a/.mailmap +++ b/.mailmap @@ -2,7 +2,26 @@ # so if someone were to legally change their name, we could use it to fix that # while maintaining the integrity of the repository -# I've mapped the old single quote version of my name to the double quote -# version for consistency -Arthur Axel "fREW" Schmidt Arthur Axel 'fREW' Schmidt -Andrew Rodland Andrew Rodland \ No newline at end of file +Alexander Hartmaier +Amiri Barksdale +Andrew Rodland +Arthur Axel "fREW" Schmidt +Brendan Byrd +Brendan Byrd +Brendan Byrd +Brian Phillips +David Kamholz +David Schmidt +Devin Austin +Felix Antonius Wilhelm Ostmann +Gerda Shank +Gianni Ceccarelli +Gordon Irving +Hakim Cassimally +Jonathan Chu +Matt Phillips +Roman Filippov +Peter Rabbitson +Tim Bunce +Toby Corkindale +Wallace Reis diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..fcf7acc --- /dev/null +++ b/.travis.yml @@ -0,0 +1,163 @@ +# Some overall notes on how this works +# +# * We smoke using the system provided latest, and custom built "oddball perls" +# The reason for not having a blanket matrix is to conserve travis resources +# as a full DBIC depchain isn't cheap +# +# * Minimum perl officially supported by DBIC is 5.8.3. This *includes* the +# basic depchain. On failure either attempt to fix it or bring it to the +# attention of ribasushi. *DO NOT* disable 5.8 testing - it is here for a +# reason +# +# * The matrix is built from two main modes - CLEANTEST = [true|false]. +# - In the first case we test with minimal deps available, and skip everything +# listed in DBIC::OptDesps. The modules are installed with classic CPAN +# invocations and are *fully tested*. In other words we simulate what would +# happen if a user tried to install on a just-compiled virgin perl +# - Without CLEANTEST we bring the armada of RDBMS and install the maximum +# possible set of deps *without testing them*. This ensures we stay within +# a reasonable build-time and still run as many of our tests as possible +# +# * The perl builds and the DBIC tests run under NUMTHREADS number of threads. +# The testing of dependencies under CLEANTEST runs single-threaded, at least +# until we fix our entire dep-chain to safely pass under -j +# +# * The way .travis.yml is fed to the command controller is idiotic - it +# makes using multiline `bash -c` statements impossible. Therefore to +# aid readability (our travis logic is rather complex), the bulk of +# functionality is moved to scripts. More about the problem (and the +# WONTFIX "explanation") here: https://github.com/travis-ci/travis-ci/issues/497 +# + +# +# Smoke only specific branches to a) not overload the queue and b) not +# overspam the notification channels +# +# Furthermore if the branch is ^topic/ - the custom compiled smokes will +# not run at all, again in order to conserve queue resources +# +# Additionally bleadperl tests do not run on master (but do run on smoke/*) +# +branches: + only: + - master + - /^smoke\// + - /^topic\// + +notifications: + irc: + channels: + - "irc.perl.org#dbic-smoke" + template: + - "%{branch}#%{build_number} by %{author}: %{message} (%{build_url})" + on_success: change + on_failure: always + use_notice: true + + email: + recipients: + - ribasushi@cpan.org + # Temporary - if it proves to be too noisy, we'll shut it off + #- dbix-class-devel@lists.scsys.co.uk + on_success: change + on_failure: change + +language: perl + +perl: + - "5.16" + +env: + - CLEANTEST=false + - CLEANTEST=true + +matrix: + include: + # bleadperl + - perl: bleadperl_thr_mb + env: + - CLEANTEST=false + - BREWOPTS="-Duseithreads -Dusemorebits" + - BREWVER=blead + + # minimum supported with threads + - perl: 5.8.5_thr + env: + - CLEANTEST=false + - BREWOPTS="-Duseithreads" + - BREWVER=5.8.5 + + # minimum supported without threads + - perl: 5.8.3_nt + env: + - CLEANTEST=false + - BREWOPTS="" + - BREWVER=5.8.3 + + # check CLEANTEST of minimum supported + - perl: 5.8.3_nt_mb + env: + - CLEANTEST=true + - BREWOPTS="-Dusemorebits" + - BREWVER=5.8.3 + + # this is the perl suse ships + - perl: 5.10.0_thr_dbg + env: + - CLEANTEST=true + - BREWOPTS="-DDEBUGGING -Duseithreads" + - BREWVER=5.10.0 + + # this particular perl is quite widespread + - perl: 5.8.8_thr_mb + env: + - CLEANTEST=true + - BREWOPTS="-Duseithreads -Dusemorebits" + - BREWVER=5.8.8 + +# sourcing the files is *EXTREMELY* important - otherwise +# no envvars will survive + +# the entire run times out after 50 minutes, or after 5 minutes without +# console output + +before_install: + # Sets global envvars, downloads/configures debs based on CLEANTEST + # Sets extra DBICTEST_* envvars + # + - source maint/travis-ci_scripts/10_before_install.bash + +install: + # Build and switch to a custom perl if requested + # Configure the perl env, preinstall some generic toolchain parts + # + - source maint/travis-ci_scripts/20_install.bash + +before_script: + # Preinstall/install deps based on envvars/CLEANTEST + # + - source maint/travis-ci_scripts/30_before_script.bash + +script: + # Run actual tests + # + - source maint/travis-ci_scripts/40_script.bash + +after_success: + # Check if we can assemble a dist properly if not in CLEANTEST + # + - source maint/travis-ci_scripts/50_after_success.bash + +after_failure: + # No tasks yet + # + #- source maint/travis-ci_scripts/50_after_failure.bash + +after_script: + # No tasks yet + # + #- source maint/travis-ci_scripts/60_after_script.bash + + # if we do not unset this before we terminate the travis teardown will + # mark the entire job as failed + - set +e diff --git a/Changes b/Changes index f3515dc..6eacbb1 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,93 @@ Revision history for DBIx::Class + * Fixes + - Fix duplicated selected columns when calling 'count' when a same + aggregate function is used more than once in a 'having' clause + (RT#83305) + + * Misc + - Fixup our distbuilding process to stop creating world-writable + tarball contents (implicitly fixes RT#83084) + - Added strict and warnings tests for all lib and test files + +0.08206 2013-02-08 + * Fixes + - Fix dbh_do() failing to properly reconnect (regression in 0.08205) + - Extra sanity check of a fresh DBI handle ($dbh). Fixes + connection coderefs returning garbage (seen in the wild) + + * Misc + - Only allow known globals in SQL::Translator leak allowance + - General cleanup of error message texts - quote names/identifiers + for easier reading + - Stop t/52leaks.t from failing when AUTOMATED_TESTING=1 + +0.08205 2013-01-22 + * New Features / Changes + - The emulate_limit() arbitrary limit dialect emulation mechanism is + now deprecated, and will be removed when DBIx::Class migrates to + Data::Query + - Support for the source_bind_attributes() storage method has been + removed after a lengthy deprecation cycle + * Fixes + - When performing resultset update/delete only strip condition + qualifiers - leave the source name alone (RT#80015, RT#78844) + - Fix incorrect behavior on resultset update/delete invoked on + composite resultsets (e.g. as_subselect_rs) + - Fix update/delete operations referencing the updated table failing + on MySQL, due to its refusal to modify a table being directly + queried. As a workaround induce in-memory temp-table creation + (RT#81378, RT#81897) + - More robust behavior under heavily threaded environments - make + sure we do not have refaddr reuse in the global storage registry + - Fix failing test on 5.8 under Win32 (RT#81114) + - Fix hash-randomization test issues (RT#81638) + - Disallow erroneous calling of connect_info on a replicated storage + (RT#78436) + * Misc + - Improve the populate docs in ::Schema and ::ResultSet + - ::Storage::DBI::source_bind_attributes() removed as announced + on Jan 2011 in 0e773352a + +0.08204 2012-11-08 + * New Features / Changes + - SQLMaker now accepts \'literal' with the 'for' rs attribute as an + override to the builtin FOR options + * Fixes + - Fix unique constraint violations in Ordered.pm blanket movement + (RT#79773, rolls back short-sighted 5e6fde33e) + - Fix API mismatch between new_result() and new_related() (originally + broken by fea3d045) + - Fix test failure on perl 5.8 + * Misc + - Much more extensive diagnostics when a new RDBMS/DSN combination is + encountered (RT#80431) + +0.08203 2012-10-18 + * Fixes + - Really fix inadequate $dbh->ping SQLite implementation (what shipped + in 0.08201 tickled other deficiencies in DBD::SQLite itself) + +0.08202 2012-10-06 + * Fixes + - Replace inadequate $dbh->ping SQLite implementation with our own, + fixes RT#78420 + +0.08200 2012-08-24 (UTC) + * Fixes + - Change one of the new tests for the previous release to not require + SQL::Translator + +0.08199 2012-08-22 (UTC) + * Fixes + - Roll back incomplete (and broken) internal changes - restore prefetch functionality + +0.08198 2012-07-11 03:43 (UTC) + * Fixes + - Fix a number of Win32 Test issues + - Fix silent Oracle connection failures + +0.08197 2012-07-10 10:32 (UTC) * New Features / Changes - Issue a warning when DateTime objects are passed to ->search - Fast populate() in void context is now even more efficient by @@ -18,6 +106,8 @@ Revision history for DBIx::Class - Nomalization of retrieved GUID values * Fixes + - Fix complex has_many prefetch with resultsets not selecting identity + columns from the root result source - Fix SkipFirst and FirstSkip limit dialects (Informix and Firebird) - Fix "Skimming limit" dialects (Top, FetchFirst) to properly check the order_by criteria for stability diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index f6c1759..5f0567e 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -26,3 +26,5 @@ \.orig$ \.rej$ +lib/DBIx/Class/Manual/ResultClass.pod.proto +maint/.Generated_Pod diff --git a/Makefile.PL b/Makefile.PL index d4d11e3..1b45288 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -12,11 +12,20 @@ use inc::Module::Install 1.06; # for that) BEGIN { $Module::Install::AUTHOR = 0 if (grep { $ENV{"PERL5_${_}_IS_RUNNING"} } (qw/CPANM CPANPLUS CPAN/) ); + makemaker_args( NORECURS => 1 ); } +homepage 'http://www.dbix-class.org/'; +resources 'IRC' => 'irc://irc.perl.org/#dbix-class'; +resources 'license' => 'http://dev.perl.org/licenses/'; +resources 'repository' => 'https://github.com/dbsrgits/DBIx-Class'; +resources 'MailingList' => 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class'; +resources 'bugtracker' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class'; + name 'DBIx-Class'; perl_version '5.008001'; all_from 'lib/DBIx/Class.pm'; +Meta->{values}{x_authority} = 'cpan:RIBASUSHI'; tests_recursive (qw| t @@ -26,53 +35,55 @@ install_script (qw| script/dbicadmin |); -homepage 'http://www.dbix-class.org/'; -resources 'IRC' => 'irc://irc.perl.org/#dbix-class'; -resources 'license' => 'http://dev.perl.org/licenses/'; -resources 'repository' => 'git://git.shadowcat.co.uk/dbsrgits/DBIx-Class.git'; -resources 'MailingList' => 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class'; -resources 'bugtracker' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class'; - ### ### DO NOT ADD OPTIONAL DEPENDENCIES HERE, EVEN AS recommends() ### All of them *MUST* go to DBIx::Class::Optional::Dependencies ### my $runtime_requires = { + # FIXME - temporary workaround for RT#83143 (Path::Class) + 'File::Spec' => '3.30', + # FIXME - temporary, needs throwing out for something more efficient 'Data::Compare' => '1.22', - # Moo does not yet depend on this higher version - 'strictures' => '1.003001', - # DBI itself should be capable of installation and execution in pure-perl # mode. However it has never been tested yet, so consider XS for the time # being 'DBI' => '1.57', + # on older versions first() leaks + # for the time being make it a hard dep - when we get + # rid of Sub::Name will revisit this (possibility is + # to use Devel::HideXS to force the pure-perl version + # or something like that) + 'List::Util' => '1.16', + # XS (or XS-dependent) libs 'Sub::Name' => '0.04', # pure-perl (FatPack-able) libs - 'Class::Accessor::Grouped' => '0.10002', + 'Class::Accessor::Grouped' => '0.10009', 'Class::C3::Componentised' => '1.0009', 'Class::Inspector' => '1.24', - 'Class::Method::Modifiers' => '1.06', 'Config::Any' => '0.20', 'Context::Preserve' => '0.01', 'Data::Dumper::Concise' => '2.020', 'Data::Page' => '2.00', + 'Devel::GlobalDestruction' => '0.09', 'Hash::Merge' => '0.12', - 'Moo' => '0.009014', - 'MRO::Compat' => '0.09', - 'Module::Find' => '0.06', - 'namespace::clean' => '0.20', + 'Moo' => '1.000006', + 'MRO::Compat' => '0.12', + 'Module::Find' => '0.07', + 'namespace::clean' => '0.24', 'Path::Class' => '0.18', 'Scope::Guard' => '0.03', - 'SQL::Abstract' => '1.72', - 'Try::Tiny' => '0.04', + 'SQL::Abstract' => '1.73', + 'Try::Tiny' => '0.07', - # dual-life corelibs needing a specific bugfixed version - 'File::Path' => '2.07', + # Technically this is not a core dependency - it is only required + # by the MySQL codepath. However this particular version is bundled + # since 5.10.0 and is a pure-perl module anyway - let it slide + 'Text::Balanced' => '2.00', }; my $build_requires = { @@ -144,20 +155,44 @@ if ($Module::Install::AUTHOR and ! $ENV{MAKELEVEL}) { warn "\nIgnoring unrecognized option(s): @ARGV\n\n"; } + # We need the MM facilities to generate the pieces for the final MM run. + # Just instantiate a throaway object here + my $mm_proto = ExtUtils::MakeMaker->new({ + NORECURS => 1, + NAME => Meta->name || die 'The Module::Install metadata must be available at this point but is not - did you rearrange the Makefile.PL...?', + }); + + # Crutch for DISTBUILDING_IN_HELL + # Spits back a working dos2unix snippet to be used on the supplied path(s) + # Ironically EUMM's dos2unix is broken on win32 itself - it does + # not take into account the CRLF layer present on win32 + my $crlf_fixup = sub { + return '' unless ($^O eq 'MSWin32' or $^O eq 'cygwin'); + my $targets = join ', ', map { "q($_)" } @_; + "\t" . $mm_proto->oneliner( qq(\$ENV{PERLIO}='unix' and system( \$^X, qw( -MExtUtils::Command -e dos2unix -- ), $targets ) ) ); + }; + + # we are in the process of (re)writing the makefile - some things we + # call below very well may fail + local $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION} = 1; + require File::Spec; # string-eval, not do(), because we need to provide the - # $reqs and $*_requires lexicals to the included file + # $mm_proto, $reqs and $*_requires lexicals to the included file # (some includes *do* modify $reqs above) - for (sort glob ( File::Spec->catfile('maint', 'Makefile.PL.inc', '*') ) ) { - eval scalar do { local (@ARGV, $/) = $_; <> } - or die ($@ || $!); + for my $inc (sort glob ( File::Spec->catfile('maint', 'Makefile.PL.inc', '*') ) ) { + my $src = do { local (@ARGV, $/) = $inc; <> } or die $!; + eval "use warnings; use strict; $src" or die sprintf + "Failed execution of %s: %s\n", + $inc, + ($@ || $! || 'Unknown error'), + ; } } else { # make sure this Makefile can not be used to make a dist # (without the author includes there are no meta cleanup, no sanity checks, etc) postamble <load_namespaces; diff --git a/examples/Schema/db/example.sql b/examples/Schema/db/example.sql index 13d9b39..4bc6cb6 100644 --- a/examples/Schema/db/example.sql +++ b/examples/Schema/db/example.sql @@ -1,6 +1,6 @@ CREATE TABLE artist ( artistid INTEGER PRIMARY KEY, - name TEXT NOT NULL + name TEXT NOT NULL ); CREATE TABLE cd ( @@ -13,4 +13,4 @@ CREATE TABLE track ( trackid INTEGER PRIMARY KEY, cd INTEGER NOT NULL REFERENCES cd(cdid), title TEXT NOT NULL -); \ No newline at end of file +); diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index d0d9d0b..eafc15a 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -11,7 +11,7 @@ our $VERSION; # $VERSION declaration must stay up here, ahead of any other package # declarations, as to not confuse various modules attempting to determine # this ones version, whether that be s.c.o. or Module::Metadata, etc -$VERSION = '0.08196'; +$VERSION = '0.08206'; $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases @@ -19,48 +19,37 @@ BEGIN { package # hide from pause DBIx::Class::_ENV_; - if ($] < 5.009_005) { - require MRO::Compat; - *OLD_MRO = sub () { 1 }; - } - else { - require mro; - *OLD_MRO = sub () { 0 }; - } - - # ::Runmode would only be loaded by DBICTest, which in turn implies t/ - *DBICTEST = eval { DBICTest::RunMode->is_author } - ? sub () { 1 } - : sub () { 0 } - ; + use Config; - # There was a brief period of p5p insanity when $@ was invisible in a DESTROY - *INVISIBLE_DOLLAR_AT = ($] >= 5.013001 and $] <= 5.013007) - ? sub () { 1 } - : sub () { 0 } - ; + use constant { - # During 5.13 dev cycle HELEMs started to leak on copy - *PEEPEENESS = (defined $ENV{DBICTEST_ALL_LEAKS} - # request for all tests would force "non-leaky" illusion and vice-versa - ? ! $ENV{DBICTEST_ALL_LEAKS} + # but of course + BROKEN_FORK => ($^O eq 'MSWin32') ? 1 : 0, - # otherwise confess that this perl is busted ONLY on smokers - : do { - if (eval { DBICTest::RunMode->is_smoker }) { + HAS_ITHREADS => $Config{useithreads} ? 1 : 0, - # leaky 5.13.6 (fixed in blead/cefd5c7c) - if ($] == '5.013006') { 1 } + # ::Runmode would only be loaded by DBICTest, which in turn implies t/ + DBICTEST => eval { DBICTest::RunMode->is_author } ? 1 : 0, - # not sure why this one leaks, but disable anyway - ANDK seems to make it weep - elsif ($] == '5.013005') { 1 } - - else { 0 } - } - else { 0 } - } - ) ? sub () { 1 } : sub () { 0 }; + # During 5.13 dev cycle HELEMs started to leak on copy + PEEPEENESS => + # request for all tests would force "non-leaky" illusion and vice-versa + defined $ENV{DBICTEST_ALL_LEAKS} ? !$ENV{DBICTEST_ALL_LEAKS} + # otherwise confess that this perl is busted ONLY on smokers + : eval { DBICTest::RunMode->is_smoker } && ($] >= 5.013005 and $] <= 5.013006) ? 1 + # otherwise we are good + : 0 + , + }; + if ($] < 5.009_005) { + require MRO::Compat; + constant->import( OLD_MRO => 1 ); + } + else { + require mro; + constant->import( OLD_MRO => 0 ); + } } use mro 'c3'; @@ -69,6 +58,7 @@ use DBIx::Class::Optional::Dependencies; use base qw/DBIx::Class::Componentised DBIx::Class::AccessorGroup/; use DBIx::Class::StartupCheck; +use DBIx::Class::Exception; __PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames'); __PACKAGE__->_skip_namespace_frames('^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve'); @@ -115,8 +105,6 @@ The community can be found via: =over -=item * Web Site: L - =item * IRC: irc.perl.org#dbix-class =for html @@ -124,13 +112,30 @@ The community can be found via: =item * Mailing list: L +=item * Twitter L + +=item * Web Site: L + =item * RT Bug Tracker: L -=item * gitweb: L +=back + +The project is maintained in a git repository, accessible from the following sources: + +=over =item * git: L -=item * twitter L +=item * gitweb: L + +=item * github mirror: L + +=item * authorized committers: L + +=item * Travis-CI log: L + +=for html + =back @@ -222,7 +227,7 @@ Then you can use these classes in your application's code: my $cd = $millennium_cds_rs->next; # SELECT ... FROM cds JOIN artists ... my $cd_artist_name = $cd->artist->name; # Already has the data so no 2nd query - # new() makes a DBIx::Class::Row object but doesnt insert it into the DB. + # new() makes a Result object but doesnt insert it into the DB. # create() is the same as new() then insert(). my $new_cd = $schema->resultset('CD')->new({ title => 'Spoon' }); $new_cd->artist($cd->artist); @@ -290,12 +295,16 @@ aherzog: Adam Herzog Alexander Keusch +alexrj: Alessandro Ranellucci + alnewkirk: Al Newkirk amiri: Amiri Barksdale amoore: Andrew Moore +andrewalker: Andre Walker + andyg: Andy Grundman ank: Andres Kievsky @@ -386,6 +395,8 @@ jguenther: Justin Guenther jhannah: Jay Hannah +jmac: Jason McIntosh + jnapiorkowski: John Napiorkowski jon: Jon Schutz @@ -410,6 +421,8 @@ michaelr: Michael Reddick milki: Jonathan Chu +mjemmeson: Michael Jemmeson + mstratman: Mark A. Stratman ned: Neil de Carteret @@ -466,7 +479,7 @@ robkinyon: Rob Kinyon Robert Olson -Roman: Roman Filippov +moltar: Roman Filippov Sadrak: Felix Antonius Wilhelm Ostmann diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index 2b0462b..c999a6b 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -4,7 +4,7 @@ use strict; use warnings; use base qw/Class::Accessor::Grouped/; -use Scalar::Util qw/weaken/; +use Scalar::Util qw/weaken blessed/; use namespace::clean; my $successfully_loaded_components; @@ -12,6 +12,9 @@ my $successfully_loaded_components; sub get_component_class { my $class = $_[0]->get_inherited($_[1]); + # It's already an object, just go for it. + return $class if blessed $class; + if (defined $class and ! $successfully_loaded_components->{$class} ) { $_[0]->ensure_class_loaded($class); @@ -41,9 +44,9 @@ DBIx::Class::AccessorGroup - See Class::Accessor::Grouped This class now exists in its own right on CPAN as Class::Accessor::Grouped -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S. Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/Admin/Descriptive.pm b/lib/DBIx/Class/Admin/Descriptive.pm index 9326fca..c3a1e1a 100644 --- a/lib/DBIx/Class/Admin/Descriptive.pm +++ b/lib/DBIx/Class/Admin/Descriptive.pm @@ -1,6 +1,8 @@ package # hide from PAUSE DBIx::Class::Admin::Descriptive; +use warnings; +use strict; use base 'Getopt::Long::Descriptive'; diff --git a/lib/DBIx/Class/Admin/Usage.pm b/lib/DBIx/Class/Admin/Usage.pm index 2e02705..6aabfd9 100644 --- a/lib/DBIx/Class/Admin/Usage.pm +++ b/lib/DBIx/Class/Admin/Usage.pm @@ -1,6 +1,8 @@ package # hide from PAUSE DBIx::Class::Admin::Usage; +use warnings; +use strict; use base 'Getopt::Long::Descriptive::Usage'; diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm index b4c6399..ee983fd 100644 --- a/lib/DBIx/Class/CDBICompat.pm +++ b/lib/DBIx/Class/CDBICompat.pm @@ -165,9 +165,9 @@ Relationships between tables (has_a, has_many...) must be declared after all tab =back -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S. Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm index ecd0864..443e6ca 100644 --- a/lib/DBIx/Class/Carp.pm +++ b/lib/DBIx/Class/Carp.pm @@ -1,4 +1,5 @@ -package DBIx::Class::Carp; +package # hide from pause + DBIx::Class::Carp; use strict; use warnings; @@ -114,7 +115,7 @@ sub import { ## FIXME FIXME FIXME - something is tripping up V::M on 5.8.1, leading # to segfaults. When n::c/B::H::EndOfScope is rewritten in terms of tie() # see if this starts working - unless DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN(); + unless DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN; } sub unimport { diff --git a/lib/DBIx/Class/Core.pm b/lib/DBIx/Class/Core.pm index 080e028..39407dc 100644 --- a/lib/DBIx/Class/Core.pm +++ b/lib/DBIx/Class/Core.pm @@ -48,9 +48,12 @@ The core modules currently are: =back -=head1 AUTHORS +A better overview of the methods found in a Result class can be found +in L. -Matt S. Trout +=head1 AUTHOR AND CONTRIBUTORS + +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/Cursor.pm b/lib/DBIx/Class/Cursor.pm index 14816ab..2031ac4 100644 --- a/lib/DBIx/Class/Cursor.pm +++ b/lib/DBIx/Class/Cursor.pm @@ -13,7 +13,12 @@ resultset. =head1 SYNOPSIS my $cursor = $schema->resultset('CD')->cursor(); - my $first_cd = $cursor->next; + + # raw values off the database handle in resultset columns/select order + my @next_cd_column_values = $cursor->next; + + # list of all raw values as arrayrefs + my @all_cds_column_values = $cursor->all; =head1 DESCRIPTION diff --git a/lib/DBIx/Class/DB.pm b/lib/DBIx/Class/DB.pm index 93eec58..9f12a98 100644 --- a/lib/DBIx/Class/DB.pm +++ b/lib/DBIx/Class/DB.pm @@ -37,7 +37,9 @@ use, documentation has been removed as of 0.08000 Hidden. -=begin hidden head2 storage +=begin hidden + +=head2 storage Sets or gets the storage backend. Defaults to L. @@ -45,7 +47,9 @@ Sets or gets the storage backend. Defaults to L. =cut -=begin hidden head2 class_resolver +=begin hidden + +=head2 class_resolver ****DEPRECATED**** @@ -60,7 +64,9 @@ it. See resolve_class below. __PACKAGE__->mk_classdata('class_resolver' => 'DBIx::Class::ClassResolver::PassThrough'); -=begin hidden head2 connection +=begin hidden + +=head2 connection __PACKAGE__->connection($dsn, $user, $pass, $attrs); @@ -77,7 +83,9 @@ sub connection { $class->schema_instance->connection(@info); } -=begin hidden head2 setup_schema_instance +=begin hidden + +=head2 setup_schema_instance Creates a class method ->schema_instance which contains a DBIx::Class::Schema; all class-method operations are proxies through to this object. If you don't @@ -96,7 +104,9 @@ sub setup_schema_instance { $class->mk_classdata('schema_instance' => $schema); } -=begin hidden head2 txn_begin +=begin hidden + +=head2 txn_begin Begins a transaction (does nothing if AutoCommit is off). @@ -106,7 +116,9 @@ Begins a transaction (does nothing if AutoCommit is off). sub txn_begin { shift->schema_instance->txn_begin(@_); } -=begin hidden head2 txn_commit +=begin hidden + +=head2 txn_commit Commits the current transaction. @@ -116,7 +128,9 @@ Commits the current transaction. sub txn_commit { shift->schema_instance->txn_commit(@_); } -=begin hidden head2 txn_rollback +=begin hidden + +=head2 txn_rollback Rolls back the current transaction. @@ -126,7 +140,9 @@ Rolls back the current transaction. sub txn_rollback { shift->schema_instance->txn_rollback(@_); } -=begin hidden head2 txn_do +=begin hidden + +=head2 txn_do Executes a block of code transactionally. If this code reference throws an exception, the transaction is rolled back and the exception @@ -147,7 +163,9 @@ sub txn_do { shift->schema_instance->txn_do(@_); } } } -=begin hidden head2 resultset_instance +=begin hidden + +=head2 resultset_instance Returns an instance of a resultset for this class - effectively mapping the L connection-as-classdata paradigm into the @@ -161,7 +179,9 @@ sub resultset_instance { $_[0]->result_source_instance->resultset } -=begin hidden head2 result_source_instance +=begin hidden + +=head2 result_source_instance Returns an instance of the result source for this class @@ -217,7 +237,9 @@ sub result_source_instance { return $source; } -=begin hidden head2 resolve_class +=begin hidden + +=head2 resolve_class ****DEPRECATED**** @@ -225,7 +247,9 @@ See L =end hidden -=begin hidden head2 dbi_commit +=begin hidden + +=head2 dbi_commit ****DEPRECATED**** @@ -233,7 +257,9 @@ Alias for L =end hidden -=begin hidden head2 dbi_rollback +=begin hidden + +=head2 dbi_rollback ****DEPRECATED**** @@ -241,13 +267,13 @@ Alias for L =end hidden -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S. Trout +See L and L in DBIx::Class =head1 LICENSE -You may distribute this code under the same terms as Perl itself. +You may distribute this code under the same terms as Perl itself =cut diff --git a/lib/DBIx/Class/Exception.pm b/lib/DBIx/Class/Exception.pm index 3c2aa9b..1f56cb5 100644 --- a/lib/DBIx/Class/Exception.pm +++ b/lib/DBIx/Class/Exception.pm @@ -83,9 +83,9 @@ sub rethrow { die shift; } -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Brandon L. Black +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/GlobalDestruction.pm b/lib/DBIx/Class/GlobalDestruction.pm deleted file mode 100644 index 33a9654..0000000 --- a/lib/DBIx/Class/GlobalDestruction.pm +++ /dev/null @@ -1,64 +0,0 @@ -# This is just a concept-test. If works as intended will ship in its own -# right as Devel::GlobalDestruction::PP or perhaps even as part of rafls -# D::GD itself - -package # hide from pause - DBIx::Class::GlobalDestruction; - -use strict; -use warnings; - -use base 'Exporter'; -our @EXPORT = 'in_global_destruction'; - -use DBIx::Class::Exception; - -if (defined ${^GLOBAL_PHASE}) { - eval 'sub in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }'; -} -elsif (eval { require Devel::GlobalDestruction }) { # use the XS version if available - *in_global_destruction = \&Devel::GlobalDestruction::in_global_destruction; -} -else { - my ($in_global_destruction, $before_is_installed); - - eval <<'PP_IGD'; - -sub in_global_destruction () { $in_global_destruction } - -END { - # SpeedyCGI runs END blocks every cycle but keeps object instances - # hence we have to disable the globaldestroy hatch, and rely on the - # eval traps (which appears to work, but are risky done so late) - $in_global_destruction = 1 unless $CGI::SpeedyCGI::i_am_speedy; -} - -# threads do not execute the global ENDs (it would be stupid). However -# one can register a new END via simple string eval within a thread, and -# achieve the same result. A logical place to do this would be CLONE, which -# is claimed to run in the context of the new thread. However this does -# not really seem to be the case - any END evaled in a CLONE is ignored :( -# Hence blatantly hooking threads::create -if ($INC{'threads.pm'}) { - require Class::Method::Modifiers; - Class::Method::Modifiers::install_modifier( threads => before => create => sub { - my $orig_target_cref = $_[1]; - $_[1] = sub { - { local $@; eval 'END { $in_global_destruction = 1 }' } - $orig_target_cref->(); - }; - }); - $before_is_installed = 1; -} - -# just in case threads got loaded after DBIC (silly) -sub CLONE { - DBIx::Class::Exception->throw("You must load the 'threads' module before @{[ __PACKAGE__ ]}") - unless $before_is_installed; -} - -PP_IGD - -} - -1; diff --git a/lib/DBIx/Class/InflateColumn.pm b/lib/DBIx/Class/InflateColumn.pm index 2c6a955..9214582 100644 --- a/lib/DBIx/Class/InflateColumn.pm +++ b/lib/DBIx/Class/InflateColumn.pm @@ -11,11 +11,17 @@ DBIx::Class::InflateColumn - Automatically create references from column data =head1 SYNOPSIS - # In your table classes - __PACKAGE__->inflate_column('column_name', { - inflate => sub { ... }, - deflate => sub { ... }, - }); + # In your table classes + __PACKAGE__->inflate_column('column_name', { + inflate => sub { + my ($raw_value_from_db, $result_object) = @_; + ... + }, + deflate => sub { + my ($inflated_value_from_user, $result_object) = @_; + ... + }, + }); =head1 DESCRIPTION @@ -54,20 +60,25 @@ named C, you could inflate the column in the corresponding table class using something like: __PACKAGE__->inflate_column('insert_time', { - inflate => sub { DateTime::Format::Pg->parse_datetime(shift); }, - deflate => sub { DateTime::Format::Pg->format_datetime(shift); }, + inflate => sub { + my ($insert_time_raw_value, $event_result_object) = @_; + DateTime->from_epoch( epoch => $insert_time_raw_value ); + }, + deflate => sub { + my ($insert_time_dt_object, $event_result_object) = @_; + $insert_time_dt_object->epoch; + }, }); -(Replace L with the appropriate module for your -database, or consider L.) - The coderefs you set for inflate and deflate are called with two parameters, -the first is the value of the column to be inflated/deflated, the second is the -row object itself. Thus you can call C<< ->result_source->schema->storage->dbh >> in your inflate/defalte subs, to feed to L. +the first is the value of the column to be inflated/deflated, the second is +the result object itself. In this example, calls to an event's C accessor return a -L object. This L object is later "deflated" when -used in the database layer. +L object. This L object is later "deflated" back +to the integer epoch representation when used in the database layer. +For a much more thorough handling of the above example, please see +L =cut diff --git a/lib/DBIx/Class/InflateColumn/DateTime.pm b/lib/DBIx/Class/InflateColumn/DateTime.pm index 0e2d058..3162223 100644 --- a/lib/DBIx/Class/InflateColumn/DateTime.pm +++ b/lib/DBIx/Class/InflateColumn/DateTime.pm @@ -201,7 +201,7 @@ sub _flate_or_fallback $parser->$method($value); } catch { - $self->throw_exception ("Error while inflating ${value} for $info->{__dbic_colname} on ${self}: $_") + $self->throw_exception ("Error while inflating '$value' for $info->{__dbic_colname} on ${self}: $_") unless $info->{datetime_undef_if_invalid}; undef; # rv }; diff --git a/lib/DBIx/Class/Manual/Cookbook.pod b/lib/DBIx/Class/Manual/Cookbook.pod index 014ff38..328c891 100644 --- a/lib/DBIx/Class/Manual/Cookbook.pod +++ b/lib/DBIx/Class/Manual/Cookbook.pod @@ -117,7 +117,12 @@ almost like you would define a regular ResultSource. __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); - # ->table, ->add_columns, etc. + # For the time being this is necessary even for virtual views + __PACKAGE__->table($view_name); + + # + # ->add_columns, etc. + # # do not attempt to deploy() this view __PACKAGE__->result_source_instance->is_virtual(1); @@ -349,8 +354,8 @@ from, select, and +select attributes. my $rs = $cdrs->search({ year => { '=' => $cdrs->search( - { artist_id => { '=' => { -ident => 'me.artist_id' } } }, - { alias => 'inner' } + { artist_id => { -ident => 'me.artist_id' } }, + { alias => 'sub_query' } )->get_column('year')->max_rs->as_query, }, }); @@ -359,11 +364,11 @@ That creates the following SQL: 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 artist_id = me.artist_id - ) + WHERE year = ( + SELECT MAX(sub_query.year) + FROM cd sub_query + WHERE artist_id = me.artist_id + ) =head2 Predefined searches @@ -440,6 +445,35 @@ etc.), but this may change in the future. See also L. +=head2 Software Limits + +When your RDBMS does not have a working SQL limit mechanism (e.g. Sybase ASE) +and L is either too slow or does +not work at all, you can try the +L +L attribute, which skips over records to simulate limits +in the Perl layer. + +For example: + + my $paged_rs = $rs->search({}, { + rows => 25, + page => 3, + order_by => [ 'me.last_name' ], + software_limit => 1, + }); + +You can set it as a default for your schema by placing the following in your +C: + + __PACKAGE__->default_resultset_attributes({ software_limit => 1 }); + +B If you are dealing with large resultsets and your L or +ODBC/ADO driver does not have proper cursor support (i.e. it loads the whole +resultset into memory) then this feature will be extremely slow and use huge +amounts of memory at best, and may cause your process to run out of memory and +cause instability on your server at worst, beware! + =head1 JOINS AND PREFETCHING =head2 Using joins and prefetch @@ -683,9 +717,9 @@ SQL statements: =head1 ROW-LEVEL OPERATIONS -=head2 Retrieving a row object's Schema +=head2 Retrieving a result object's Schema -It is possible to get a Schema object from a row object like so: +It is possible to get a Schema object from a result object like so: my $schema = $cd->result_source->schema; # use the schema as normal: @@ -930,7 +964,7 @@ B test.pl Alternatively you can use L that implements exactly the above functionality. -=head2 Skip row object creation for faster results +=head2 Skip result object creation for faster results DBIx::Class is not built for speed, it's built for convenience and ease of use, but sometimes you just need to get the data, and skip the @@ -1029,7 +1063,7 @@ See L for more documentation. =head2 Creating a result set from a set of rows -Sometimes you have a (set of) row objects that you want to put into a +Sometimes you have a (set of) result objects that you want to put into a resultset without the need to hit the DB again. You can do that by using the L method: @@ -1907,8 +1941,9 @@ just looking for this. For example, say that you have three columns, C, C, and C. You would like to make changes to C and have C be automagically set to the value of C squared. -You can accomplish this by wrapping the C accessor with -L: +You can accomplish this by wrapping the C accessor with the C +method modifier, available through either L, +L or L modules): around number => sub { my ($orig, $self) = (shift, shift); @@ -1919,7 +1954,7 @@ L: } $self->$orig(@_); - } + }; Note that the hard work is done by the call to C<< $self->$orig >>, which redispatches your call to store_column in the superclass(es). @@ -2128,8 +2163,8 @@ L. =item * Use L in void context to insert data -when you don't need the resulting L objects, if possible, but -see the caveats. +when you don't need the resulting L objects, +if possible, but see the caveats. When inserting many rows, for best results, populate a large number of rows at a time, but not so large that the table is locked for an unacceptably long time. diff --git a/lib/DBIx/Class/Manual/FAQ.pod b/lib/DBIx/Class/Manual/FAQ.pod index 8a706e1..051ae30 100644 --- a/lib/DBIx/Class/Manual/FAQ.pod +++ b/lib/DBIx/Class/Manual/FAQ.pod @@ -351,7 +351,7 @@ C on the resultset will only return the total number in the page. =item .. insert a row with an auto incrementing primary key? This happens automatically. After -L a row object, the primary +L a result object, the primary key value created by your database can be fetched by calling C (or the access of your primary key column) on the object. @@ -536,7 +536,7 @@ L runs the actual SQL statement as late as possible, thus if you create a resultset using C in scalar context, no query is executed. You can create further resultset refinements by calling search again or relationship accessors. The SQL query is only run when -you ask the resultset for an actual row object. +you ask the resultset for an actual result object. =item How do I deal with tables that lack a primary key? @@ -556,7 +556,7 @@ Look at the tips in L =item How do I reduce the overhead of database queries? You can reduce the overhead of object creation within L -using the tips in L +using the tips in L and L =item How do I override a run time method (e.g. a relationship accessor)? diff --git a/lib/DBIx/Class/Manual/Glossary.pod b/lib/DBIx/Class/Manual/Glossary.pod index 2cd6db3..4feb8e1 100644 --- a/lib/DBIx/Class/Manual/Glossary.pod +++ b/lib/DBIx/Class/Manual/Glossary.pod @@ -73,12 +73,14 @@ At least one L class is needed per database. =head2 Result class A Result class defines both a source of data (usually one per table), -and the methods that will be available in the L objects created -using that source. +and the methods that will be available in the L objects +created using that source. One Result class is needed per data source (table, view, query) used in your application, they should inherit from L. +See also: L + =head2 ResultSource ResultSource objects represent the source of your data, these are @@ -101,23 +103,43 @@ See also: L =head2 Record -See Row. +See Result. =head2 Row -Row objects contain your actual data. They are returned from ResultSet objects. +See Result. + +=head2 Result + +Result objects contain your actual data. They are returned from +ResultSet objects. These are sometimes (incorrectly) called +row objects, including older versions of the DBIC documentation. + +See also: L =head2 Object -See Row. +See Result. =head2 join +See Join. + =head2 prefetch +Similiar to a join, except the related result objects are fetched and +cached for future use, instead of used directly from the ResultSet. This +allows you to jump to different relationships within a Result without +worrying about generating a ton of extra SELECT statements. =head1 SQL TERMS +=head2 CRUD + +Create, Read, Update, Delete. A general concept of something that can +do all four operations (INSERT, SELECT, UPDATE, DELETE), usually at a +row-level. + =head2 Join This is an SQL keyword, it is used to link multiple tables in one SQL @@ -135,4 +157,12 @@ can be found in L. =head2 Related data In SQL, related data actually refers to data that are normalised into -the same table. (Yes. DBIC does mis-use this term). +the same table. (Yes. DBIC does mis-use this term.) + +=head1 AUTHOR AND CONTRIBUTORS + +See L and L in DBIx::Class + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. diff --git a/lib/DBIx/Class/Manual/Intro.pod b/lib/DBIx/Class/Manual/Intro.pod index d27a24a..382f72d 100644 --- a/lib/DBIx/Class/Manual/Intro.pod +++ b/lib/DBIx/Class/Manual/Intro.pod @@ -67,7 +67,7 @@ The important thing to understand: =head2 Search results are returned as Rows Rows of the search from the database are blessed into -L objects. +L objects. =head1 SETTING UP DBIx::Class @@ -136,34 +136,29 @@ of information that it may be useful to have -- just pass C a hash: size => 16, is_nullable => 0, is_auto_increment => 1, - default_value => '', }, artist => { data_type => 'integer', size => 16, is_nullable => 0, - is_auto_increment => 0, - default_value => '', }, title => { data_type => 'varchar', size => 256, is_nullable => 0, - is_auto_increment => 0, - default_value => '', }, rank => { data_type => 'integer', size => 16, is_nullable => 0, - is_auto_increment => 0, - default_value => '', + default_value => 0, } ); DBIx::Class doesn't directly use most of this data yet, but various related -modules such as L make use of it. Also it allows you to -create your database tables from your Schema, instead of the other way around. +modules such as L make use of it. +Also it allows you to create your database tables from your Schema, +instead of the other way around. See L for details. See L for more details of the possible column @@ -402,7 +397,7 @@ attributes: my @albums = My::Schema->resultset('Album')->search( { artist => 'Bob Marley' }, - { rows => 2, order_by => 'year DESC' } + { rows => 2, order_by => { -desc => 'year' } } ); C<@albums> then holds the two most recent Bob Marley albums. @@ -432,7 +427,7 @@ important to declare a L on all your result sources B. In a pinch one can always declare each row identifiable by all its columns: - __PACKAGE__->set_primary_keys (__PACKAGE__->columns); + __PACKAGE__->set_primary_key(__PACKAGE__->columns); Note that DBIx::Class is smart enough to store a copy of the PK values before any row-object changes take place, so even if you change the values of PK diff --git a/lib/DBIx/Class/Manual/Reading.pod b/lib/DBIx/Class/Manual/Reading.pod index 3754f29..cb352a2 100644 --- a/lib/DBIx/Class/Manual/Reading.pod +++ b/lib/DBIx/Class/Manual/Reading.pod @@ -89,6 +89,20 @@ method arguments, use with caution. =item * +L<$obj|DBIx::Class> - Reference to the source class or object definition + +All arguments and return values should provide a link to the object's +class documentation or definition, even if it's the same class as the current +documentation. For example: + + ## Correct, if stated within DBIx::Class::ResultSet + L<$resultset|/new> + + ## Correct, if stated outside DBIx::Class::ResultSet + L<$resultset|DBIx::Class::ResultSet> + +=item * + ? - Optional, should be placed after the argument type and name. ## Correct @@ -112,26 +126,28 @@ marked optional. =back -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. +The second item starts with the text "Return Value:". The remainder of +the line is either the text "not defined" or a variable with a descriptive +name. ## Good examples - =item Return value: undefined - =item Return value: A schema object - =item Return value: $classname + =item Return Value: not defined + =item Return Value: L<$schema|DBIx::Class::Schema> + =item Return Value: $classname ## Bad examples - =item Return value: The names + =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 +"not defined" 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.) +statement, if there is no explicit return statement.) This is different +than specifying "undef", which means that it explicitly returns undef, +though usually this is used an alternate return (like C<$obj | undef>). =item * -The argument list is followed by a single paragraph describing what +The argument/return list is followed by a single paragraph describing what the method does. =item * @@ -144,7 +160,7 @@ self-explanatory enough to not require it. Use best judgement. =item * -The argument list is followed by some examples of how to use the +The argument/return list is followed by some examples of how to use the method, using its various types of arguments. The examples can also include ways to use the results if @@ -163,15 +179,12 @@ Examples and explaining paragraphs can be repeated as necessary. =back -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -see L +See L and L in DBIx::Class =head1 LICENSE You may distribute this code under the same terms as Perl itself. =cut - - - diff --git a/lib/DBIx/Class/Manual/ResultClass.pod.proto b/lib/DBIx/Class/Manual/ResultClass.pod.proto new file mode 100644 index 0000000..29ff9e9 --- /dev/null +++ b/lib/DBIx/Class/Manual/ResultClass.pod.proto @@ -0,0 +1,60 @@ +# +# This is what eventually becomes lib/DBIx/Class/Manual/ResultClass.pod +# Courtesy of maint/gen_pod_inherit and Pod::Inherit +# + +=head1 NAME + +DBIx::Class::Manual::ResultClass - Representing a single result (row) from +a DB query + +=head1 SYNOPSIS + + package My::Schema::Result::Track; + + use parent 'DBIx::Class::Core'; + + __PACKAGE__->table('tracks'); + + __PACKAGE__->add_columns({ + id => { + data_type => 'int', + is_auto_increment => 1, + }, + cd_id => { + data_type => 'int', + }, + title => { + data_type => 'varchar', + size => 50, + }, + rank => { + data_type => 'int', + is_nullable => 1, + }, + }); + + __PACKAGE__->set_primary_key('id'); + __PACKAGE__->add_unique_constraint(u_title => ['cd_id', 'title']); + +=head1 DESCRIPTION + +In L, a user normally receives query results as instances of a +certain C, depending on the main query source. Besides being +the primary "toolset" for interaction with your data, a C also +serves to establish source metadata, which is then used during initialization +of your L instance. + +Because of these multiple seemingly conflicting purposes, it is hard to +aggregate the documentation of various methods available on a typical +C. This document serves as a general overview of C +declaration best practices, and offers an index of the available methods +(and the Components/Roles which provide them). + +=head1 AUTHOR AND CONTRIBUTORS + +See L and L in DBIx::Class + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. diff --git a/lib/DBIx/Class/Manual/Troubleshooting.pod b/lib/DBIx/Class/Manual/Troubleshooting.pod index 747caf9..f76934e 100644 --- a/lib/DBIx/Class/Manual/Troubleshooting.pod +++ b/lib/DBIx/Class/Manual/Troubleshooting.pod @@ -134,7 +134,7 @@ with full current updates will not be subject to this problem):- This issue is due to perl doing an exhaustive search of blessed objects under certain circumstances. The problem shows up as performance -degradation exponential to the number of L row objects in +degradation exponential to the number of L result objects in memory, so can be unnoticeable with certain data sets, but with huge performance impacts on other datasets. @@ -152,7 +152,7 @@ L It has been observed, using L, that creating a L object which includes a column of data type TEXT/BLOB/etc. will allocate LongReadLen bytes. This allocation does not leak, but if LongReadLen -is large in size, and many such row objects are created, e.g. as the +is large in size, and many such result objects are created, e.g. as the output of a ResultSet query, the memory footprint of the Perl interpreter can grow very large. diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm index afd41f5..a96c189 100644 --- a/lib/DBIx/Class/Optional/Dependencies.pm +++ b/lib/DBIx/Class/Optional/Dependencies.pm @@ -32,6 +32,13 @@ my $admin_basic = { 'namespace::autoclean' => '0.09', }; +my $admin_script = { + %$moose_basic, + %$admin_basic, + 'Getopt::Long::Descriptive' => '0.081', + 'Text::CSV' => '1.16', +}; + my $datetime_basic = { 'DateTime' => '0.55', 'DateTime::Format::Strptime' => '1.2', @@ -99,8 +106,11 @@ my $rdbms_firebird_odbc = { }; my $reqs = { - dist => { - #'Module::Install::Pod::Inherit' => '0.01', + dist_podinherit => { + req => { + 'Pod::Inherit' => '0.90', + 'Pod::Tree' => '0', + } }, replicated => { @@ -131,10 +141,7 @@ my $reqs = { admin_script => { req => { - %$moose_basic, - %$admin_basic, - 'Getopt::Long::Descriptive' => '0.081', - 'Text::CSV' => '1.16', + %$admin_script, }, pod => { title => 'dbicadmin', @@ -144,7 +151,7 @@ my $reqs = { deploy => { req => { - 'SQL::Translator' => '0.11006', + 'SQL::Translator' => '0.11016', }, pod => { title => 'Storage::DBI::deploy()', @@ -175,15 +182,16 @@ my $reqs = { }, }, - test_notabs => { + test_whitespace => { req => { + 'Test::EOL' => '1.0', 'Test::NoTabs' => '0.9', }, }, - test_eol => { + test_strictures => { req => { - 'Test::EOL' => '1.0', + 'Test::Strict' => '0.16', }, }, @@ -191,6 +199,20 @@ my $reqs = { req => $json_any, }, + test_admin_script => { + req => { + %$admin_script, + 'JSON' => 0, + 'JSON::XS' => 0, + $^O eq 'MSWin32' + # for t/admin/10script.t + ? ('Win32::ShellQuote' => 0) + # DWIW does not compile (./configure even) on win32 + : ('JSON::DWIW' => 0 ) + , + } + }, + test_leaks => { req => { 'Test::Memory::Cycle' => '0', @@ -253,6 +275,7 @@ my $reqs = { rdbms_pg => { req => { + # when changing this list make sure to adjust xt/optional_deps.t %$rdbms_pg, }, pod => { @@ -427,6 +450,7 @@ my $reqs = { req => { $ENV{DBICTEST_PG_DSN} ? ( + # when changing this list make sure to adjust xt/optional_deps.t %$rdbms_pg, ($^O ne 'MSWin32' ? ('Sys::SigAction' => '0') : ()), 'DBD::Pg' => '2.009002', @@ -685,13 +709,9 @@ sub req_group_list { # This is to be called by the author only (automatically in Makefile.PL) sub _gen_pod { - my ($class, $distver) = @_; - - my $modfn = __PACKAGE__ . '.pm'; - $modfn =~ s/\:\:/\//g; + my ($class, $distver, $pod_dir) = @_; - my $podfn = __FILE__; - $podfn =~ s/\.pm$/\.pod/; + die "No POD root dir supplied" unless $pod_dir; $distver ||= eval { require DBIx::Class; DBIx::Class->VERSION; } @@ -704,11 +724,22 @@ sub _gen_pod { "\n\n---------------------------------------------------------------------\n" ; + # do not ask for a recent version, use 1.x API calls + # this *may* execute on a smoker with old perl or whatnot + require File::Path; + + (my $modfn = __PACKAGE__ . '.pm') =~ s|::|/|g; + + (my $podfn = "$pod_dir/$modfn") =~ s/\.pm$/\.pod/; + (my $dir = $podfn) =~ s|/[^/]+$||; + + File::Path::mkpath([$dir]); + my $sqltver = $class->req_list_for ('deploy')->{'SQL::Translator'} or die "Hrmm? No sqlt dep?"; my @chunks = ( - <<'EOC', + <<"EOC", ######################################################################### ##################### A U T O G E N E R A T E D ######################## ######################################################################### @@ -784,7 +815,7 @@ EOD '=head2 req_group_list', '=over', '=item Arguments: none', - '=item Returns: \%list_of_requirement_groups', + '=item Return Value: \%list_of_requirement_groups', '=back', <<'EOD', This method should be used by DBIx::Class packagers, to get a hashref of all @@ -795,7 +826,7 @@ EOD '=head2 req_list_for', '=over', '=item Arguments: $group_name', - '=item Returns: \%list_of_module_version_pairs', + '=item Return Value: \%list_of_module_version_pairs', '=back', <<'EOD', This method should be used by DBIx::Class extension authors, to determine the @@ -807,7 +838,7 @@ EOD '=head2 req_ok_for', '=over', '=item Arguments: $group_name', - '=item Returns: 1|0', + '=item Return Value: 1|0', '=back', <<'EOD', Returns true or false depending on whether all modules required by @@ -817,7 +848,7 @@ EOD '=head2 req_missing_for', '=over', '=item Arguments: $group_name', - '=item Returns: $error_message_string', + '=item Return Value: $error_message_string', '=back', <<"EOD", Returns a single line string suitable for inclusion in larger error messages. @@ -837,7 +868,7 @@ EOD '=head2 req_errorlist_for', '=over', '=item Arguments: $group_name', - '=item Returns: \%list_of_loaderrors_per_module', + '=item Return Value: \%list_of_loaderrors_per_module', '=back', <<'EOD', Returns a hashref containing the actual errors that occured while attempting @@ -851,6 +882,7 @@ EOD open (my $fh, '>', $podfn) or Carp::croak "Unable to write to $podfn: $!"; print $fh join ("\n\n", @chunks); + print $fh "\n"; close ($fh); } diff --git a/lib/DBIx/Class/Ordered.pm b/lib/DBIx/Class/Ordered.pm index 8a50e25..5e40dc0 100644 --- a/lib/DBIx/Class/Ordered.pm +++ b/lib/DBIx/Class/Ordered.pm @@ -275,7 +275,7 @@ sub last_sibling { return defined $lsib ? $lsib : 0; } -# an optimized method to get the last sibling position value without inflating a row object +# an optimized method to get the last sibling position value without inflating a result object sub _last_sibling_posval { my $self = shift; my $position_column = $self->position_column; @@ -705,9 +705,39 @@ sub _shift_siblings { $ord = 'desc'; } - $self->_group_rs - ->search ({ $position_column => { -between => \@between } }) - ->update ({ $position_column => \ "$position_column $op 1" } ); + my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } }); + + # some databases (sqlite, pg, perhaps others) are dumb and can not do a + # blanket increment/decrement without violating a unique constraint. + # So what we do here is check if the position column is part of a unique + # constraint, and do a one-by-one update if this is the case. + my $rsrc = $self->result_source; + + # set in case there are more cascades combined with $rs->update => $rs_update_all overrides + local $rsrc->schema->{_ORDERED_INTERNAL_UPDATE} = 1; + my @pcols = $rsrc->primary_columns; + if ( + first { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) + ) { + my $cursor = $shift_rs->search ( + {}, { order_by => { "-$ord", $position_column }, select => [$position_column, @pcols] } + )->cursor; + my $rs = $rsrc->resultset; + + my @all_data = $cursor->all; + while (my $data = shift @all_data) { + my $pos = shift @$data; + my $cond; + for my $i (0.. $#pcols) { + $cond->{$pcols[$i]} = $data->[$i]; + } + + $rs->find($cond)->update ({ $position_column => $pos + ( ($op eq '+') ? 1 : -1 ) }); + } + } + else { + $shift_rs->update ({ $position_column => \ "$position_column $op 1" } ); + } } diff --git a/lib/DBIx/Class/PK.pm b/lib/DBIx/Class/PK.pm index db9b8a1..e128e57 100644 --- a/lib/DBIx/Class/PK.pm +++ b/lib/DBIx/Class/PK.pm @@ -50,7 +50,7 @@ sub _ident_values { if (@missing && $self->in_storage) { $self->throw_exception ( - 'Unable to uniquely identify row object with missing PK columns: ' + 'Unable to uniquely identify result object with missing PK columns: ' . join (', ', @missing ) ); } @@ -60,7 +60,7 @@ sub _ident_values { =head2 ID -Returns a unique id string identifying a row object by primary key. +Returns a unique id string identifying a result object by primary key. Used by L and L. @@ -126,7 +126,7 @@ sub _mk_ident_cond { if (@undef && $self->in_storage) { $self->throw_exception ( - 'Unable to construct row object identity condition due to NULL PK columns: ' + 'Unable to construct result object identity condition due to NULL PK columns: ' . join (', ', @undef) ); } @@ -136,9 +136,9 @@ sub _mk_ident_cond { 1; -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S. Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/PK/Auto.pm b/lib/DBIx/Class/PK/Auto.pm index 523ec27..26bd6df 100644 --- a/lib/DBIx/Class/PK/Auto.pm +++ b/lib/DBIx/Class/PK/Auto.pm @@ -41,9 +41,9 @@ The code that was handled here is now in Row for efficiency. The code that was handled here is now in ResultSource, and is being proxied to Row as well. -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S. Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/PK/Auto/DB2.pm b/lib/DBIx/Class/PK/Auto/DB2.pm index b30a9ff..c7fed59 100644 --- a/lib/DBIx/Class/PK/Auto/DB2.pm +++ b/lib/DBIx/Class/PK/Auto/DB2.pm @@ -18,9 +18,9 @@ DBIx::Class::PK::Auto::DB2 - (DEPRECATED) Automatic primary key class for DB2 Just load PK::Auto instead; auto-inc is now handled by Storage. -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/PK/Auto/MSSQL.pm b/lib/DBIx/Class/PK/Auto/MSSQL.pm index f87a3cf..ce0ee2c 100644 --- a/lib/DBIx/Class/PK/Auto/MSSQL.pm +++ b/lib/DBIx/Class/PK/Auto/MSSQL.pm @@ -18,9 +18,9 @@ DBIx::Class::PK::Auto::MSSQL - (DEPRECATED) Automatic primary key class for MSSQ Just load PK::Auto instead; auto-inc is now handled by Storage. -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/PK/Auto/MySQL.pm b/lib/DBIx/Class/PK/Auto/MySQL.pm index 8dd5c09..fd152f7 100644 --- a/lib/DBIx/Class/PK/Auto/MySQL.pm +++ b/lib/DBIx/Class/PK/Auto/MySQL.pm @@ -18,9 +18,9 @@ DBIx::Class::PK::Auto::MySQL - (DEPRECATED) Automatic primary key class for MySQ Just load PK::Auto instead; auto-inc is now handled by Storage. -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/PK/Auto/Oracle.pm b/lib/DBIx/Class/PK/Auto/Oracle.pm index e23e243..45e4b0d 100644 --- a/lib/DBIx/Class/PK/Auto/Oracle.pm +++ b/lib/DBIx/Class/PK/Auto/Oracle.pm @@ -18,9 +18,9 @@ DBIx::Class::PK::Auto::Oracle - (DEPRECATED) Automatic primary key class for Ora Just load PK::Auto instead; auto-inc is now handled by Storage. -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/PK/Auto/Pg.pm b/lib/DBIx/Class/PK/Auto/Pg.pm index 0a6bd27..a1b24cd 100644 --- a/lib/DBIx/Class/PK/Auto/Pg.pm +++ b/lib/DBIx/Class/PK/Auto/Pg.pm @@ -18,9 +18,9 @@ DBIx::Class::PK::Auto::Pg - (DEPRECATED) Automatic primary key class for Pg Just load PK::Auto instead; auto-inc is now handled by Storage. -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/PK/Auto/SQLite.pm b/lib/DBIx/Class/PK/Auto/SQLite.pm index 6fb9495..3bc5c5e 100644 --- a/lib/DBIx/Class/PK/Auto/SQLite.pm +++ b/lib/DBIx/Class/PK/Auto/SQLite.pm @@ -18,9 +18,9 @@ DBIx::Class::PK::Auto::SQLite - (DEPRECATED) Automatic primary key class for SQL Just load PK::Auto instead; auto-inc is now handled by Storage. -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/Relationship.pm b/lib/DBIx/Class/Relationship.pm index 4882924..c6f744d 100644 --- a/lib/DBIx/Class/Relationship.pm +++ b/lib/DBIx/Class/Relationship.pm @@ -75,7 +75,7 @@ Each relationship sets up an accessor method on the L objects that represent the items of your table. From L objects, the relationships can be searched using the "search_related" method. -In list context, each returns a list of Row objects for the related class, +In list context, each returns a list of Result objects for the related class, in scalar context, a new ResultSet representing the joined tables is returned. Thus, the calls can be chained to produce complex queries. Since the database is not actually queried until you attempt to retrieve @@ -137,7 +137,7 @@ in this class or C specifies a reference to a join condition. =item accessor_name This argument is the name of the method you can call on a -L object to retrieve the instance of the foreign +L object to retrieve the instance of the foreign class matching this relationship. This is often called the C. @@ -231,7 +231,7 @@ which can be assigned to relationships as well. =over 4 -=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond|\&cond?, \%attrs? +=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond|\&cond?, L<\%attrs?|DBIx::Class::ResultSet/ATTRIBUTES> =back @@ -248,9 +248,9 @@ specifies a reference to a join condition. =item accessor_name This argument is the name of the method you can call on a -L object to retrieve a resultset of the related -class restricted to the ones related to the row object. In list -context it returns the row objects. This is often called the +L object to retrieve a resultset of the related +class restricted to the ones related to the result object. In list +context it returns the result objects. This is often called the C. Use this accessor_name in L @@ -355,7 +355,7 @@ relationships as well. =over 4 -=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond|\&cond?, \%attrs? +=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond|\&cond?, L<\%attrs?|DBIx::Class::ResultSet/ATTRIBUTES> =back @@ -370,7 +370,7 @@ condition. =item accessor_name This argument is the name of the method you can call on a -L object to retrieve the instance of the foreign +L object to retrieve the instance of the foreign class matching this relationship. This is often called the C. @@ -450,7 +450,7 @@ you probably just meant to use C. =over 4 -=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond|\&cond?, \%attrs? +=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond|\&cond?, L<\%attrs?|DBIx::Class::ResultSet/ATTRIBUTES> =back @@ -465,7 +465,7 @@ condition. =item accessor_name This argument is the name of the method you can call on a -L object to retrieve the instance of the foreign +L object to retrieve the instance of the foreign class matching this relationship. This is often called the C. @@ -543,7 +543,7 @@ L. =over 4 -=item Arguments: $accessor_name, $link_rel_name, $foreign_rel_name, \%attrs? +=item Arguments: $accessor_name, $link_rel_name, $foreign_rel_name, L<\%attrs?|DBIx::Class::ResultSet/ATTRIBUTES> =back @@ -562,7 +562,7 @@ C and similar methods which operate on true relationships. =item accessor_name This argument is the name of the method you can call on a -L object to retrieve the rows matching this +L object to retrieve the rows matching this relationship. On a many_to_many, unlike other relationships, this cannot be used in @@ -633,9 +633,9 @@ relationships as well. 1; -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -see L +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index 174aa23..1609122 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -45,7 +45,7 @@ sub add_relationship_accessor { } }; } elsif ($acc_type eq 'filter') { - $class->throw_exception("No such column $rel to filter") + $class->throw_exception("No such column '$rel' to filter") unless $class->has_column($rel); my $f_class = $class->relationship_info($rel)->{class}; $class->inflate_column($rel, @@ -55,7 +55,7 @@ sub add_relationship_accessor { }, deflate => sub { my ($val, $self) = @_; - $self->throw_exception("$val isn't a $f_class") unless $val->isa($f_class); + $self->throw_exception("'$val' isn't a $f_class") unless $val->isa($f_class); return ($val->_ident_values)[0]; # WARNING: probably breaks for multi-pri sometimes. FIXME } @@ -66,7 +66,7 @@ sub add_relationship_accessor { $meth{"${rel}_rs"} = sub { shift->search_related_rs($rel, @_) }; $meth{"add_to_${rel}"} = sub { shift->create_related($rel, @_); }; } else { - $class->throw_exception("No such relationship accessor type $acc_type"); + $class->throw_exception("No such relationship accessor type '$acc_type'"); } { no strict 'refs'; diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index fdbec40..41c7a8a 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -168,8 +168,8 @@ clause of the C statement associated with this relationship. While every coderef-based condition must return a valid C clause, it may elect to additionally return a simplified join-free condition hashref when -invoked as C<< $row_object->relationship >>, as opposed to -C<< $rs->related_resultset('relationship') >>. In this case C<$row_object> is +invoked as C<< $result->relationship >>, as opposed to +C<< $rs->related_resultset('relationship') >>. In this case C<$result> is passed to the coderef as C<< $args->{self_rowobj} >>, so a user can do the following: @@ -219,11 +219,11 @@ clause, the C<$args> hashref passed to the subroutine contains some extra metadata. Currently the supplied coderef is executed as: $relationship_info->{cond}->({ - self_alias => The alias of the invoking resultset ('me' in case of a row object), + self_alias => The alias of the invoking resultset ('me' in case of a result object), foreign_alias => The alias of the to-be-joined resultset (often matches relname), self_resultsource => The invocant's resultsource, foreign_relname => The relationship name (does *not* always match foreign_alias), - self_rowobj => The invocant itself in case of $row_obj->relationship + self_rowobj => The invocant itself in case of a $result_object->$relationship call }); =head3 attributes @@ -249,6 +249,12 @@ command immediately before C. =item proxy =E $column | \@columns | \%column +The 'proxy' attribute can be used to retrieve values, and to perform +updates if the relationship has 'cascade_update' set. The 'might_have' +and 'has_one' relationships have this set by default; if you want a proxy +to update across a 'belongs_to' relationship, you must set the attribute +yourself. + =over 4 =item \@columns @@ -267,6 +273,14 @@ Then, assuming MyApp::Schema::LinerNotes has an accessor named notes, you can do $cd->notes('Notes go here'); # set notes -- LinerNotes object is # created if it doesn't exist +For a 'belongs_to relationship, note the 'cascade_update': + + MyApp::Schema::Track->belongs_to( cd => 'DBICTest::Schema::CD', 'cd, + { proxy => ['title'], cascade_update => 1 } + ); + $track->title('New Title'); + $track->update; # updates title in CD + =item \%column A hashref where each key is the accessor you want installed in the main class, @@ -276,7 +290,7 @@ and its value is the name of the original in the fireign class. proxy => { cd_title => 'title' }, }); -This will create an accessor named C on the C<$track> row object. +This will create an accessor named C on the C<$track> result object. =back @@ -331,6 +345,10 @@ C relationships. You can disable this behaviour on a per-relationship basis by supplying C<< cascade_update => 0 >> in the relationship attributes. +The C relationship does not update across relationships +by default, so if you have a 'proxy' attribute on a belongs_to and want to +use 'update' on it, you muse set C<< cascade_update => 1 >>. + This is not a RDMS style cascade update - it purely means that when an object has update called on it, all the related objects also have update called. It will not change foreign keys automatically - @@ -368,7 +386,7 @@ L. Default is on, set to 0 to disable. =over 4 -=item Arguments: $relname, $rel_info +=item Arguments: $rel_name, $rel_info =back @@ -383,16 +401,41 @@ sub register_relationship { } =over 4 -=item Arguments: $relationship_name +=item Arguments: $rel_name -=item Return Value: $related_resultset +=item Return Value: L<$related_resultset|DBIx::Class::ResultSet> =back $rs = $cd->related_resultset('artist'); Returns a L for the relationship named -$relationship_name. +$rel_name. + +=head2 $relationship_accessor + +=over 4 + +=item Arguments: none + +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | L<$related_resultset|DBIx::Class::ResultSet> | undef + +=back + + # These pairs do the same thing + $row = $cd->related_resultset('artist')->single; # has_one relationship + $row = $cd->artist; + $rs = $cd->related_resultset('tracks'); # has_many relationship + $rs = $cd->tracks; + +This is the recommended way to traverse through relationships, based +on the L name given in the relationship definition. + +This will return either a L or a +L, depending on if the relationship is +C (returns only one row) or C (returns many rows). The +method may also return C if the relationship doesn't exist for +this instance (like in the case of C relationships). =cut @@ -402,7 +445,7 @@ sub related_resultset { unless ref $self; my $rel = shift; my $rel_info = $self->relationship_info($rel); - $self->throw_exception( "No such relationship ${rel}" ) + $self->throw_exception( "No such relationship '$rel'" ) unless $rel_info; return $self->{related_resultsets}{$rel} ||= do { @@ -431,8 +474,8 @@ sub related_resultset { # keep in mind that the following if() block is part of a do{} - no return()s!!! if ($is_crosstable) { $self->throw_exception ( - "A cross-table relationship condition returned for statically declared '$rel'") - unless ref $rel_info->{cond} eq 'CODE'; + "A cross-table relationship condition returned for statically declared '$rel'" + ) unless ref $rel_info->{cond} eq 'CODE'; # A WHOREIFFIC hack to reinvoke the entire condition resolution # with the correct alias. Another way of doing this involves a @@ -497,12 +540,19 @@ sub related_resultset { =head2 search_related - @objects = $rs->search_related('relname', $cond, $attrs); - $objects_rs = $rs->search_related('relname', $cond, $attrs); +=over 4 + +=item Arguments: $rel_name, $cond?, L<\%attrs?|DBIx::Class::ResultSet/ATTRIBUTES> + +=item Return Value: L<$resultset|DBIx::Class::ResultSet> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) + +=back Run a search on a related resultset. The search will be restricted to the -item or items represented by the L it was called -upon. This method can be called on a ResultSet, a Row or a ResultSource class. +results represented by the L it was called +upon. + +See L for more information. =cut @@ -512,8 +562,6 @@ sub search_related { =head2 search_related_rs - ( $objects_rs ) = $rs->search_related_rs('relname', $cond, $attrs); - This method works exactly the same as search_related, except that it guarantees a resultset, even in list context. @@ -525,35 +573,42 @@ sub search_related_rs { =head2 count_related - $obj->count_related('relname', $cond, $attrs); +=over 4 + +=item Arguments: $rel_name, $cond?, L<\%attrs?|DBIx::Class::ResultSet/ATTRIBUTES> -Returns the count of all the items in the related resultset, restricted by the -current item or where conditions. Can be called on a -L or a -L object. +=item Return Value: $count + +=back + +Returns the count of all the rows in the related resultset, restricted by the +current result or where conditions. =cut sub count_related { - my $self = shift; - return $self->search_related(@_)->count; + shift->search_related(@_)->count; } =head2 new_related - my $new_obj = $obj->new_related('relname', \%col_data); +=over 4 + +=item Arguments: $rel_name, \%col_data + +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> -Create a new item of the related foreign class. If called on a -L object, it will magically -set any foreign key columns of the new object to the related primary -key columns of the source object for you. The newly created item will -not be saved into your storage until you call L -on it. +=back + +Create a new result object of the related foreign class. It will magically set +any foreign key columns of the new object to the related primary key columns +of the source object for you. The newly created result will not be saved into +your storage until you call L on it. =cut sub new_related { - my ($self, $rel, $values, $attrs) = @_; + my ($self, $rel, $values) = @_; # FIXME - this is a bad position for this (also an identical copy in # set_from_related), but I have no saner way to hook, and I absolutely @@ -582,17 +637,24 @@ sub new_related { } } - my $row = $self->search_related($rel)->new($values, $attrs); - return $row; + return $self->search_related($rel)->new_result($values); } =head2 create_related - my $new_obj = $obj->create_related('relname', \%col_data); +=over 4 + +=item Arguments: $rel_name, \%col_data + +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> + +=back + + my $result = $obj->create_related($rel_name, \%col_data); -Creates a new item, similarly to new_related, and also inserts the item's data -into your storage medium. See the distinction between C and C -in L for details. +Creates a new result object, similarly to new_related, and also inserts the +result's data into your storage medium. See the distinction between C +and C in L for details. =cut @@ -606,7 +668,15 @@ sub create_related { =head2 find_related - my $found_item = $obj->find_related('relname', @pri_vals | \%pri_vals); +=over 4 + +=item Arguments: $rel_name, \%col_data | @pk_values, { key => $unique_constraint, L<%attrs|DBIx::Class::ResultSet/ATTRIBUTES> }? + +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef + +=back + + my $result = $obj->find_related($rel_name, \%col_data); Attempt to find a related object using its primary key or unique constraints. See L for details. @@ -614,18 +684,22 @@ See L for details. =cut sub find_related { - my $self = shift; - my $rel = shift; - return $self->search_related($rel)->find(@_); + #my ($self, $rel, @args) = @_; + return shift->search_related(shift)->find(@_); } =head2 find_or_new_related - my $new_obj = $obj->find_or_new_related('relname', \%col_data); +=over 4 + +=item Arguments: $rel_name, \%col_data, { key => $unique_constraint, L<%attrs|DBIx::Class::ResultSet/ATTRIBUTES> }? -Find an item of a related class. If none exists, instantiate a new item of the -related class. The object will not be saved into your storage until you call -L on it. +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> + +=back + +Find a result object of a related class. See L +for details. =cut @@ -637,9 +711,15 @@ sub find_or_new_related { =head2 find_or_create_related - my $new_obj = $obj->find_or_create_related('relname', \%col_data); +=over 4 -Find or create an item of a related class. See +=item Arguments: $rel_name, \%col_data, { key => $unique_constraint, L<%attrs|DBIx::Class::ResultSet/ATTRIBUTES> }? + +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> + +=back + +Find or create a result object of a related class. See L for details. =cut @@ -652,21 +732,34 @@ sub find_or_create_related { =head2 update_or_create_related - my $updated_item = $obj->update_or_create_related('relname', \%col_data, \%attrs?); +=over 4 + +=item Arguments: $rel_name, \%col_data, { key => $unique_constraint, L<%attrs|DBIx::Class::ResultSet/ATTRIBUTES> }? + +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> + +=back -Update or create an item of a related class. See +Update or create a result object of a related class. See L for details. =cut sub update_or_create_related { - my $self = shift; - my $rel = shift; - return $self->related_resultset($rel)->update_or_create(@_); + #my ($self, $rel, @args) = @_; + shift->related_resultset(shift)->update_or_create(@_); } =head2 set_from_related +=over 4 + +=item Arguments: $rel_name, L<$result|DBIx::Class::Manual::ResultClass> + +=item Return Value: not defined + +=back + $book->set_from_related('author', $author_obj); $book->author($author_obj); ## same thing @@ -688,11 +781,11 @@ sub set_from_related { my $rsrc = $self->result_source; my $rel_info = $rsrc->relationship_info($rel) - or $self->throw_exception( "No such relationship ${rel}" ); + or $self->throw_exception( "No such relationship '$rel'" ); if (defined $f_obj) { my $f_class = $rel_info->{class}; - $self->throw_exception( "Object $f_obj isn't a ".$f_class ) + $self->throw_exception( "Object '$f_obj' isn't a ".$f_class ) unless blessed $f_obj and $f_obj->isa($f_class); } @@ -722,6 +815,14 @@ sub set_from_related { =head2 update_from_related +=over 4 + +=item Arguments: $rel_name, L<$result|DBIx::Class::Manual::ResultClass> + +=item Return Value: not defined + +=back + $book->update_from_related('author', $author_obj); The same as L, but the changes are immediately updated @@ -737,9 +838,20 @@ sub update_from_related { =head2 delete_related - $obj->delete_related('relname', $cond, $attrs); +=over 4 + +=item Arguments: $rel_name, $cond?, L<\%attrs?|DBIx::Class::ResultSet/ATTRIBUTES> + +=item Return Value: $underlying_storage_rv + +=back + +Delete any related row, subject to the given conditions. Internally, this +calls: + + $self->search_related(@_)->delete -Delete any related item subject to the given conditions. +And returns the result of that. =cut @@ -752,36 +864,60 @@ sub delete_related { =head2 add_to_$rel -B, C and 'multi' type +B, C and 'multi' type relationships.> +=head3 has_many / multi + +=over 4 + +=item Arguments: \%col_data + +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> + +=back + +Creates/inserts a new result object. Internally, this calls: + + $self->create_related($rel, @_) + +And returns the result of that. + +=head3 many_to_many + =over 4 -=item Arguments: ($foreign_vals | $obj), $link_vals? +=item Arguments: (\%col_data | L<$result|DBIx::Class::Manual::ResultClass>), \%link_col_data? + +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back my $role = $schema->resultset('Role')->find(1); $actor->add_to_roles($role); - # creates a My::DBIC::Schema::ActorRoles linking table row object + # creates a My::DBIC::Schema::ActorRoles linking table result object $actor->add_to_roles({ name => 'lead' }, { salary => 15_000_000 }); - # creates a new My::DBIC::Schema::Role row object and the linking table + # creates a new My::DBIC::Schema::Role result object and the linking table # object with an extra column in the link -Adds a linking table object for C<$obj> or C<$foreign_vals>. If the first -argument is a hash reference, the related object is created first with the -column values in the hash. If an object reference is given, just the linking -table object is created. In either case, any additional column values for the -linking table object can be specified in C<$link_vals>. +Adds a linking table object. If the first argument is a hash reference, the +related object is created first with the column values in the hash. If an object +reference is given, just the linking table object is created. In either case, +any additional column values for the linking table object can be specified in +C<\%link_col_data>. + +See L for additional details. =head2 set_$rel -B relationships.> +B relationships.> =over 4 -=item Arguments: (\@hashrefs | \@objs), $link_vals? +=item Arguments: (\@hashrefs_of_col_data | L<\@result_objs|DBIx::Class::Manual::ResultClass>), $link_vals? + +=item Return Value: not defined =back @@ -811,25 +947,27 @@ removed in a future version. =head2 remove_from_$rel -B relationships.> +B relationships.> =over 4 -=item Arguments: $obj +=item Arguments: L<$result|DBIx::Class::Manual::ResultClass> + +=item Return Value: not defined =back my $role = $schema->resultset('Role')->find(1); $actor->remove_from_roles($role); - # removes $role's My::DBIC::Schema::ActorRoles linking table row object + # removes $role's My::DBIC::Schema::ActorRoles linking table result object Removes the link between the current object and the related object. Note that the related object itself won't be deleted unless you call ->delete() on it. This method just removes the link between the two objects. -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S. Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/Relationship/BelongsTo.pm b/lib/DBIx/Class/Relationship/BelongsTo.pm index 76ffb50..e55d1bd 100644 --- a/lib/DBIx/Class/Relationship/BelongsTo.pm +++ b/lib/DBIx/Class/Relationship/BelongsTo.pm @@ -28,19 +28,19 @@ sub belongs_to { $class->ensure_class_loaded($f_class); my %f_primaries = map { $_ => 1 } try { $f_class->_pri_cols } catch { - $class->throw_exception( "Can't infer join condition for ${rel} on ${class}: $_"); + $class->throw_exception( "Can't infer join condition for '$rel' on ${class}: $_"); }; my ($pri, $too_many) = keys %f_primaries; $class->throw_exception( - "Can't infer join condition for ${rel} on ${class}; ". - "${f_class} has multiple primary keys" + "Can't infer join condition for '$rel' on ${class}: " + . "${f_class} has multiple primary keys" ) if $too_many; my $fk = defined $cond ? $cond : $rel; $class->throw_exception( - "Can't infer join condition for ${rel} on ${class}; ". - "$fk is not a column of $class" + "Can't infer join condition for '$rel' on ${class}: " + . "'$fk' is not a column of $class" ) unless $class->has_column($fk); $cond = { "foreign.${pri}" => "self.${fk}" }; diff --git a/lib/DBIx/Class/Relationship/HasMany.pm b/lib/DBIx/Class/Relationship/HasMany.pm index b8a9b4c..16fa0ba 100644 --- a/lib/DBIx/Class/Relationship/HasMany.pm +++ b/lib/DBIx/Class/Relationship/HasMany.pm @@ -18,7 +18,7 @@ sub has_many { $class->ensure_class_loaded($f_class); my ($pri, $too_many) = try { $class->_pri_cols } catch { - $class->throw_exception("Can't infer join condition for ${rel} on ${class}: $_"); + $class->throw_exception("Can't infer join condition for '$rel' on ${class}: $_"); }; $class->throw_exception( @@ -43,7 +43,7 @@ sub has_many { my $f_class_loaded = try { $f_class->columns }; $class->throw_exception( - "No such column ${f_key} on foreign class ${f_class} ($guess)" + "No such column '$f_key' on foreign class ${f_class} ($guess)" ) if $f_class_loaded && !$f_class->has_column($f_key); $cond = { "foreign.${f_key}" => "self.${pri}" }; diff --git a/lib/DBIx/Class/Relationship/HasOne.pm b/lib/DBIx/Class/Relationship/HasOne.pm index f9046ca..09ea77c 100644 --- a/lib/DBIx/Class/Relationship/HasOne.pm +++ b/lib/DBIx/Class/Relationship/HasOne.pm @@ -45,7 +45,7 @@ sub _has_one { $guess = "using primary key of foreign class for foreign key"; } $class->throw_exception( - "No such column ${f_key} on foreign class ${f_class} ($guess)" + "No such column '$f_key' on foreign class ${f_class} ($guess)" ) if $f_class_loaded && !$f_class->has_column($f_key); $cond = { "foreign.${f_key}" => "self.${pri}" }; } @@ -90,7 +90,7 @@ sub _validate_has_one_condition { # warning return unless $self_id =~ /^self\.(.*)$/; my $key = $1; - $class->throw_exception("Defining rel on ${class} that includes ${key} but no such column defined here yet") + $class->throw_exception("Defining rel on ${class} that includes '$key' but no such column defined here yet") unless $class->has_column($key); my $column_info = $class->column_info($key); if ( $column_info->{is_nullable} ) { diff --git a/lib/DBIx/Class/ResultClass/HashRefInflator.pm b/lib/DBIx/Class/ResultClass/HashRefInflator.pm index 3df5f20..4223930 100644 --- a/lib/DBIx/Class/ResultClass/HashRefInflator.pm +++ b/lib/DBIx/Class/ResultClass/HashRefInflator.pm @@ -30,7 +30,7 @@ DBIx::Class::ResultClass::HashRefInflator - Get raw hashrefs from a resultset DBIx::Class is faster than older ORMs like Class::DBI but it still isn't designed primarily for speed. Sometimes you need to quickly retrieve the data -from a massive resultset, while skipping the creation of fancy row objects. +from a massive resultset, while skipping the creation of fancy result objects. Specifying this class as a C for a resultset will change C<< $rs->next >> to return a plain data hash-ref (or a list of such hash-refs if C<< $rs->all >> is used). diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index d4c271a..5ec88d0 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -4,7 +4,6 @@ use strict; use warnings; use base qw/DBIx::Class/; use DBIx::Class::Carp; -use DBIx::Class::Exception; use DBIx::Class::ResultSetColumn; use Scalar::Util qw/blessed weaken/; use Try::Tiny; @@ -34,12 +33,12 @@ DBIx::Class::ResultSet - Represents a query used for fetching a set of results. =head1 SYNOPSIS - my $users_rs = $schema->resultset('User'); + my $users_rs = $schema->resultset('User'); while( $user = $users_rs->next) { print $user->username; } - my $registered_users_rs = $schema->resultset('User')->search({ registered => 1 }); + my $registered_users_rs = $schema->resultset('User')->search({ registered => 1 }); my @cds_in_2005 = $schema->resultset('CD')->search({ year => 2005 })->all(); =head1 DESCRIPTION @@ -191,9 +190,9 @@ See: L, L, L, L, L. =over 4 -=item Arguments: $source, \%$attrs +=item Arguments: L<$source|DBIx::Class::ResultSource>, L<\%attrs?|/ATTRIBUTES> -=item Return Value: $rs +=item Return Value: L<$resultset|/search> =back @@ -202,16 +201,31 @@ L) and an attribute hash (see L below). Does not perform any queries -- these are executed as needed by the other methods. -Generally you won't need to construct a resultset manually. You'll -automatically get one from e.g. a L called in scalar context: +Generally you never construct a resultset manually. Instead you get one +from e.g. a +C<< $schema->L('$source_name') >> +or C<< $another_resultset->L(...) >> (the later called in +scalar context): my $rs = $schema->resultset('CD')->search({ title => '100th Window' }); -IMPORTANT: If called on an object, proxies to new_result instead so +=over + +=item WARNING + +If called on an object, proxies to L instead, so my $cd = $schema->resultset('CD')->new({ title => 'Spoon' }); -will return a CD object, not a ResultSet. +will return a CD object, not a ResultSet, and is equivalent to: + + my $cd = $schema->resultset('CD')->new_result({ title => 'Spoon' }); + +Please also keep in mind that many internals call L directly, +so overloading this method with the idea of intercepting new result object +creation B. See also warning pertaining to L. + +=back =cut @@ -254,9 +268,9 @@ sub new { =over 4 -=item Arguments: $cond, \%attrs? +=item Arguments: L<$cond|DBIx::Class::SQLMaker> | undef, L<\%attrs?|/ATTRIBUTES> -=item Return Value: $resultset (scalar context) || @row_objs (list context) +=item Return Value: $resultset (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back @@ -267,7 +281,8 @@ sub new { # year = 2005 OR year = 2004 In list context, C<< ->all() >> is called implicitly on the resultset, thus -returning a list of row objects instead. To avoid that, use L. +returning a list of L objects instead. +To avoid that, use L. If you need to pass in additional attributes but no additional condition, call it as C. @@ -289,7 +304,7 @@ For more help on using joins with search, see L. Note that L does not process/deflate any of the values passed in the L-compatible search condition structure. This is unlike other -condition-bound methods L, L and L. The user must ensure +condition-bound methods L, L and L. The user must ensure manually that any value passed to this method will stringify to something the RDBMS knows how to deal with. A notable example is the handling of L objects, for more info see: @@ -324,9 +339,9 @@ sub search { =over 4 -=item Arguments: $cond, \%attrs? +=item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES> -=item Return Value: $resultset +=item Return Value: L<$resultset|/search> =back @@ -338,20 +353,36 @@ always return a resultset, even in list context. sub search_rs { my $self = shift; - # Special-case handling for (undef, undef). - if ( @_ == 2 && !defined $_[1] && !defined $_[0] ) { - @_ = (); - } + my $rsrc = $self->result_source; + my ($call_cond, $call_attrs); - my $call_attrs = {}; - if (@_ > 1) { - if (ref $_[-1] eq 'HASH') { - # copy for _normalize_selection - $call_attrs = { %{ pop @_ } }; - } - elsif (! defined $_[-1] ) { - pop @_; # search({}, undef) + # Special-case handling for (undef, undef) or (undef) + # Note that (foo => undef) is valid deprecated syntax + @_ = () if not scalar grep { defined $_ } @_; + + # just a cond + if (@_ == 1) { + $call_cond = shift; + } + # fish out attrs in the ($condref, $attr) case + elsif (@_ == 2 and ( ! defined $_[0] or (ref $_[0]) ne '') ) { + ($call_cond, $call_attrs) = @_; + } + elsif (@_ % 2) { + $self->throw_exception('Odd number of arguments to search') + } + # legacy search + elsif (@_) { + carp_unique 'search( %condition ) is deprecated, use search( \%condition ) instead' + unless $rsrc->result_class->isa('DBIx::Class::CDBICompat'); + + for my $i (0 .. $#_) { + next if $i % 2; + $self->throw_exception ('All keys in condition key/value pairs must be plain scalars') + if (! defined $_[$i] or ref $_[$i] ne ''); } + + $call_cond = { @_ }; } # see if we can keep the cache (no $rs changes) @@ -367,8 +398,6 @@ sub search_rs { $cache = $self->get_cache; } - my $rsrc = $self->result_source; - my $old_attrs = { %{$self->{attrs}} }; my $old_having = delete $old_attrs->{having}; my $old_where = delete $old_attrs->{where}; @@ -376,7 +405,10 @@ sub search_rs { my $new_attrs = { %$old_attrs }; # take care of call attrs (only if anything is changing) - if (keys %$call_attrs) { + if ($call_attrs and keys %$call_attrs) { + + # copy for _normalize_selection + $call_attrs = { %$call_attrs }; my @selector_attrs = qw/select as columns cols +select +as +columns include_columns/; @@ -423,28 +455,6 @@ sub search_rs { } - # rip apart the rest of @_, parse a condition - my $call_cond = do { - - if (ref $_[0] eq 'HASH') { - (keys %{$_[0]}) ? $_[0] : undef - } - elsif (@_ == 1) { - $_[0] - } - elsif (@_ % 2) { - $self->throw_exception('Odd number of arguments to search') - } - else { - +{ @_ } - } - - } if @_; - - if( @_ > 1 and ! $rsrc->result_class->isa('DBIx::Class::CDBICompat') ) { - carp_unique 'search( %condition ) is deprecated, use search( \%condition ) instead'; - } - for ($old_where, $call_cond) { if (defined $_) { $new_attrs->{where} = $self->_stack_cond ( @@ -617,11 +627,20 @@ sub _stack_cond { =head2 search_literal +B: C is provided for Class::DBI compatibility and +should only be used in that context. C is a convenience +method. It is equivalent to calling C<< $schema->search(\[]) >>, but if you +want to ensure columns are bound correctly, use L. + +See L and +L for searching techniques that do not +require C. + =over 4 -=item Arguments: $sql_fragment, @bind_values +=item Arguments: $sql_fragment, @standalone_bind_values -=item Return Value: $resultset (scalar context) || @row_objs (list context) +=item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back @@ -631,21 +650,11 @@ sub _stack_cond { Pass a literal chunk of SQL to be added to the conditional part of the resultset query. -CAVEAT: C is provided for Class::DBI compatibility and should -only be used in that context. C is a convenience method. -It is equivalent to calling $schema->search(\[]), but if you want to ensure -columns are bound correctly, use C. - Example of how to use C instead of C 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 and -L for searching techniques that do not -require C. - =cut sub search_literal { @@ -654,16 +663,16 @@ sub search_literal { if ( @bind && ref($bind[-1]) eq 'HASH' ) { $attr = pop @bind; } - return $self->search(\[ $sql, map [ __DUMMY__ => $_ ], @bind ], ($attr || () )); + return $self->search(\[ $sql, map [ {} => $_ ], @bind ], ($attr || () )); } =head2 find =over 4 -=item Arguments: \%columns_values | @pk_values, \%attrs? +=item Arguments: \%columns_values | @pk_values, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }? -=item Return Value: $row_object | undef +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef =back @@ -695,7 +704,7 @@ Note that this fallback behavior may be deprecated in further versions. If you need to search with arbitrary conditions - use L. If the query resulting from this fallback produces more than one row, a warning to the effect is issued, though only the first row is constructed and returned as -C<$row_object>. +C<$result_object>. In addition to C, L recognizes and applies standard L in the same way as L does. @@ -909,7 +918,7 @@ sub _build_unique_cond { and !$ENV{DBIC_NULLABLE_KEY_NOWARN} and - my @undefs = grep { ! defined $final_cond->{$_} } (keys %$final_cond) + my @undefs = sort grep { ! defined $final_cond->{$_} } (keys %$final_cond) ) { carp_unique ( sprintf ( "NULL/undef values supplied for requested unique constraint '%s' (NULL " @@ -927,9 +936,9 @@ sub _build_unique_cond { =over 4 -=item Arguments: $rel, $cond?, \%attrs? +=item Arguments: $rel_name, $cond?, L<\%attrs?|/ATTRIBUTES> -=item Return Value: $new_resultset (scalar context) || @row_objs (list context) +=item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back @@ -941,7 +950,7 @@ Searches the specified relationship, optionally specifying a condition and attributes for matching records. See L for more information. In list context, C<< ->all() >> is called implicitly on the resultset, thus -returning a list of row objects instead. To avoid that, use L. +returning a list of result objects instead. To avoid that, use L. See also L. @@ -968,7 +977,7 @@ sub search_related_rs { =item Arguments: none -=item Return Value: $cursor +=item Return Value: L<$cursor|DBIx::Class::Cursor> =back @@ -978,22 +987,23 @@ L for more information. =cut sub cursor { - my ($self) = @_; - - my $attrs = $self->_resolved_attrs_copy; + my $self = shift; - return $self->{cursor} - ||= $self->result_source->storage->select($attrs->{from}, $attrs->{select}, - $attrs->{where},$attrs); + return $self->{cursor} ||= do { + my $attrs = { %{$self->_resolved_attrs } }; + $self->result_source->storage->select( + $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs + ); + }; } =head2 single =over 4 -=item Arguments: $cond? +=item Arguments: L<$cond?|DBIx::Class::SQLMaker> -=item Return Value: $row_object | undef +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef =back @@ -1036,7 +1046,7 @@ sub single { $self->throw_exception('single() only takes search conditions, no attributes. You want ->search( $cond, $attrs )->single()'); } - my $attrs = $self->_resolved_attrs_copy; + my $attrs = { %{$self->_resolved_attrs} }; $self->throw_exception( 'single() can not be used on resultsets prefetching has_many. Use find( \%cond ) or next() instead' @@ -1100,9 +1110,9 @@ sub _collapse_query { =over 4 -=item Arguments: $cond? +=item Arguments: L<$cond?|DBIx::Class::SQLMaker> -=item Return Value: $resultsetcolumn +=item Return Value: L<$resultsetcolumn|DBIx::Class::ResultSetColumn> =back @@ -1122,9 +1132,9 @@ sub get_column { =over 4 -=item Arguments: $cond, \%attrs? +=item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES> -=item Return Value: $resultset (scalar context) || @row_objs (list context) +=item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back @@ -1167,7 +1177,7 @@ sub search_like { =item Arguments: $first, $last -=item Return Value: $resultset (scalar context) || @row_objs (list context) +=item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back @@ -1196,7 +1206,7 @@ sub slice { =item Arguments: none -=item Return Value: $result | undef +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef =back @@ -1307,10 +1317,11 @@ sub _construct_objects { push @$rows, do { my @r = $cursor->next; @r ? \@r : () }; } # instead of looping over ->next, use ->all in stealth mode + # *without* calling a ->reset afterwards # FIXME - encapsulation breach, got to be a better way - elsif (! $cursor->{done}) { + elsif (! $cursor->{_done}) { push @$rows, $cursor->all; - $cursor->{done} = 1; + $cursor->{_done} = 1; $fetch_all = 1; } } @@ -1373,9 +1384,9 @@ sub _construct_objects { =over 4 -=item Arguments: $result_source? +=item Arguments: L<$result_source?|DBIx::Class::ResultSource> -=item Return Value: $result_source +=item Return Value: L<$result_source|DBIx::Class::ResultSource> =back @@ -1392,7 +1403,7 @@ is derived. =back -An accessor for the class to use when creating row objects. Defaults to +An accessor for the class to use when creating result objects. Defaults to C<< result_source->result_class >> - which in most cases is the name of the L<"table"|DBIx::Class::Manual::Glossary/"ResultSource"> class. @@ -1422,7 +1433,7 @@ sub result_class { =over 4 -=item Arguments: $cond, \%attrs?? +=item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES> =item Return Value: $count @@ -1439,7 +1450,7 @@ sub count { return $self->search(@_)->count if @_ and defined $_[0]; return scalar @{ $self->get_cache } if $self->get_cache; - my $attrs = $self->_resolved_attrs_copy; + my $attrs = { %{ $self->_resolved_attrs } }; # this is a little optimization - it is faster to do the limit # adjustments in software, instead of a subquery @@ -1465,9 +1476,9 @@ sub count { =over 4 -=item Arguments: $cond, \%attrs?? +=item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES> -=item Return Value: $count_rs +=item Return Value: L<$count_rs|DBIx::Class::ResultSetColumn> =back @@ -1573,18 +1584,22 @@ sub _count_subq_rs { my ($lquote, $rquote, $sep) = map { quotemeta $_ } ($sql_maker->_quote_chars, $sql_maker->name_sep); - my $sql = $sql_maker->_parse_rs_attrs ({ having => $attrs->{having} }); + my $having_sql = $sql_maker->_parse_rs_attrs ({ having => $attrs->{having} }); + my %seen_having; # search for both a proper quoted qualified string, for a naive unquoted scalarref # and if all fails for an utterly naive quoted scalar-with-function - while ($sql =~ / + while ($having_sql =~ / $rquote $sep $lquote (.+?) $rquote | [\s,] \w+ \. (\w+) [\s,] | [\s,] $lquote (.+?) $rquote [\s,] /gx) { - push @parts, ($1 || $2 || $3); # one of them matched if we got here + my $part = $1 || $2 || $3; # one of them matched if we got here + unless ($seen_having{$part}++) { + push @parts, $part; + } } } @@ -1620,9 +1635,12 @@ sub _bool { =head2 count_literal +B: C is provided for Class::DBI compatibility and +should only be used in that context. See L for further info. + =over 4 -=item Arguments: $sql_fragment, @bind_values +=item Arguments: $sql_fragment, @standalone_bind_values =item Return Value: $count @@ -1641,7 +1659,7 @@ sub count_literal { shift->search_literal(@_)->count; } =item Arguments: none -=item Return Value: @objects +=item Return Value: L<@result_objs|DBIx::Class::Manual::ResultClass> =back @@ -1689,8 +1707,7 @@ another query. sub reset { my ($self) = @_; - delete @{$self}{qw/_attrs stashed_rows stashed_objects/}; - + delete @{$self}{qw/stashed_rows stashed_objects/}; $self->{all_cache_position} = 0; $self->cursor->reset; return $self; @@ -1702,12 +1719,12 @@ sub reset { =item Arguments: none -=item Return Value: $object | undef +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef =back -Resets the resultset and returns an object for the first result (or C -if the resultset is empty). +L the resultset (causing a fresh query to storage) and returns +an object for the first result (or C if the resultset is empty). =cut @@ -1725,154 +1742,146 @@ sub first { sub _rs_update_delete { my ($self, $op, $values) = @_; - my $cond = $self->{cond}; my $rsrc = $self->result_source; my $storage = $rsrc->schema->storage; my $attrs = { %{$self->_resolved_attrs} }; - # "needs" is a strong word here - if the subquery is part of an IN clause - no point of - # even adding the group_by. It will really be used only when composing a poor-man's - # multicolumn-IN equivalent OR set - my $needs_group_by_subq = defined $attrs->{group_by}; - - # simplify the joinmap and maybe decide if a grouping (and thus subquery) is necessary - my $relation_classifications; - if (ref($attrs->{from}) eq 'ARRAY') { - $attrs->{from} = $storage->_prune_unused_joins ($attrs->{from}, $attrs->{select}, $cond, $attrs); - - $relation_classifications = $storage->_resolve_aliastypes_from_select_args ( - [ @{$attrs->{from}}[1 .. $#{$attrs->{from}}] ], - $attrs->{select}, - $cond, - $attrs - ) unless $needs_group_by_subq; # we already know we need a group, no point of resolving them - } - else { - $needs_group_by_subq ||= 1; # if {from} is unparseable assume the worst - } - - $needs_group_by_subq ||= exists $relation_classifications->{multiplying}; + my $join_classifications; + my $existing_group_by = delete $attrs->{group_by}; - # if no subquery - life is easy-ish - unless ( - $needs_group_by_subq + # do we need a subquery for any reason? + my $needs_subq = ( + defined $existing_group_by or - keys %$relation_classifications # if any joins at all - need to wrap a subq + # if {from} is unparseable wrap a subq + ref($attrs->{from}) ne 'ARRAY' or - $self->_has_resolved_attr(qw/rows offset/) # limits call for a subq - ) { - # Most databases do not allow aliasing of tables in UPDATE/DELETE. Thus - # a condition containing 'me' or other table prefixes will not work - # at all. What this code tries to do (badly) is to generate a condition - # with the qualifiers removed, by exploiting the quote mechanism of sqla - # - # this is atrocious and should be replaced by normal sqla introspection - # one sunny day - my ($sql, @bind) = do { - my $sqla = $rsrc->storage->sql_maker; - local $sqla->{_dequalify_idents} = 1; - $sqla->_recurse_where($self->{cond}); - } if $self->{cond}; + # limits call for a subq + $self->_has_resolved_attr(qw/rows offset/) + ); - return $rsrc->storage->$op( - $rsrc, - $op eq 'update' ? $values : (), - $self->{cond} ? \[$sql, @bind] : (), - ); + # simplify the joinmap, so we can further decide if a subq is necessary + if (!$needs_subq and @{$attrs->{from}} > 1) { + $attrs->{from} = $storage->_prune_unused_joins ($attrs->{from}, $attrs->{select}, $self->{cond}, $attrs); + + # check if there are any joins left after the prune + if ( @{$attrs->{from}} > 1 ) { + $join_classifications = $storage->_resolve_aliastypes_from_select_args ( + [ @{$attrs->{from}}[1 .. $#{$attrs->{from}}] ], + $attrs->{select}, + $self->{cond}, + $attrs + ); + + # any non-pruneable joins imply subq + $needs_subq = scalar keys %{ $join_classifications->{restricting} || {} }; + } } - # we got this far - means it is time to wrap a subquery - my $idcols = $rsrc->_identifying_column_set || $self->throw_exception( - sprintf( - "Unable to perform complex resultset %s() without an identifying set of columns on source '%s'", - $op, - $rsrc->source_name, - ) + # check if the head is composite (by now all joins are thrown out unless $needs_subq) + $needs_subq ||= ( + (ref $attrs->{from}[0]) ne 'HASH' + or + ref $attrs->{from}[0]{ $attrs->{from}[0]{-alias} } ); - my $existing_group_by = delete $attrs->{group_by}; - - # make a new $rs selecting only the PKs (that's all we really need for the subq) - delete @{$attrs}{qw/collapse select _prefetch_selector_range as/}; - $attrs->{columns} = [ map { "$attrs->{alias}.$_" } @$idcols ]; - $attrs->{group_by} = \ ''; # FIXME - this is an evil hack, it causes the optimiser to kick in and throw away the LEFT joins - my $subrs = (ref $self)->new($rsrc, $attrs); - if (@$idcols == 1) { - return $storage->$op ( - $rsrc, - $op eq 'update' ? $values : (), - { $idcols->[0] => { -in => $subrs->as_query } }, - ); + my ($cond, $guard); + # do we need anything like a subquery? + if (! $needs_subq) { + # Most databases do not allow aliasing of tables in UPDATE/DELETE. Thus + # a condition containing 'me' or other table prefixes will not work + # at all. Tell SQLMaker to dequalify idents via a gross hack. + $cond = do { + my $sqla = $rsrc->storage->sql_maker; + local $sqla->{_dequalify_idents} = 1; + \[ $sqla->_recurse_where($self->{cond}) ]; + }; } - elsif ($storage->_use_multicolumn_in) { - # This is hideously ugly, but SQLA does not understand multicol IN expressions - my $sql_maker = $storage->sql_maker; - my ($sql, @bind) = @${$subrs->as_query}; - $sql = sprintf ('(%s) IN %s', # the as_query already comes with a set of parenthesis - join (', ', map { $sql_maker->_quote ($_) } @$idcols), - $sql, + else { + # we got this far - means it is time to wrap a subquery + my $idcols = $rsrc->_identifying_column_set || $self->throw_exception( + sprintf( + "Unable to perform complex resultset %s() without an identifying set of columns on source '%s'", + $op, + $rsrc->source_name, + ) ); - return $storage->$op ( - $rsrc, - $op eq 'update' ? $values : (), - \[$sql, @bind], - ); - } - else { - # if all else fails - get all primary keys and operate over a ORed set - # wrap in a transaction for consistency - # this is where the group_by starts to matter - my $subq_group_by; - if ($needs_group_by_subq) { - $subq_group_by = $attrs->{columns}; - - # make sure if there is a supplied group_by it matches the columns compiled above - # perfectly. Anything else can not be sanely executed on most databases so croak - # right then and there - if ($existing_group_by) { - my @current_group_by = map - { $_ =~ /\./ ? $_ : "$attrs->{alias}.$_" } - @$existing_group_by - ; + # make a new $rs selecting only the PKs (that's all we really need for the subq) + delete $attrs->{$_} for qw/collapse select _prefetch_selector_range as/; + $attrs->{columns} = [ map { "$attrs->{alias}.$_" } @$idcols ]; + $attrs->{group_by} = \ ''; # FIXME - this is an evil hack, it causes the optimiser to kick in and throw away the LEFT joins + my $subrs = (ref $self)->new($rsrc, $attrs); - if ( - join ("\x00", sort @current_group_by) - ne - join ("\x00", sort @$subq_group_by ) - ) { - $self->throw_exception ( - "You have just attempted a $op operation on a resultset which does group_by" - . ' on columns other than the primary keys, while DBIC internally needs to retrieve' - . ' the primary keys in a subselect. All sane RDBMS engines do not support this' - . ' kind of queries. Please retry the operation with a modified group_by or' - . ' without using one at all.' - ); + if (@$idcols == 1) { + $cond = { $idcols->[0] => { -in => $subrs->as_query } }; + } + elsif ($storage->_use_multicolumn_in) { + # no syntax for calling this properly yet + # !!! EXPERIMENTAL API !!! WILL CHANGE !!! + $cond = $storage->sql_maker->_where_op_multicolumn_in ( + $idcols, # how do I convey a list of idents...? can binds reside on lhs? + $subrs->as_query + ), + } + else { + # if all else fails - get all primary keys and operate over a ORed set + # wrap in a transaction for consistency + # this is where the group_by/multiplication starts to matter + if ( + $existing_group_by + or + keys %{ $join_classifications->{multiplying} || {} } + ) { + # make sure if there is a supplied group_by it matches the columns compiled above + # perfectly. Anything else can not be sanely executed on most databases so croak + # right then and there + if ($existing_group_by) { + my @current_group_by = map + { $_ =~ /\./ ? $_ : "$attrs->{alias}.$_" } + @$existing_group_by + ; + + if ( + join ("\x00", sort @current_group_by) + ne + join ("\x00", sort @{$attrs->{columns}} ) + ) { + $self->throw_exception ( + "You have just attempted a $op operation on a resultset which does group_by" + . ' on columns other than the primary keys, while DBIC internally needs to retrieve' + . ' the primary keys in a subselect. All sane RDBMS engines do not support this' + . ' kind of queries. Please retry the operation with a modified group_by or' + . ' without using one at all.' + ); + } } + + $subrs = $subrs->search({}, { group_by => $attrs->{columns} }); } - } - my $guard = $storage->txn_scope_guard; + $guard = $storage->txn_scope_guard; - my @op_condition; - for my $row ($subrs->search({}, { group_by => $subq_group_by })->cursor->all) { - push @op_condition, { map - { $idcols->[$_] => $row->[$_] } - (0 .. $#$idcols) - }; + $cond = []; + for my $row ($subrs->cursor->all) { + push @$cond, { map + { $idcols->[$_] => $row->[$_] } + (0 .. $#$idcols) + }; + } } + } - my $res = $storage->$op ( - $rsrc, - $op eq 'update' ? $values : (), - \@op_condition, - ); + my $res = $storage->$op ( + $rsrc, + $op eq 'update' ? $values : (), + $cond, + ); - $guard->commit; + $guard->commit if $guard; - return $res; - } + return $res; } =head2 update @@ -1881,13 +1890,13 @@ sub _rs_update_delete { =item Arguments: \%values -=item Return Value: $storage_rv +=item Return Value: $underlying_storage_rv =back Sets the specified columns in the resultset to the supplied values in a single query. Note that this will not run any accessor/set_column/update -triggers, nor will it update any row object instances derived from this +triggers, nor will it update any result object instances derived from this resultset (this includes the contents of the L if any). See L if you need to execute any on-update triggers or cascades defined either by you or a @@ -1949,13 +1958,13 @@ sub update_all { =item Arguments: none -=item Return Value: $storage_rv +=item Return Value: $underlying_storage_rv =back Deletes the rows matching this resultset in a single query. Note that this will not run any delete triggers, nor will it alter the -L status of any row object instances +L status of any result object instances derived from this resultset (this includes the contents of the L if any). See L if you need to execute any on-delete triggers or cascades defined either by you or a @@ -2005,28 +2014,55 @@ sub delete_all { =over 4 -=item Arguments: \@data; +=item Arguments: [ \@column_list, \@row_values+ ] | [ \%col_data+ ] + +=item Return Value: L<\@result_objects|DBIx::Class::Manual::ResultClass> (scalar context) | L<@result_objects|DBIx::Class::Manual::ResultClass> (list context) =back -Accepts either an arrayref of hashrefs or alternatively an arrayref of arrayrefs. -For the arrayref of hashrefs style each hashref should be a structure suitable -for submitting to a $resultset->create(...) method. +Accepts either an arrayref of hashrefs or alternatively an arrayref of +arrayrefs. + +=over + +=item NOTE -In void context, C in L is used -to insert the data, as this is a faster method. +The context of this method call has an important effect on what is +submitted to storage. In void context data is fed directly to fastpath +insertion routines provided by the underlying storage (most often +L), bypassing the L and +L calls on the +L class, including any +augmentation of these methods provided by components. For example if you +are using something like L to create primary +keys for you, you will find that your PKs are empty. In this case you +will have to explicitly force scalar or list context in order to create +those values. -Otherwise, each set of data is inserted into the database using -L, and the resulting objects are -accumulated into an array. The array itself, or an array reference -is returned depending on scalar or list context. +=back -Example: Assuming an Artist Class that has many CDs Classes relating: +In non-void (scalar or list) context, this method is simply a wrapper +for L. Depending on list or scalar context either a list of +L objects or an arrayref +containing these objects is returned. + +When supplying data in "arrayref of arrayrefs" invocation style, the +first element should be a list of column names and each subsequent +element should be a data value in the earlier specified column order. +For example: + + $Arstist_rs->populate([ + [ qw( artistid name ) ], + [ 100, 'A Formally Unknown Singer' ], + [ 101, 'A singer that jumped the shark two albums ago' ], + [ 102, 'An actually cool singer' ], + ]); - my $Artist_rs = $schema->resultset("Artist"); +For the arrayref of hashrefs style each hashref should be a structure +suitable for passing to L. Multi-create is also permitted with +this syntax. - ## Void Context Example - $Artist_rs->populate([ + $schema->resultset("Artist")->populate([ { artistid => 4, name => 'Manufactured Crap', cds => [ { title => 'My First CD', year => 2006 }, { title => 'Yet More Tweeny-Pop crap', year => 2007 }, @@ -2040,37 +2076,11 @@ Example: Assuming an Artist Class that has many CDs Classes relating: }, ]); - ## Array Context Example - my ($ArtistOne, $ArtistTwo, $ArtistThree) = $Artist_rs->populate([ - { name => "Artist One"}, - { name => "Artist Two"}, - { name => "Artist Three", cds=> [ - { title => "First CD", year => 2007}, - { title => "Second CD", year => 2008}, - ]} - ]); - - print $ArtistOne->name; ## response is 'Artist One' - print $ArtistThree->cds->count ## reponse is '2' - -For the arrayref of arrayrefs style, the first element should be a list of the -fieldsnames to which the remaining elements are rows being inserted. For -example: - - $Arstist_rs->populate([ - [qw/artistid name/], - [100, 'A Formally Unknown Singer'], - [101, 'A singer that jumped the shark two albums ago'], - [102, 'An actually cool singer'], - ]); - -Please note an important effect on your data when choosing between void and -wantarray context. Since void context goes straight to C in -L this will skip any component that is overriding -C. So if you are using something like L to -create primary keys for you, you will find that your PKs are empty. In this -case you will have to use the wantarray context in order to create those -values. +If you attempt a void-context multi-create as in the example above (each +Artist also has the related list of CDs), and B supply the +necessary autoinc foreign key information, this method will proxy to the +less efficient L, and then throw the Result objects away. In this +case there are obviously no benefits to using this method over L. =cut @@ -2083,10 +2093,7 @@ sub populate { return unless @$data; if(defined wantarray) { - my @created; - foreach my $item (@$data) { - push(@created, $self->create($item)); - } + my @created = map { $self->create($_) } @$data; return wantarray ? @created : \@created; } else { @@ -2141,14 +2148,12 @@ sub populate { ## inherit the data locked in the conditions of the resultset my ($rs_data) = $self->_merge_with_rscond({}); delete @{$rs_data}{@columns}; - my @inherit_cols = keys %$rs_data; - my @inherit_data = values %$rs_data; ## do bulk insert on current row $rsrc->storage->insert_bulk( $rsrc, - [@columns, @inherit_cols], - [ map { [ @$_{@columns}, @inherit_data ] } @$data ], + [@columns, keys %$rs_data], + [ map { [ @$_{@columns}, values %$rs_data ] } @$data ], ); ## do the has_many relationships @@ -2211,11 +2216,11 @@ sub _normalize_populate_args { =item Arguments: none -=item Return Value: $pager +=item Return Value: L<$pager|Data::Page> =back -Return Value a L object for the current resultset. Only makes +Returns a L object for the current resultset. Only makes sense for queries with a C attribute. To get the full count of entries for a paged resultset, call @@ -2258,7 +2263,7 @@ sub pager { =item Arguments: $page_number -=item Return Value: $rs +=item Return Value: L<$resultset|/search> =back @@ -2277,16 +2282,16 @@ sub page { =over 4 -=item Arguments: \%vals +=item Arguments: \%col_data -=item Return Value: $rowobject +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back -Creates a new row object in the resultset's result class and returns +Creates a new result object in the resultset's result class and returns it. The row is not inserted into the database at this point, call L to do that. Calling L -will tell you whether the row object has been inserted or not. +will tell you whether the result object has been inserted or not. Passes the hashref of input on to L. @@ -2294,7 +2299,11 @@ Passes the hashref of input on to L. sub new_result { my ($self, $values) = @_; - $self->throw_exception( "new_result needs a hash" ) + + $self->throw_exception( "new_result takes only one argument - a hashref of values" ) + if @_ > 2; + + $self->throw_exception( "new_result expects a hashref" ) unless (ref $values eq 'HASH'); my ($merged_cond, $cols_from_relations) = $self->_merge_with_rscond($values); @@ -2480,7 +2489,7 @@ sub _remove_alias { =item Arguments: none -=item Return Value: \[ $sql, @bind ] +=item Return Value: \[ $sql, L<@bind_values|/DBIC BIND VALUES> ] =back @@ -2493,7 +2502,7 @@ This is generally used as the RHS for a subquery. sub as_query { my $self = shift; - my $attrs = $self->_resolved_attrs_copy; + my $attrs = { %{ $self->_resolved_attrs } }; # For future use: # @@ -2511,9 +2520,9 @@ sub as_query { =over 4 -=item Arguments: \%vals, \%attrs? +=item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }? -=item Return Value: $rowobject +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back @@ -2558,9 +2567,9 @@ sub find_or_new { =over 4 -=item Arguments: \%vals +=item Arguments: \%col_data -=item Return Value: a L $object +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back @@ -2584,12 +2593,11 @@ This can be applied recursively, and will work correctly for a structure with an arbitrary depth and width, as long as the relationships actually exists and the correct column data has been supplied. - Instead of hashrefs of plain related data (key/value pairs), you may also pass new or inserted objects. New objects (not inserted yet, see -L), will be inserted into their appropriate tables. +L), will be inserted into their appropriate tables. -Effectively a shortcut for C<< ->new_result(\%vals)->insert >>. +Effectively a shortcut for C<< ->new_result(\%col_data)->insert >>. Example of creating a new row. @@ -2627,9 +2635,10 @@ C resultset. Note Hashref. When subclassing ResultSet never attempt to override this method. Since it is a simple shortcut for C<< $self->new_result($attrs)->insert >>, a lot of the internals simply never call it, so your override will be -bypassed more often than not. Override either L -or L depending on how early in the -L process you need to intervene. +bypassed more often than not. Override either L +or L depending on how early in the +L process you need to intervene. See also warning pertaining to +L. =back @@ -2646,9 +2655,9 @@ sub create { =over 4 -=item Arguments: \%vals, \%attrs? +=item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }? -=item Return Value: $rowobject +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back @@ -2707,7 +2716,7 @@ database! year => 2005, }); - if( $cd->in_storage ) { + if( !$cd->in_storage ) { # do some stuff $cd->insert; } @@ -2728,16 +2737,16 @@ sub find_or_create { =over 4 -=item Arguments: \%col_values, { key => $unique_constraint }? +=item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }? -=item Return Value: $row_object +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back $resultset->update_or_create({ col => $val, ... }); Like L, but if a row is found it is immediately updated via -C<< $found_row->update (\%col_values) >>. +C<< $found_row->update (\%col_data) >>. Takes an optional C attribute to search on a specific unique constraint. @@ -2778,20 +2787,6 @@ L and L instead. Don't forget to call L to save the newly created row to the database! - my $cd = $schema->resultset('CD')->update_or_new( - { - artist => 'Massive Attack', - title => 'Mezzanine', - year => 1998, - }, - { key => 'cd_artist_title' } - ); - - if( $cd->in_storage ) { - # do some stuff - $cd->insert; - } - =cut sub update_or_create { @@ -2812,16 +2807,16 @@ sub update_or_create { =over 4 -=item Arguments: \%col_values, { key => $unique_constraint }? +=item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }? -=item Return Value: $rowobject +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back $resultset->update_or_new({ col => $val, ... }); Like L but if a row is found it is immediately updated via -C<< $found_row->update (\%col_values) >>. +C<< $found_row->update (\%col_data) >>. For example: @@ -2877,7 +2872,7 @@ sub update_or_new { =item Arguments: none -=item Return Value: \@cache_objects | undef +=item Return Value: L<\@result_objs|DBIx::Class::Manual::ResultClass> | undef =back @@ -2896,15 +2891,15 @@ sub get_cache { =over 4 -=item Arguments: \@cache_objects +=item Arguments: L<\@result_objs|DBIx::Class::Manual::ResultClass> -=item Return Value: \@cache_objects +=item Return Value: L<\@result_objs|DBIx::Class::Manual::ResultClass> =back Sets the contents of the cache for the resultset. Expects an arrayref of objects of the same class as those produced by the resultset. Note that -if the cache is set the resultset will return the cached objects rather +if the cache is set, the resultset will return the cached objects rather than re-querying the database even if the cache attr is not set. The contents of the cache can also be populated by using the @@ -2975,9 +2970,9 @@ sub is_ordered { =over 4 -=item Arguments: $relationship_name +=item Arguments: $rel_name -=item Return Value: $resultset +=item Return Value: L<$resultset|/search> =back @@ -3089,9 +3084,7 @@ source alias of the current result set: =cut sub current_source_alias { - my ($self) = @_; - - return ($self->{attrs} || {})->{alias} || 'me'; + return (shift->{attrs} || {})->{alias} || 'me'; } =head2 as_subselect_rs @@ -3100,7 +3093,7 @@ sub current_source_alias { =item Arguments: none -=item Return Value: $resultset +=item Return Value: L<$resultset|/search> =back @@ -3273,12 +3266,6 @@ sub _chain_relationship { return {%$attrs, from => $from, seen_join => $seen}; } -# too many times we have to do $attrs = { %{$self->_resolved_attrs} } -sub _resolved_attrs_copy { - my $self = shift; - return { %{$self->_resolved_attrs (@_)} }; -} - sub _resolved_attrs { my $self = shift; return $self->{_attrs} if $self->{_attrs}; @@ -3302,7 +3289,7 @@ sub _resolved_attrs { if (my $cols = delete $attrs->{columns}) { for my $c (ref $cols eq 'ARRAY' ? @$cols : $cols) { if (ref $c eq 'HASH') { - for my $as (keys %$c) { + for my $as (sort keys %$c) { push @sel, $c->{$as}; push @as, $as; } @@ -3490,6 +3477,7 @@ sub _resolved_attrs { # default order for collapsing unless the user asked for something $attrs->{order_by} = [ map { "$alias.$_" } $source->primary_columns ]; $attrs->{_ordered_for_collapse} = 1; + $attrs->{_order_is_artificial} = 1; } # if both page and offset are specified, produce a combined offset @@ -3759,6 +3747,10 @@ searching for data. They can be passed to any method which takes an C<\%attrs> argument. See L, L, L, L. +Default attributes can be set on the result class using +L. (Please read +the CAVEATS on that feature before using it!) + These are in no particular order: =head2 order_by @@ -4013,6 +4005,12 @@ to Earth' and a cd with title 'Popular'. If you want to fetch related objects from other tables as well, see C below. + NOTE: An internal join-chain pruner will discard certain joins while + constructing the actual SQL query, as long as the joins in question do not + affect the retrieved result. This for example includes 1:1 left joins + that are not part of the restriction specification (WHERE/HAVING) nor are + a part of the query selection. + For more help on using joins with search, see L. =head2 prefetch @@ -4118,12 +4116,6 @@ relationship on a given level. e.g.: } ); -In fact, C will emit the following warning: - - Prefetching multiple has_many rels tracks and cd_to_producer at top - level will explode the number of row objects retrievable via ->next - or ->all. Use at your own risk. - The collapser currently can't identify duplicate tuples for multiple L relationships and as a result the second L @@ -4201,6 +4193,37 @@ behavior may or may not survive the 0.09 transition. =back +=head2 alias + +=over 4 + +=item Value: $source_alias + +=back + +Sets the source alias for the query. Normally, this defaults to C, but +nested search queries (sub-SELECTs) might need specific aliases set to +reference inner queries. For example: + + my $q = $rs + ->related_resultset('CDs') + ->related_resultset('Tracks') + ->search({ + 'track.id' => { -ident => 'none_search.id' }, + }) + ->as_query; + + my $ids = $self->search({ + -not_exists => $q, + }, { + alias => 'none_search', + group_by => 'none_search.id', + })->get_column('id')->as_query; + + $self->search({ id => { -in => $ids } }) + +This attribute is directly tied to L. + =head2 page =over 4 @@ -4307,7 +4330,7 @@ attribute, this setting is ignored and an appropriate warning is issued. Adds to the WHERE clause. # only return rows WHERE deleted IS NULL for all searches - __PACKAGE__->resultset_attributes({ where => { deleted => undef } }); ) + __PACKAGE__->resultset_attributes({ where => { deleted => undef } }); Can be overridden by passing C<< { where => undef } >> as an attribute to a resultset. @@ -4338,12 +4361,69 @@ L. =over 4 -=item Value: ( 'update' | 'shared' ) +=item Value: ( 'update' | 'shared' | \$scalar ) =back Set to 'update' for a SELECT ... FOR UPDATE or 'shared' for a SELECT -... FOR SHARED. +... FOR SHARED. If \$scalar is passed, this is taken directly and embedded in the +query. + +=head1 DBIC BIND VALUES + +Because DBIC may need more information to bind values than just the column name +and value itself, it uses a special format for both passing and receiving bind +values. Each bind value should be composed of an arrayref of +C<< [ \%args => $val ] >>. The format of C<< \%args >> is currently: + +=over 4 + +=item dbd_attrs + +If present (in any form), this is what is being passed directly to bind_param. +Note that different DBD's expect different bind args. (e.g. DBD::SQLite takes +a single numerical type, while DBD::Pg takes a hashref if bind options.) + +If this is specified, all other bind options described below are ignored. + +=item sqlt_datatype + +If present, this is used to infer the actual bind attribute by passing to +C<< $resolved_storage->bind_attribute_by_data_type() >>. Defaults to the +"data_type" from the L. + +Note that the data type is somewhat freeform (hence the sqlt_ prefix); +currently drivers are expected to "Do the Right Thing" when given a common +datatype name. (Not ideal, but that's what we got at this point.) + +=item sqlt_size + +Currently used to correctly allocate buffers for bind_param_inout(). +Defaults to "size" from the L, +or to a sensible value based on the "data_type". + +=item dbic_colname + +Used to fill in missing sqlt_datatype and sqlt_size attributes (if they are +explicitly specified they are never overriden). Also used by some weird DBDs, +where the column name should be available at bind_param time (e.g. Oracle). + +=back + +For backwards compatibility and convenience, the following shortcuts are +supported: + + [ $name => $val ] === [ { dbic_colname => $name }, $val ] + [ \$dt => $val ] === [ { sqlt_datatype => $dt }, $val ] + [ undef, $val ] === [ {}, $val ] + +=head1 AUTHOR AND CONTRIBUTORS + +See L and L in DBIx::Class + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. =cut diff --git a/lib/DBIx/Class/ResultSetColumn.pm b/lib/DBIx/Class/ResultSetColumn.pm index 8a92b2f..a3ab2cc 100644 --- a/lib/DBIx/Class/ResultSetColumn.pm +++ b/lib/DBIx/Class/ResultSetColumn.pm @@ -5,7 +5,6 @@ use warnings; use base 'DBIx::Class'; use DBIx::Class::Carp; -use DBIx::Class::Exception; # not importing first() as it will clash with our own method use List::Util (); @@ -118,7 +117,7 @@ sub new { =item Arguments: none -=item Return Value: \[ $sql, @bind ] +=item Return Value: \[ $sql, L<@bind_values|DBIx::Class::ResultSet/DBIC BIND VALUES> ] =back @@ -171,7 +170,7 @@ Returns all values of the column in the resultset (or C if there are none). Much like L but returns values rather -than row objects. +than result objects. =cut @@ -286,7 +285,7 @@ sub min { =item Arguments: none -=item Return Value: $resultset +=item Return Value: L<$resultset|DBIx::Class::ResultSet> =back @@ -325,7 +324,7 @@ sub max { =item Arguments: none -=item Return Value: $resultset +=item Return Value: L<$resultset|DBIx::Class::ResultSet> =back @@ -364,7 +363,7 @@ sub sum { =item Arguments: none -=item Return Value: $resultset +=item Return Value: L<$resultset|DBIx::Class::ResultSet> =back @@ -413,7 +412,7 @@ sub func { =item Arguments: $function -=item Return Value: $resultset +=item Return Value: L<$resultset|DBIx::Class::ResultSet> =back @@ -438,7 +437,7 @@ See L for details. =cut sub throw_exception { - my $self=shift; + my $self = shift; if (ref $self && $self->{_parent_resultset}) { $self->{_parent_resultset}->throw_exception(@_); @@ -472,11 +471,9 @@ sub _resultset { 1; -=head1 AUTHORS - -Luke Saunders +=head1 AUTHOR AND CONTRIBUTORS -Jess Robinson +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index f45ea2f..97c37eb 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -8,9 +8,8 @@ use base qw/DBIx::Class::ResultSource::RowParser DBIx::Class/; use DBIx::Class::ResultSet; use DBIx::Class::ResultSourceHandle; -use DBIx::Class::Exception; use DBIx::Class::Carp; -use DBIx::Class::GlobalDestruction; +use Devel::GlobalDestruction; use Try::Tiny; use List::Util 'first'; use Scalar::Util qw/blessed weaken isweak/; @@ -95,7 +94,7 @@ You can retrieve the result source at runtime in the following ways: $schema->source($source_name); -=item From a Row object: +=item From a Result object: $row->result_source; @@ -134,7 +133,7 @@ sub new { =item Arguments: @columns -=item Return value: The ResultSource object +=item Return Value: L<$result_source|/new> =back @@ -147,7 +146,7 @@ pairs, uses the hashref as the L for that column. Repeated calls of this method will add more columns, not replace them. The column names given will be created as accessor methods on your -L objects. You can change the name of the accessor +L objects. You can change the name of the accessor by supplying an L in the column_info hash. If a column name beginning with a plus sign ('+col1') is provided, the @@ -300,7 +299,7 @@ L. =item Arguments: $colname, \%columninfo? -=item Return value: 1/0 (true/false) +=item Return Value: 1/0 (true/false) =back @@ -344,7 +343,7 @@ sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB =item Arguments: $colname -=item Return value: 1/0 (true/false) +=item Return Value: 1/0 (true/false) =back @@ -365,7 +364,7 @@ sub has_column { =item Arguments: $colname -=item Return value: Hashref of info +=item Return Value: Hashref of info =back @@ -413,9 +412,9 @@ sub column_info { =over -=item Arguments: None +=item Arguments: none -=item Return value: Ordered list of column names +=item Return Value: Ordered list of column names =back @@ -439,7 +438,7 @@ sub columns { =item Arguments: \@colnames ? -=item Return value: Hashref of column name/info pairs +=item Return Value: Hashref of column name/info pairs =back @@ -513,7 +512,7 @@ sub columns_info { =item Arguments: @colnames -=item Return value: undefined +=item Return Value: not defined =back @@ -531,7 +530,7 @@ broken result source. =item Arguments: $colname -=item Return value: undefined +=item Return Value: not defined =back @@ -569,7 +568,7 @@ sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB =item Arguments: @cols -=item Return value: undefined +=item Return Value: not defined =back @@ -603,9 +602,9 @@ sub set_primary_key { =over 4 -=item Arguments: None +=item Arguments: none -=item Return value: Ordered list of primary column names +=item Return Value: Ordered list of primary column names =back @@ -642,7 +641,7 @@ will be applied to the L of each L =item Arguments: $sequence_name -=item Return value: undefined +=item Return Value: not defined =back @@ -665,7 +664,7 @@ sub sequence { =item Arguments: $name?, \@colnames -=item Return value: undefined +=item Return Value: not defined =back @@ -731,7 +730,7 @@ sub add_unique_constraint { =item Arguments: @constraints -=item Return value: undefined +=item Return Value: not defined =back @@ -783,7 +782,7 @@ sub add_unique_constraints { =item Arguments: \@colnames -=item Return value: Constraint name +=item Return Value: Constraint name =back @@ -817,9 +816,9 @@ sub name_unique_constraint { =over 4 -=item Arguments: None +=item Arguments: none -=item Return value: Hash of unique constraint data +=item Return Value: Hash of unique constraint data =back @@ -841,9 +840,9 @@ sub unique_constraints { =over 4 -=item Arguments: None +=item Arguments: none -=item Return value: Unique constraint names +=item Return Value: Unique constraint names =back @@ -867,7 +866,7 @@ sub unique_constraint_names { =item Arguments: $constraintname -=item Return value: List of constraint columns +=item Return Value: List of constraint columns =back @@ -895,7 +894,7 @@ sub unique_constraint_columns { =item Arguments: $callback_name | \&callback_code -=item Return value: $callback_name | \&callback_code +=item Return Value: $callback_name | \&callback_code =back @@ -962,13 +961,39 @@ sub _invoke_sqlt_deploy_hook { } } +=head2 result_class + +=over 4 + +=item Arguments: $classname + +=item Return Value: $classname + +=back + + use My::Schema::ResultClass::Inflator; + ... + + use My::Schema::Artist; + ... + __PACKAGE__->result_class('My::Schema::ResultClass::Inflator'); + +Set the default result class for this source. You can use this to create +and use your own result inflator. See L +for more details. + +Please note that setting this to something like +L will make every result unblessed +and make life more difficult. Inflators like those are better suited to +temporary usage via L. + =head2 resultset =over 4 -=item Arguments: None +=item Arguments: none -=item Return value: $resultset +=item Return Value: L<$resultset|DBIx::Class::ResultSet> =back @@ -985,7 +1010,7 @@ but is cached from then on unless resultset_class changes. =item Arguments: $classname -=item Return value: $classname +=item Return Value: $classname =back @@ -1009,9 +1034,9 @@ exists. =over 4 -=item Arguments: \%attrs +=item Arguments: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES> -=item Return value: \%attrs +=item Return Value: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES> =back @@ -1022,8 +1047,35 @@ exists. $source->resultset_attributes({ order_by => [ 'id' ] }); Store a collection of resultset attributes, that will be set on every -L produced from this result source. For a full -list see L. +L produced from this result source. + +B: C comes with its own set of issues and +bugs! While C isn't deprecated per se, its usage is +not recommended! + +Since relationships use attributes to link tables together, the "default" +attributes you set may cause unpredictable and undesired behavior. Furthermore, +the defaults cannot be turned off, so you are stuck with them. + +In most cases, what you should actually be using are project-specific methods: + + package My::Schema::ResultSet::Artist; + use base 'DBIx::Class::ResultSet'; + ... + + # BAD IDEA! + #__PACKAGE__->resultset_attributes({ prefetch => 'tracks' }); + + # GOOD IDEA! + sub with_tracks { shift->search({}, { prefetch => 'tracks' }) } + + # in your code + $schema->resultset('Artist')->with_tracks->... + +This gives you the flexibility of not using it when you don't need it. + +For more complex situations, another solution would be to use a virtual view +via L. =cut @@ -1047,7 +1099,7 @@ sub resultset { =over 4 -=item Arguments: None +=item Arguments: none =item Result value: $name @@ -1083,9 +1135,9 @@ its class name. =over 4 -=item Arguments: None +=item Arguments: none -=item Return value: FROM clause +=item Return Value: FROM clause =back @@ -1103,9 +1155,9 @@ sub from { die 'Virtual method!' } =over 4 -=item Arguments: $schema +=item Arguments: L<$schema?|DBIx::Class::Schema> -=item Return value: A schema object +=item Return Value: L<$schema|DBIx::Class::Schema> =back @@ -1139,17 +1191,15 @@ sub schema { =over 4 -=item Arguments: None +=item Arguments: none -=item Return value: A Storage object +=item Return Value: L<$storage|DBIx::Class::Storage> =back $source->storage->debug(1); -Returns the storage handle for the current schema. - -See also: L +Returns the L for the current schema. =cut @@ -1159,13 +1209,13 @@ sub storage { shift->schema->storage; } =over 4 -=item Arguments: $relname, $related_source_name, \%cond, [ \%attrs ] +=item Arguments: $rel_name, $related_source_name, \%cond, \%attrs? -=item Return value: 1/true if it succeeded +=item Return Value: 1/true if it succeeded =back - $source->add_relationship('relname', 'related_source', $cond, $attrs); + $source->add_relationship('rel_name', 'related_source', $cond, $attrs); L describes a series of methods which create pre-defined useful types of relationships. Look there first @@ -1285,9 +1335,9 @@ sub add_relationship { =over 4 -=item Arguments: None +=item Arguments: none -=item Return value: List of relationship names +=item Return Value: L<@rel_names|DBIx::Class::Relationship> =back @@ -1305,29 +1355,29 @@ sub relationships { =over 4 -=item Arguments: $relname +=item Arguments: L<$rel_name|DBIx::Class::Relationship> -=item Return value: Hashref of relation data, +=item Return Value: L<\%rel_data|DBIx::Class::Relationship::Base/add_relationship> =back Returns a hash of relationship information for the specified relationship -name. The keys/values are as specified for L. +name. The keys/values are as specified for L. =cut sub relationship_info { - my ($self, $rel) = @_; - return $self->_relationships->{$rel}; + #my ($self, $rel) = @_; + return shift->_relationships->{+shift}; } =head2 has_relationship =over 4 -=item Arguments: $rel +=item Arguments: L<$rel_name|DBIx::Class::Relationship> -=item Return value: 1/0 (true/false) +=item Return Value: 1/0 (true/false) =back @@ -1336,17 +1386,17 @@ Returns true if the source has a relationship of this name, false otherwise. =cut sub has_relationship { - my ($self, $rel) = @_; - return exists $self->_relationships->{$rel}; + #my ($self, $rel) = @_; + return exists shift->_relationships->{+shift}; } =head2 reverse_relationship_info =over 4 -=item Arguments: $relname +=item Arguments: L<$rel_name|DBIx::Class::Relationship> -=item Return value: Hashref of relationship data +=item Return Value: L<\%rel_data|DBIx::Class::Relationship::Base/add_relationship> =back @@ -1567,9 +1617,9 @@ sub pk_depends_on { # having already been inserted. Takes the name of the relationship and a # hashref of columns of the related object. sub _pk_depends_on { - my ($self, $relname, $rel_data) = @_; + my ($self, $rel_name, $rel_data) = @_; - my $relinfo = $self->relationship_info($relname); + my $relinfo = $self->relationship_info($rel_name); # don't assume things if the relationship direction is specified return $relinfo->{attrs}{is_foreign_key_constraint} @@ -1584,7 +1634,7 @@ sub _pk_depends_on { # assume anything that references our PK probably is dependent on us # rather than vice versa, unless the far side is (a) defined or (b) # auto-increment - my $rel_source = $self->related_source($relname); + my $rel_source = $self->related_source($rel_name); foreach my $p ($self->primary_columns) { if (exists $keyhash->{$p}) { @@ -1612,7 +1662,7 @@ our $UNRESOLVABLE_CONDITION = \ '1 = 0'; # list of non-triviail values (notmally conditions) returned as a part # of a joinfree condition hash sub _resolve_condition { - my ($self, $cond, $as, $for, $relname) = @_; + my ($self, $cond, $as, $for, $rel_name) = @_; my $obj_rel = !!blessed $for; @@ -1623,7 +1673,7 @@ sub _resolve_condition { self_alias => $obj_rel ? $as : $for, foreign_alias => $relalias, self_resultsource => $self, - foreign_relname => $relname || ($obj_rel ? $as : $for), + foreign_relname => $rel_name || ($obj_rel ? $as : $for), self_rowobj => $obj_rel ? $for : undef }); @@ -1632,7 +1682,7 @@ sub _resolve_condition { # FIXME sanity check until things stabilize, remove at some point $self->throw_exception ( - "A join-free condition returned for relationship '$relname' without a row-object to chain from" + "A join-free condition returned for relationship '$rel_name' without a row-object to chain from" ) unless $obj_rel; # FIXME another sanity check @@ -1642,7 +1692,7 @@ sub _resolve_condition { first { $_ !~ /^\Q$relalias.\E.+/ } keys %$joinfree_cond ) { $self->throw_exception ( - "The join-free condition returned for relationship '$relname' must be a hash " + "The join-free condition returned for relationship '$rel_name' must be a hash " .'reference with all keys being valid columns on the related result source' ); } @@ -1659,7 +1709,7 @@ sub _resolve_condition { } # see which parts of the joinfree cond are conditionals - my $relcol_list = { map { $_ => 1 } $self->related_source($relname)->columns }; + my $relcol_list = { map { $_ => 1 } $self->related_source($rel_name)->columns }; for my $c (keys %$joinfree_cond) { my ($colname) = $c =~ /^ (?: \Q$relalias.\E )? (.+)/x; @@ -1736,14 +1786,14 @@ sub _resolve_condition { elsif (ref $cond eq 'ARRAY') { my (@ret, $crosstable); for (@$cond) { - my ($cond, $crosstab) = $self->_resolve_condition($_, $as, $for, $relname); + my ($cond, $crosstab) = $self->_resolve_condition($_, $as, $for, $rel_name); push @ret, $cond; $crosstable ||= $crosstab; } return wantarray ? (\@ret, $crosstable) : \@ret; } else { - $self->throw_exception ("Can't handle condition $cond for relationship '$relname' yet :("); + $self->throw_exception ("Can't handle condition $cond for relationship '$rel_name' yet :("); } } @@ -1751,9 +1801,9 @@ sub _resolve_condition { =over 4 -=item Arguments: $relname +=item Arguments: $rel_name -=item Return value: $source +=item Return Value: $source =back @@ -1784,9 +1834,9 @@ sub related_source { =over 4 -=item Arguments: $relname +=item Arguments: $rel_name -=item Return value: $classname +=item Return Value: $classname =back @@ -1806,9 +1856,9 @@ sub related_class { =over 4 -=item Arguments: None +=item Arguments: none -=item Return value: $source_handle +=item Return Value: L<$source_handle|DBIx::Class::ResultSourceHandle> =back @@ -1925,7 +1975,7 @@ Creates a new ResultSource object. Not normally called directly by end users. =item Arguments: 1/0 (default: 0) -=item Return value: 1/0 +=item Return Value: 1/0 =back @@ -1936,9 +1986,9 @@ metadata from storage as necessary. This is *deprecated*, and should not be used. It will be removed before 1.0. -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S. Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/ResultSource/Table.pm b/lib/DBIx/Class/ResultSource/Table.pm index 9586d33..7c8dbe7 100644 --- a/lib/DBIx/Class/ResultSource/Table.pm +++ b/lib/DBIx/Class/ResultSource/Table.pm @@ -30,9 +30,9 @@ sub from { shift->name; } 1; -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S. Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/ResultSourceHandle.pm b/lib/DBIx/Class/ResultSourceHandle.pm index e0dbd08..733db83 100644 --- a/lib/DBIx/Class/ResultSourceHandle.pm +++ b/lib/DBIx/Class/ResultSourceHandle.pm @@ -5,9 +5,7 @@ use warnings; use base qw/DBIx::Class/; -use DBIx::Class::Exception; use Try::Tiny; - use namespace::clean; use overload diff --git a/lib/DBIx/Class/ResultSourceProxy/Table.pm b/lib/DBIx/Class/ResultSourceProxy/Table.pm index 8b63593..fe72d4d 100644 --- a/lib/DBIx/Class/ResultSourceProxy/Table.pm +++ b/lib/DBIx/Class/ResultSourceProxy/Table.pm @@ -104,6 +104,14 @@ sub table { return $class->result_source_instance->name; } +=head2 table_class + + __PACKAGE__->table_class('DBIx::Class::ResultSource::Table'); + +Gets or sets the table class used for construction and validation. + +=cut + =head2 has_column if ($obj->has_column($col)) { ... } @@ -130,9 +138,9 @@ L 1; -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S. Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 51b5325..f56ec61 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -5,7 +5,6 @@ use warnings; use base qw/DBIx::Class/; -use DBIx::Class::Exception; use Scalar::Util 'blessed'; use List::Util 'first'; use Try::Tiny; @@ -34,14 +33,31 @@ DBIx::Class::Row - Basic row methods This class is responsible for defining and doing basic operations on rows derived from L objects. -Row objects are returned from Ls using the +Result objects are returned from Ls using the L, L, L and L methods, as well as invocations of 'single' ( L, L or L) -relationship accessors of L objects. +relationship accessors of L objects. + +=head1 NOTE + +All "Row objects" derived from a Schema-attached L +object (such as a typical C<< L->L >> call) are actually Result +instances, based on your application's +L. + +L implements most of the row-based communication with the +underlying storage, but a Result class B. +Usually, Result classes inherit from L, which in turn +combines the methods from several classes, one of them being +L. Therefore, while many of the methods available to a +L-derived Result class are described in the following +documentation, it does not detail all of the methods available to Result +objects. Refer to L for more info. =head1 METHODS @@ -55,11 +71,11 @@ relationship accessors of L objects. =item Arguments: \%attrs or \%colsandvalues -=item Returns: A Row object +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back -While you can create a new row object by calling C directly on +While you can create a new result object by calling C directly on this class, you are better off calling it on a L object. @@ -243,7 +259,7 @@ sub new { next; } } - $new->throw_exception("No such column $key on $class") + $new->throw_exception("No such column '$key' on $class") unless $class->has_column($key); $new->store_column($key => $attrs->{$key}); } @@ -255,6 +271,42 @@ sub new { return $new; } +=head2 $column_accessor + + # Each pair does the same thing + + # (un-inflated, regular column) + my $val = $row->get_column('first_name'); + my $val = $row->first_name; + + $row->set_column('first_name' => $val); + $row->first_name($val); + + # (inflated column via DBIx::Class::InflateColumn::DateTime) + my $val = $row->get_inflated_column('last_modified'); + my $val = $row->last_modified; + + $row->set_inflated_column('last_modified' => $val); + $row->last_modified($val); + +=over + +=item Arguments: $value? + +=item Return Value: $value + +=back + +A column accessor method is created for each column, which is used for +getting/setting the value for that column. + +The actual method name is based on the +L name given during the +L L. Like L, this +will not store the data in the database until L or L +is called on the row. + =head2 insert $row->insert; @@ -263,7 +315,7 @@ sub new { =item Arguments: none -=item Returns: The Row object +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back @@ -271,8 +323,8 @@ Inserts an object previously created by L into the database if it isn't already in there. Returns the object itself. To insert an entirely new row into the database, use L. -To fetch an uninserted row object, call -L on a resultset. +To fetch an uninserted result object, call +L on a resultset. This will also insert any uninserted, related objects held inside this one, see L for more details. @@ -416,7 +468,7 @@ sub insert { =item Arguments: none or 1|0 -=item Returns: 1|0 +=item Return Value: 1|0 =back @@ -425,8 +477,8 @@ not. This is set to true when L, L or L are used. -Creating a row object using L, or calling -L on one, sets it to false. +Creating a result object using L, or +calling L on one, sets it to false. =cut @@ -444,11 +496,11 @@ sub in_storage { =item Arguments: none or a hashref -=item Returns: The Row object +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back -Throws an exception if the row object is not yet in the database, +Throws an exception if the result object is not yet in the database, according to L. This method issues an SQL UPDATE query to commit any changes to the @@ -473,7 +525,7 @@ contain scalar references, e.g.: $row->update({ last_modified => \'NOW()' }); The update will pass the values verbatim into SQL. (See -L docs). The values in your Row object will NOT change +L docs). The values in your Result object will NOT change as a result of the update call, if you want the object to be updated with the actual values from the database, call L after the update. @@ -522,7 +574,7 @@ sub update { =item Arguments: none -=item Returns: The Row object +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back @@ -546,7 +598,7 @@ main row first> and only then attempts to delete any remaining related rows. If you delete an object within a txn_do() (see L) -and the transaction subsequently fails, the row object will remain marked as +and the transaction subsequently fails, the result object will remain marked as not being in storage. If you know for a fact that the object is still in storage (i.e. by inspecting the cause of the transaction's failure), you can use C<< $obj->in_storage(1) >> to restore consistency between the object and @@ -588,14 +640,14 @@ sub delete { =item Arguments: $columnname -=item Returns: The value of the column +=item Return Value: The value of the column =back Throws an exception if the column name given doesn't exist according to L. -Returns a raw column value from the row object, if it has already +Returns a raw column value from the result object, if it has already been fetched from the database or set by an accessor. If an L has been set, it @@ -632,7 +684,7 @@ sub get_column { =item Arguments: $columnname -=item Returns: 0|1 +=item Return Value: 0|1 =back @@ -656,7 +708,7 @@ sub has_column_loaded { =item Arguments: none -=item Returns: A hash of columnname, value pairs. +=item Return Value: A hash of columnname, value pairs. =back @@ -686,7 +738,7 @@ sub get_columns { =item Arguments: none -=item Returns: A hash of column, value pairs +=item Return Value: A hash of column, value pairs =back @@ -711,7 +763,7 @@ sub get_dirty_columns { =item Arguments: $columnname -=item Returns: undefined +=item Return Value: not defined =back @@ -751,7 +803,7 @@ sub make_column_dirty { =item Arguments: none -=item Returns: A hash of column, object|value pairs +=item Return Value: A hash of column, object|value pairs =back @@ -814,7 +866,7 @@ sub _is_column_numeric { =item Arguments: $columnname, $value -=item Returns: $value +=item Return Value: $value =back @@ -824,7 +876,7 @@ the column is marked as dirty for when you next call L. If passed an object or reference as a value, this method will happily attempt to store it, and a later L or L will try and stringify/numify as appropriate. To set an object to be deflated -instead, see L. +instead, see L, or better yet, use L. =cut @@ -924,7 +976,7 @@ sub _track_storage_value { =item Arguments: \%columndata -=item Returns: The Row object +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back @@ -950,16 +1002,16 @@ sub set_columns { =item Arguments: \%columndata -=item Returns: The Row object +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back Sets more than one column value at once. Any inflated values are deflated and the raw values stored. -Any related values passed as Row objects, using the relation name as a +Any related values passed as Result objects, using the relation name as a key, are reduced to the appropriate foreign key values and stored. If -instead of related row objects, a hashref of column, value data is +instead of related result objects, a hashref of column, value data is passed, will create the related object first then store. Will even accept arrayrefs of data as a value to a @@ -1007,7 +1059,7 @@ sub set_inflated_columns { =item Arguments: \%replacementdata -=item Returns: The Row object copy +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> copy =back @@ -1078,7 +1130,7 @@ sub copy { =item Arguments: $columnname, $value -=item Returns: The value sent to storage +=item Return Value: The value sent to storage =back @@ -1086,7 +1138,7 @@ Set a raw value for a column without marking it as changed. This method is used internally by L which you should probably be using. -This is the lowest level at which data is set on a row object, +This is the lowest level at which data is set on a result object, extend this method to catch all data setting methods. =cut @@ -1106,14 +1158,14 @@ sub store_column { =over -=item Arguments: $result_source, \%columndata, \%prefetcheddata +=item Arguments: L<$result_source|DBIx::Class::ResultSource>, \%columndata, \%prefetcheddata -=item Returns: A Row object +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back All L methods that retrieve data from the -database and turn it into row objects call this method. +database and turn it into result objects call this method. Extend this method in your Result classes to hook into this process, for example to rebless the result into a different class. @@ -1185,7 +1237,7 @@ sub inflate_result { =item Arguments: none -=item Returns: Result of update or insert operation +=item Return Value: Result of update or insert operation =back @@ -1216,7 +1268,7 @@ sub update_or_insert { =item Arguments: none -=item Returns: 0|1 or @columnnames +=item Return Value: 0|1 or @columnnames =back @@ -1238,7 +1290,7 @@ sub is_changed { =item Arguments: $columname -=item Returns: 0|1 +=item Return Value: 0|1 =back @@ -1257,9 +1309,9 @@ sub is_column_changed { =over -=item Arguments: $result_source_instance +=item Arguments: L<$result_source?|DBIx::Class::ResultSource> -=item Returns: a ResultSource instance +=item Return Value: L<$result_source|DBIx::Class::ResultSource> =back @@ -1295,7 +1347,7 @@ sub result_source { =item Arguments: $columnname, \%columninfo -=item Returns: undefined +=item Return Value: not defined =back @@ -1326,11 +1378,11 @@ sub register_column { =item Arguments: \%attrs -=item Returns: A Row object +=item Return Value: A Result object =back -Fetches a fresh copy of the Row object from the database and returns it. +Fetches a fresh copy of the Result object from the database and returns it. Throws an exception if a proper WHERE clause identifying the database row can not be constructed (i.e. if the original object does not contain its entire @@ -1338,11 +1390,11 @@ entire ). If passed the \%attrs argument, will first apply these attributes to the resultset used to find the row. -This copy can then be used to compare to an existing row object, to +This copy can then be used to compare to an existing result object, to determine if any changes have been made in the database since it was created. -To just update your Row object with any latest changes from the +To just update your Result object with any latest changes from the database, use L instead. The \%attrs argument should be compatible with @@ -1362,7 +1414,7 @@ sub get_from_storage { return $resultset->find($self->_storage_ident_condition); } -=head2 discard_changes ($attrs?) +=head2 discard_changes $row->discard_changes @@ -1370,7 +1422,7 @@ sub get_from_storage { =item Arguments: none or $attrs -=item Returns: self (updates object in-place) +=item Return Value: self (updates object in-place) =back @@ -1451,9 +1503,9 @@ sub throw_exception { Returns the primary key(s) for a row. Can't be called as a class method. Actually implemented in L -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S. Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/SQLAHacks.pm b/lib/DBIx/Class/SQLAHacks.pm index ee3f156..98bb571 100644 --- a/lib/DBIx/Class/SQLAHacks.pm +++ b/lib/DBIx/Class/SQLAHacks.pm @@ -1,6 +1,9 @@ package # Hide from PAUSE DBIx::Class::SQLAHacks; +use warnings; +use strict; + use base qw/DBIx::Class::SQLMaker/; 1; diff --git a/lib/DBIx/Class/SQLAHacks/MSSQL.pm b/lib/DBIx/Class/SQLAHacks/MSSQL.pm index 6472ac3..8551a9c 100644 --- a/lib/DBIx/Class/SQLAHacks/MSSQL.pm +++ b/lib/DBIx/Class/SQLAHacks/MSSQL.pm @@ -1,6 +1,9 @@ package # Hide from PAUSE DBIx::Class::SQLAHacks::MSSQL; +use warnings; +use strict; + use base qw( DBIx::Class::SQLMaker::MSSQL ); 1; diff --git a/lib/DBIx/Class/SQLAHacks/MySQL.pm b/lib/DBIx/Class/SQLAHacks/MySQL.pm index 7b6f09a..d58e420 100644 --- a/lib/DBIx/Class/SQLAHacks/MySQL.pm +++ b/lib/DBIx/Class/SQLAHacks/MySQL.pm @@ -1,6 +1,9 @@ package # Hide from PAUSE DBIx::Class::SQLAHacks::MySQL; +use warnings; +use strict; + use base qw( DBIx::Class::SQLMaker::MySQL ); 1; diff --git a/lib/DBIx/Class/SQLAHacks/Oracle.pm b/lib/DBIx/Class/SQLAHacks/Oracle.pm index d5447c3..a55936d 100644 --- a/lib/DBIx/Class/SQLAHacks/Oracle.pm +++ b/lib/DBIx/Class/SQLAHacks/Oracle.pm @@ -1,6 +1,9 @@ package # Hide from PAUSE DBIx::Class::SQLAHacks::Oracle; +use warnings; +use strict; + use base qw( DBIx::Class::SQLMaker::Oracle ); 1; diff --git a/lib/DBIx/Class/SQLAHacks/OracleJoins.pm b/lib/DBIx/Class/SQLAHacks/OracleJoins.pm index 120df49..8e88fc1 100644 --- a/lib/DBIx/Class/SQLAHacks/OracleJoins.pm +++ b/lib/DBIx/Class/SQLAHacks/OracleJoins.pm @@ -1,6 +1,9 @@ package # Hide from PAUSE DBIx::Class::SQLAHacks::OracleJoins; +use warnings; +use strict; + use base qw( DBIx::Class::SQLMaker::OracleJoins ); 1; diff --git a/lib/DBIx/Class/SQLAHacks/SQLite.pm b/lib/DBIx/Class/SQLAHacks/SQLite.pm index 937cbf6..c9e4ad7 100644 --- a/lib/DBIx/Class/SQLAHacks/SQLite.pm +++ b/lib/DBIx/Class/SQLAHacks/SQLite.pm @@ -1,6 +1,9 @@ package # Hide from PAUSE DBIx::Class::SQLAHacks::SQLite; +use warnings; +use strict; + use base qw( DBIx::Class::SQLMaker::SQLite ); 1; diff --git a/lib/DBIx/Class/SQLMaker.pm b/lib/DBIx/Class/SQLMaker.pm index 705c569..1162280 100644 --- a/lib/DBIx/Class/SQLMaker.pm +++ b/lib/DBIx/Class/SQLMaker.pm @@ -27,10 +27,6 @@ Currently the enhancements to L are: =item * Support of C<...FOR UPDATE> type of select statement modifiers -=item * The L operator - -=item * The L operator - =back =cut @@ -44,7 +40,6 @@ use mro 'c3'; use Sub::Name 'subname'; use DBIx::Class::Carp; -use DBIx::Class::Exception; use namespace::clean; __PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/); @@ -75,9 +70,6 @@ BEGIN { my($func) = (caller(1))[3]; __PACKAGE__->throw_exception("[$func] Fatal: " . join ('', @_)); }; - - # Current SQLA pollutes its namespace - clean for the time being - namespace::clean->clean_subroutines(qw/SQL::Abstract carp croak confess/); } # the "oh noes offset/top without limit" constant @@ -101,63 +93,6 @@ sub _quote { ); } -sub new { - my $self = shift->next::method(@_); - - # use the same coderefs, they are prepared to handle both cases - my @extra_dbic_syntax = ( - { regex => qr/^ ident $/xi, handler => '_where_op_IDENT' }, - { regex => qr/^ value $/xi, handler => '_where_op_VALUE' }, - ); - - push @{$self->{special_ops}}, @extra_dbic_syntax; - push @{$self->{unary_ops}}, @extra_dbic_syntax; - - $self; -} - -sub _where_op_IDENT { - my $self = shift; - my ($op, $rhs) = splice @_, -2; - if (ref $rhs) { - $self->throw_exception("-$op takes a single scalar argument (a quotable identifier)"); - } - - # in case we are called as a top level special op (no '=') - my $lhs = shift; - - $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs); - - return $lhs - ? "$lhs = $rhs" - : $rhs - ; -} - -sub _where_op_VALUE { - my $self = shift; - my ($op, $rhs) = splice @_, -2; - - # in case we are called as a top level special op (no '=') - my $lhs = shift; - - my @bind = [ - ($lhs || $self->{_nested_func_lhs} || $self->throw_exception("Unable to find bindtype for -value $rhs") ), - $rhs - ]; - - return $lhs - ? ( - $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'), - @bind - ) - : ( - $self->_convert('?'), - @bind, - ) - ; -} - sub _where_op_NEST { carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n" .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }| @@ -194,16 +129,25 @@ sub select { ($sql, @bind) = $self->next::method ($table, $fields, $where); - my $limiter = - $self->can ('emulate_limit') # also backcompat hook from SQLA::Limit - || - do { - my $dialect = $self->limit_dialect - or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found" ); - $self->can ("_$dialect") - or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'"); - } - ; + my $limiter; + + if( $limiter = $self->can ('emulate_limit') ) { + carp_unique( + 'Support for the legacy emulate_limit() mechanism inherited from ' + . 'SQL::Abstract::Limit has been deprecated, and will be removed when ' + . 'DBIC transitions to Data::Query. If your code uses this type of ' + . 'limit specification please file an RT and provide the source of ' + . 'your emulate_limit() implementation, so an acceptable upgrade-path ' + . 'can be devised' + ); + } + else { + my $dialect = $self->limit_dialect + or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self" ); + + $limiter = $self->can ("_$dialect") + or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'"); + } $sql = $self->$limiter ( $sql, @@ -238,7 +182,15 @@ my $for_syntax = { }; sub _lock_select { my ($self, $type) = @_; - my $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" ); + + my $sql; + if (ref($type) eq 'SCALAR') { + $sql = "FOR $$type"; + } + else { + $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" ); + } + return " $sql"; } @@ -502,42 +454,56 @@ sub _join_condition { return $self->_recurse_where($cond); } -1; - -=head1 OPERATORS - -=head2 -ident - -Used to explicitly specify an SQL identifier. Takes a plain string as value -which is then invariably treated as a column name (and is being properly -quoted if quoting has been requested). Most useful for comparison of two -columns: - - my %where = ( - priority => { '<', 2 }, - requestor => { -ident => 'submitter' } - ); - -which results in: - - $stmt = 'WHERE "priority" < ? AND "requestor" = "submitter"'; - @bind = ('2'); - -=head2 -value +# This is hideously ugly, but SQLA does not understand multicol IN expressions +# FIXME TEMPORARY - DQ should have native syntax for this +# moved here to raise API questions +# +# !!! EXPERIMENTAL API !!! WILL CHANGE !!! +sub _where_op_multicolumn_in { + my ($self, $lhs, $rhs) = @_; + + if (! ref $lhs or ref $lhs eq 'ARRAY') { + my (@sql, @bind); + for (ref $lhs ? @$lhs : $lhs) { + if (! ref $_) { + push @sql, $self->_quote($_); + } + elsif (ref $_ eq 'SCALAR') { + push @sql, $$_; + } + elsif (ref $_ eq 'REF' and ref $$_ eq 'ARRAY') { + my ($s, @b) = @$$_; + push @sql, $s; + push @bind, @b; + } + else { + $self->throw_exception("ARRAY of @{[ ref $_ ]}es unsupported for multicolumn IN lhs..."); + } + } + $lhs = \[ join(', ', @sql), @bind]; + } + elsif (ref $lhs eq 'SCALAR') { + $lhs = \[ $$lhs ]; + } + elsif (ref $lhs eq 'REF' and ref $$lhs eq 'ARRAY' ) { + # noop + } + else { + $self->throw_exception( ref($lhs) . "es unsupported for multicolumn IN lhs..."); + } -The -value operator signals that the argument to the right is a raw bind value. -It will be passed straight to DBI, without invoking any of the SQL::Abstract -condition-parsing logic. This allows you to, for example, pass an array as a -column value for databases that support array datatypes, e.g.: + # is this proper...? + $rhs = \[ $self->_recurse_where($rhs) ]; - my %where = ( - array => { -value => [1, 2, 3] } - ); + for ($lhs, $rhs) { + $$_->[0] = "( $$_->[0] )" + unless $$_->[0] =~ /^ \s* \( .* \) \s* ^/xs; + } -which results in: + \[ join( ' IN ', shift @$$lhs, shift @$$rhs ), @$$lhs, @$$rhs ]; +} - $stmt = 'WHERE array = ?'; - @bind = ([1, 2, 3]); +1; =head1 AUTHORS diff --git a/lib/DBIx/Class/SQLMaker/LimitDialects.pm b/lib/DBIx/Class/SQLMaker/LimitDialects.pm index a0ea4ef..7639988 100644 --- a/lib/DBIx/Class/SQLMaker/LimitDialects.pm +++ b/lib/DBIx/Class/SQLMaker/LimitDialects.pm @@ -383,18 +383,6 @@ sub _prep_for_skimming_limit { # Whatever order bindvals there are, they will be realiased and # reselected, and need to show up at end of the initial inner select push @{$self->{select_bind}}, @{$self->{order_bind}}; - - # if this is a part of something bigger, we need to add back all - # the extra order_by's, as they may be relied upon by the outside - # of a prefetch or something - if ($rs_attrs->{_is_internal_subuery}) { - $sq_attrs->{selection_outer} .= sprintf ", $extra_order_sel->{$_} AS $_" - for sort - { $extra_order_sel->{$a} cmp $extra_order_sel->{$b} } - grep { $_ !~ /[^\w\-]/ } # ignore functions - keys %$extra_order_sel - ; - } } # and this is order re-alias magic @@ -773,7 +761,7 @@ sub _subqueried_limit_attrs { next if $in_sel_index->{$chunk}; $extra_order_sel->{$chunk} ||= $self->_quote ( - 'ORDER__BY__' . scalar keys %{$extra_order_sel||{}} + 'ORDER__BY__' . sprintf '%03d', scalar keys %{$extra_order_sel||{}} ); } diff --git a/lib/DBIx/Class/SQLMaker/MSSQL.pm b/lib/DBIx/Class/SQLMaker/MSSQL.pm index f64d972..39e2c4f 100644 --- a/lib/DBIx/Class/SQLMaker/MSSQL.pm +++ b/lib/DBIx/Class/SQLMaker/MSSQL.pm @@ -1,6 +1,9 @@ package # Hide from PAUSE DBIx::Class::SQLMaker::MSSQL; +use warnings; +use strict; + use base qw( DBIx::Class::SQLMaker ); # diff --git a/lib/DBIx/Class/SQLMaker/MySQL.pm b/lib/DBIx/Class/SQLMaker/MySQL.pm index c96b11c..34ee054 100644 --- a/lib/DBIx/Class/SQLMaker/MySQL.pm +++ b/lib/DBIx/Class/SQLMaker/MySQL.pm @@ -1,6 +1,9 @@ package # Hide from PAUSE DBIx::Class::SQLMaker::MySQL; +use warnings; +use strict; + use base qw( DBIx::Class::SQLMaker ); # @@ -29,6 +32,71 @@ sub _generate_join_clause { return $self->next::method($join_type); } +my $force_double_subq; +$force_double_subq = sub { + my ($self, $sql) = @_; + + require Text::Balanced; + my $new_sql; + while (1) { + + my ($prefix, $parenthesized); + + ($parenthesized, $sql, $prefix) = do { + # idiotic design - writes to $@ but *DOES NOT* throw exceptions + local $@; + Text::Balanced::extract_bracketed( $sql, '()', qr/[^\(]*/ ); + }; + + # this is how an error is indicated, in addition to crapping in $@ + last unless $parenthesized; + + if ($parenthesized =~ $self->{_modification_target_referenced_re}) { + # is this a select subquery? + if ( $parenthesized =~ /^ \( \s* SELECT \s+ /xi ) { + $parenthesized = "( SELECT * FROM $parenthesized `_forced_double_subquery` )"; + } + # then drill down until we find it (if at all) + else { + $parenthesized =~ s/^ \( (.+) \) $/$1/x; + $parenthesized = join ' ', '(', $self->$force_double_subq( $parenthesized ), ')'; + } + } + + $new_sql .= $prefix . $parenthesized; + } + + return $new_sql . $sql; +}; + +sub update { + my $self = shift; + + # short-circuit unless understood identifier + return $self->next::method(@_) unless $self->{_modification_target_referenced_re}; + + my ($sql, @bind) = $self->next::method(@_); + + $sql = $self->$force_double_subq($sql) + if $sql =~ $self->{_modification_target_referenced_re}; + + return ($sql, @bind); +} + +sub delete { + my $self = shift; + + # short-circuit unless understood identifier + return $self->next::method(@_) unless $self->{_modification_target_referenced_re}; + + my ($sql, @bind) = $self->next::method(@_); + + $sql = $self->$force_double_subq($sql) + if $sql =~ $self->{_modification_target_referenced_re}; + + return ($sql, @bind); +} + # LOCK IN SHARE MODE my $for_syntax = { update => 'FOR UPDATE', diff --git a/lib/DBIx/Class/SQLMaker/SQLite.pm b/lib/DBIx/Class/SQLMaker/SQLite.pm index acf0337..91f78e4 100644 --- a/lib/DBIx/Class/SQLMaker/SQLite.pm +++ b/lib/DBIx/Class/SQLMaker/SQLite.pm @@ -1,6 +1,9 @@ package # Hide from PAUSE DBIx::Class::SQLMaker::SQLite; +use warnings; +use strict; + use base qw( DBIx::Class::SQLMaker ); # diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index dbe4cbe..3bf644a 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -3,13 +3,12 @@ package DBIx::Class::Schema; use strict; use warnings; -use DBIx::Class::Exception; use DBIx::Class::Carp; use Try::Tiny; use Scalar::Util qw/weaken blessed/; use Sub::Name 'subname'; use B 'svref_2object'; -use DBIx::Class::GlobalDestruction; +use Devel::GlobalDestruction; use namespace::clean; use base qw/DBIx::Class/; @@ -168,12 +167,9 @@ sub _findallmod { my $ns = shift || ref $proto || $proto; require Module::Find; - 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; + # untaint result + return map { $_ =~ /(.+)/ } Module::Find::findallmod($ns); } # returns a hash of $shortname => $fullname for every package @@ -409,7 +405,7 @@ sub load_classes { =item Arguments: $storage_type|{$storage_type, \%args} -=item Return value: $storage_type|{$storage_type, \%args} +=item Return Value: $storage_type|{$storage_type, \%args} =item Default value: DBIx::Class::Storage::DBI @@ -435,7 +431,7 @@ L for an example of this. =item Arguments: $code_reference -=item Return value: $code_reference +=item Return Value: $code_reference =item Default value: None @@ -533,9 +529,9 @@ sub connect { shift->clone->connection(@_) } =over 4 -=item Arguments: $source_name +=item Arguments: L<$source_name|DBIx::Class::ResultSource/source_name> -=item Return Value: $resultset +=item Return Value: L<$resultset|DBIx::Class::ResultSet> =back @@ -547,17 +543,17 @@ name. =cut sub resultset { - my ($self, $moniker) = @_; + my ($self, $source_name) = @_; $self->throw_exception('resultset() expects a source name') - unless defined $moniker; - return $self->source($moniker)->resultset; + unless defined $source_name; + return $self->source($source_name)->resultset; } =head2 sources =over 4 -=item Return Value: @source_names +=item Return Value: L<@source_names|DBIx::Class::ResultSource/source_name> =back @@ -573,9 +569,9 @@ sub sources { return keys %{shift->source_registrations}; } =over 4 -=item Arguments: $source_name +=item Arguments: L<$source_name|DBIx::Class::ResultSource/source_name> -=item Return Value: $result_source +=item Return Value: L<$result_source|DBIx::Class::ResultSource> =back @@ -592,14 +588,14 @@ sub source { $self->throw_exception("source() expects a source name") unless @_; - my $moniker = shift; + my $source_name = shift; my $sreg = $self->source_registrations; - return $sreg->{$moniker} if exists $sreg->{$moniker}; + return $sreg->{$source_name} if exists $sreg->{$source_name}; # if we got here, they probably passed a full class name - my $mapped = $self->class_mappings->{$moniker}; - $self->throw_exception("Can't find source for ${moniker}") + my $mapped = $self->class_mappings->{$source_name}; + $self->throw_exception("Can't find source for ${source_name}") unless $mapped && exists $sreg->{$mapped}; return $sreg->{$mapped}; } @@ -608,7 +604,7 @@ sub source { =over 4 -=item Arguments: $source_name +=item Arguments: L<$source_name|DBIx::Class::ResultSource/source_name> =item Return Value: $classname @@ -621,8 +617,7 @@ Retrieves the Result class name for the given source name. =cut sub class { - my ($self, $moniker) = @_; - return $self->source($moniker)->result_class; + return shift->source(shift)->result_class; } =head2 txn_do @@ -741,59 +736,42 @@ found in L. =over 4 -=item Arguments: $source_name, \@data; +=item Arguments: L<$source_name|DBIx::Class::ResultSource/source_name>, [ \@column_list, \@row_values+ ] | [ \%col_data+ ] -=item Return value: \@$objects | nothing +=item Return Value: L<\@result_objects|DBIx::Class::Manual::ResultClass> (scalar context) | L<@result_objects|DBIx::Class::Manual::ResultClass> (list context) =back -Pass this method a resultsource name, and an arrayref of -arrayrefs. The arrayrefs should contain a list of column names, -followed by one or many sets of matching data for the given columns. - -In void context, C in L is used -to insert the data, as this is a fast method. However, insert_bulk currently -assumes that your datasets all contain the same type of values, using scalar -references in a column in one row, and not in another will probably not work. +A convenience shortcut to L. Equivalent to: -Otherwise, each set of data is inserted into the database using -L, and a arrayref of the resulting row -objects is returned. + $schema->resultset($source_name)->populate([...]); -e.g. +=over 4 - $schema->populate('Artist', [ - [ qw/artistid name/ ], - [ 1, 'Popular Band' ], - [ 2, 'Indie Band' ], - ... - ]); +=item NOTE -Since wantarray context is basically the same as looping over $rs->create(...) -you won't see any performance benefits and in this case the method is more for -convenience. Void context sends the column information directly to storage -using s bulk insert method. So the performance will be much better for -storages that support this method. +The context of this method call has an important effect on what is +submitted to storage. In void context data is fed directly to fastpath +insertion routines provided by the underlying storage (most often +L), bypassing the L and +L calls on the +L class, including any +augmentation of these methods provided by components. For example if you +are using something like L to create primary +keys for you, you will find that your PKs are empty. In this case you +will have to explicitly force scalar or list context in order to create +those values. -Because of this difference in the way void context inserts rows into your -database you need to note how this will effect any loaded components that -override or augment insert. For example if you are using a component such -as L to populate your primary keys you MUST use -wantarray context if you want the PKs automatically created. +=back =cut sub populate { my ($self, $name, $data) = @_; - if(my $rs = $self->resultset($name)) { - if(defined wantarray) { - return $rs->populate($data); - } else { - $rs->populate($data); - } - } else { - $self->throw_exception("$name is not a resultset"); - } + my $rs = $self->resultset($name) + or $self->throw_exception("'$name' is not a resultset"); + + return $rs->populate($data); } =head2 connection @@ -888,16 +866,16 @@ will produce the output # my ($self, $target, $base) = @_; # my $schema = $self->clone; -# foreach my $moniker ($schema->sources) { -# my $source = $schema->source($moniker); -# my $target_class = "${target}::${moniker}"; +# foreach my $source_name ($schema->sources) { +# my $source = $schema->source($source_name); +# my $target_class = "${target}::${source_name}"; # $self->inject_base( # $target_class => $source->result_class, ($base ? $base : ()) # ); # $source->result_class($target_class); # $target_class->result_source_instance($source) # if $target_class->can('result_source_instance'); -# $schema->register_source($moniker, $source); +# $schema->register_source($source_name, $source); # } # return $schema; # } @@ -919,14 +897,14 @@ sub compose_namespace { use warnings qw/redefine/; no strict qw/refs/; - foreach my $moniker ($self->sources) { - my $orig_source = $self->source($moniker); + foreach my $source_name ($self->sources) { + my $orig_source = $self->source($source_name); - my $target_class = "${target}::${moniker}"; + my $target_class = "${target}::${source_name}"; $self->inject_base($target_class, $orig_source->result_class, ($base || ()) ); # register_source examines result_class, and then returns us a clone - my $new_source = $schema->register_source($moniker, bless + my $new_source = $schema->register_source($source_name, bless { %$orig_source, result_class => $target_class }, ref $orig_source, ); @@ -1050,12 +1028,12 @@ sub _copy_state_from { $self->class_mappings({ %{$from->class_mappings} }); $self->source_registrations({ %{$from->source_registrations} }); - foreach my $moniker ($from->sources) { - my $source = $from->source($moniker); + foreach my $source_name ($from->sources) { + my $source = $from->source($source_name); my $new = $source->new($source); # we use extra here as we want to leave the class_mappings as they are # but overwrite the source_registrations entry with the new source - $self->register_extra_source($moniker => $new); + $self->register_extra_source($source_name => $new); } if ($from->storage) { @@ -1079,7 +1057,6 @@ default behavior will provide a detailed stack trace. =cut -my $false_exception_action_warned; sub throw_exception { my $self = shift; @@ -1092,13 +1069,12 @@ sub throw_exception { ." (original error: $_[0])" ); } - elsif(! $false_exception_action_warned++) { - carp ( - "The exception_action handler installed on $self returned false instead" - .' of throwing an exception. This behavior has been deprecated, adjust your' - .' handler to always rethrow the supplied error.' - ); - } + + carp_unique ( + "The exception_action handler installed on $self returned false instead" + .' of throwing an exception. This behavior has been deprecated, adjust your' + .' handler to always rethrow the supplied error.' + ); } DBIx::Class::Exception->throw($_[0], $self->stacktrace); @@ -1140,7 +1116,7 @@ sub deploy { =item Arguments: See L -=item Return value: $listofstatements +=item Return Value: $listofstatements =back @@ -1189,7 +1165,7 @@ sub create_ddl_dir { =item Arguments: $database-type, $version, $directory, $preversion -=item Return value: $normalised_filename +=item Return Value: $normalised_filename =back @@ -1308,7 +1284,7 @@ sub schema_version { =over 4 -=item Arguments: $moniker, $component_class +=item Arguments: $source_name, $component_class =back @@ -1321,27 +1297,27 @@ file). You may also need it to register classes at runtime. Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to calling: - $schema->register_source($moniker, $component_class->result_source_instance); + $schema->register_source($source_name, $component_class->result_source_instance); =cut sub register_class { - my ($self, $moniker, $to_register) = @_; - $self->register_source($moniker => $to_register->result_source_instance); + my ($self, $source_name, $to_register) = @_; + $self->register_source($source_name => $to_register->result_source_instance); } =head2 register_source =over 4 -=item Arguments: $moniker, $result_source +=item Arguments: $source_name, L<$result_source|DBIx::Class::ResultSource> =back This method is called by L. Registers the L in the schema with the given -moniker. +source name. =cut @@ -1351,11 +1327,11 @@ sub register_source { shift->_register_source(@_) } =over 4 -=item Arguments: $moniker +=item Arguments: $source_name =back -Removes the L from the schema for the given moniker. +Removes the L from the schema for the given source name. =cut @@ -1365,7 +1341,7 @@ sub unregister_source { shift->_unregister_source(@_) } =over 4 -=item Arguments: $moniker, $result_source +=item Arguments: $source_name, L<$result_source|DBIx::Class::ResultSource> =back @@ -1377,15 +1353,15 @@ has a source and you want to register an extra one. sub register_extra_source { shift->_register_source(@_, { extra => 1 }) } sub _register_source { - my ($self, $moniker, $source, $params) = @_; + my ($self, $source_name, $source, $params) = @_; - $source = $source->new({ %$source, source_name => $moniker }); + $source = $source->new({ %$source, source_name => $source_name }); $source->schema($self); weaken $source->{schema} if ref($self); my %reg = %{$self->source_registrations}; - $reg{$moniker} = $source; + $reg{$source_name} = $source; $self->source_registrations(\%reg); return $source if $params->{extra}; @@ -1396,7 +1372,7 @@ sub _register_source { if ( exists $map{$rs_class} and - $map{$rs_class} ne $moniker + $map{$rs_class} ne $source_name and $rsrc ne $_[2] # orig_source ) { @@ -1407,7 +1383,7 @@ sub _register_source { ; } - $map{$rs_class} = $moniker; + $map{$rs_class} = $source_name; $self->class_mappings(\%map); } @@ -1421,7 +1397,7 @@ sub DESTROY { my $self = shift; my $srcs = $self->source_registrations; - for my $moniker (keys %$srcs) { + for my $source_name (keys %$srcs) { # find first source that is not about to be GCed (someone other than $self # holds a reference to it) and reattach to it, weakening our own link # @@ -1429,11 +1405,11 @@ sub DESTROY { # which will serve as a signal to not try doing anything else # however beware - on older perls the exception seems randomly untrappable # due to some weird race condition during thread joining :((( - if (ref $srcs->{$moniker} and svref_2object($srcs->{$moniker})->REFCNT > 1) { + if (ref $srcs->{$source_name} and svref_2object($srcs->{$source_name})->REFCNT > 1) { local $@; eval { - $srcs->{$moniker}->schema($self); - weaken $srcs->{$moniker}; + $srcs->{$source_name}->schema($self); + weaken $srcs->{$source_name}; 1; } or do { $global_phase_destroy = 1; @@ -1445,10 +1421,10 @@ sub DESTROY { } sub _unregister_source { - my ($self, $moniker) = @_; + my ($self, $source_name) = @_; my %reg = %{$self->source_registrations}; - my $source = delete $reg{$moniker}; + my $source = delete $reg{$source_name}; $self->source_registrations(\%reg); if ($source->result_class) { my %map = %{$self->class_mappings}; @@ -1509,8 +1485,8 @@ sub compose_connection { if ($self eq $target) { # Pathological case, largely caused by the docs on early C::M::DBIC::Plain - foreach my $moniker ($self->sources) { - my $source = $self->source($moniker); + foreach my $source_name ($self->sources) { + my $source = $self->source($source_name); my $class = $source->result_class; $self->inject_base($class, $base); $class->mk_classdata(resultset_instance => $source->resultset); @@ -1528,10 +1504,10 @@ sub compose_connection { } $schema->connection(@info); - foreach my $moniker ($schema->sources) { - my $source = $schema->source($moniker); + foreach my $source_name ($schema->sources) { + my $source = $schema->source($source_name); my $class = $source->result_class; - #warn "$moniker $class $source ".$source->storage; + #warn "$source_name $class $source ".$source->storage; $class->mk_classdata(result_source_instance => $source); $class->mk_classdata(resultset_instance => $source->resultset); $class->mk_classdata(class_resolver => $schema); @@ -1541,9 +1517,9 @@ sub compose_connection { 1; -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S. Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/Schema/Versioned.pm b/lib/DBIx/Class/Schema/Versioned.pm index a04b23e..0e83dc6 100644 --- a/lib/DBIx/Class/Schema/Versioned.pm +++ b/lib/DBIx/Class/Schema/Versioned.pm @@ -298,7 +298,7 @@ sub create_upgrade_path { =over 4 -=item Returns: a list of version numbers, ordered from lowest to highest +=item Return Value: a list of version numbers, ordered from lowest to highest =back @@ -757,10 +757,9 @@ sub _source_exists 1; -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Jess Robinson -Luke Saunders +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/Serialize/Storable.pm b/lib/DBIx/Class/Serialize/Storable.pm index 23f61cb..3d6d539 100644 --- a/lib/DBIx/Class/Serialize/Storable.pm +++ b/lib/DBIx/Class/Serialize/Storable.pm @@ -52,8 +52,8 @@ in its current implementation. Do not use! =head1 DESCRIPTION -This component adds hooks for Storable so that row objects can be -serialized. It assumes that your row object class (C) is +This component adds hooks for Storable so that result objects can be +serialized. It assumes that your result object class (C) is the same as your table class, which is the normal situation. =head1 HOOKS @@ -72,9 +72,9 @@ method. The deserializing hook called on the object during deserialization. -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -David Kamholz +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/StartupCheck.pm b/lib/DBIx/Class/StartupCheck.pm index 86230d6..10b554a 100644 --- a/lib/DBIx/Class/StartupCheck.pm +++ b/lib/DBIx/Class/StartupCheck.pm @@ -1,5 +1,8 @@ package DBIx::Class::StartupCheck; +use strict; +use warnings; + =head1 NAME DBIx::Class::StartupCheck - Run environment checks on startup diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm index a3ae532..6b88d28 100644 --- a/lib/DBIx/Class/Storage.pm +++ b/lib/DBIx/Class/Storage.pm @@ -180,7 +180,10 @@ sub txn_do { DBIx::Class::Storage::BlockRunner->new( storage => $self, run_code => $coderef, - run_args => \@_, # take a ref instead of a copy, to preserve coderef @_ aliasing semantics + run_args => @_ + ? \@_ # take a ref instead of a copy, to preserve @_ aliasing + : [] # semantics within the coderef, but only if needed + , # (pseudoforking doesn't like this trick much) wrap_txn => 1, retry_handler => sub { ! ( $_[0]->retried_count or $_[0]->storage->connected ) }, )->run; @@ -623,11 +626,9 @@ Old name for DBIC_TRACE L - reference storage implementation using SQL::Abstract and DBI. -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S. Trout - -Andy Grundman +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/Storage/BlockRunner.pm b/lib/DBIx/Class/Storage/BlockRunner.pm index fe2d221..404e480 100644 --- a/lib/DBIx/Class/Storage/BlockRunner.pm +++ b/lib/DBIx/Class/Storage/BlockRunner.pm @@ -76,7 +76,7 @@ has retried_count => ( default => quote_sub(q{ 0 }), lazy => 1, trigger => quote_sub(q{ - DBIx::Class::Exception->throw(sprintf ( + $_[0]->throw_exception( sprintf ( 'Exceeded max_retried_count amount of %d, latest exception: %s', $_[0]->max_retried_count, $_[0]->last_exception )) if $_[0]->max_retried_count < ($_[1]||0); @@ -93,10 +93,12 @@ has exception_stack => ( sub last_exception { shift->exception_stack->[-1] } +sub throw_exception { shift->storage->throw_exception (@_) } + sub run { my $self = shift; - DBIx::Class::Exception->throw('run() takes no arguments') if @_; + $self->throw_exception('run() takes no arguments') if @_; $self->_reset_exception_stack; $self->_reset_retried_count; @@ -219,9 +221,9 @@ sub _run { }; } -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -see L +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 993748d..fb99190 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -8,7 +8,6 @@ use base qw/DBIx::Class::Storage::DBIHacks DBIx::Class::Storage/; use mro 'c3'; use DBIx::Class::Carp; -use DBIx::Class::Exception; use Scalar::Util qw/refaddr weaken reftype blessed/; use List::Util qw/first/; use Sub::Name 'subname'; @@ -87,7 +86,6 @@ sub _determine_supports_join_optimizer { 1 }; # class, as _use_X may be hardcoded class-wide, and _supports_X calls # _determine_supports_X which obv. needs a correct driver as well my @rdbms_specific_methods = qw/ - deployment_statements sqlt_type sql_maker build_datetime_parser @@ -198,16 +196,15 @@ sub new { my %seek_and_destroy; sub _arm_global_destructor { - my $self = shift; - my $key = refaddr ($self); - $seek_and_destroy{$key} = $self; - weaken ($seek_and_destroy{$key}); + weaken ( + $seek_and_destroy{ refaddr($_[0]) } = $_[0] + ); } END { local $?; # just in case the DBI destructor changes it somehow - # destroy just the object if not native to this process/thread + # destroy just the object if not native to this process $_->_verify_pid for (grep { defined $_ } values %seek_and_destroy @@ -218,14 +215,18 @@ sub new { # As per DBI's recommendation, DBIC disconnects all handles as # soon as possible (DBIC will reconnect only on demand from within # the thread) - for (values %seek_and_destroy) { - next unless $_; + my @instances = grep { defined $_ } values %seek_and_destroy; + for (@instances) { $_->{_dbh_gen}++; # so that existing cursors will drop as well $_->_dbh(undef); $_->transaction_depth(0); $_->savepoints([]); } + + # properly renumber all existing refs + %seek_and_destroy = (); + $_->_arm_global_destructor for @instances; } } @@ -233,7 +234,7 @@ sub DESTROY { my $self = shift; # some databases spew warnings on implicit disconnect - $self->_verify_pid; + $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; local $SIG{__WARN__} = sub {}; $self->_dbh(undef); @@ -792,7 +793,10 @@ sub dbh_do { return $self->$run_target($self->_get_dbh, @_) if $self->{_in_do_block} or $self->transaction_depth; - my $args = \@_; + # take a ref instead of a copy, to preserve @_ aliasing + # semantics within the coderef, but only if needed + # (pseudoforking doesn't like this trick much) + my $args = @_ ? \@_ : []; DBIx::Class::Storage::BlockRunner->new( storage => $self, @@ -885,7 +889,7 @@ sub connected { sub _seems_connected { my $self = shift; - $self->_verify_pid; + $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; my $dbh = $self->_dbh or return 0; @@ -933,7 +937,7 @@ sub dbh { # this is the internal "get dbh or connect (don't check)" method sub _get_dbh { my $self = shift; - $self->_verify_pid; + $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; $self->_populate_dbh unless $self->_dbh; return $self->_dbh; } @@ -1007,7 +1011,7 @@ sub _populate_dbh { $self->_dbh($self->_connect(@info)); - $self->_conn_pid($$) if $^O ne 'MSWin32'; # on win32 these are in fact threads + $self->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads $self->_determine_driver; @@ -1075,7 +1079,16 @@ sub _server_info { $info = {}; - my $server_version = try { $self->_get_server_version }; + my $server_version = try { + $self->_get_server_version + } catch { + # driver determination *may* use this codepath + # in which case we must rethrow + $self->throw_exception($_) if $self->{_in_determine_driver}; + + # $server_version on failure + undef; + }; if (defined $server_version) { $info->{dbms_version} = $server_version; @@ -1119,7 +1132,64 @@ sub _dbh_get_info { unless defined $info; } - return try { $self->_get_dbh->get_info($info) } || undef; + return $self->_get_dbh->get_info($info); +} + +sub _describe_connection { + require DBI::Const::GetInfoReturn; + + my $self = shift; + $self->ensure_connected; + + my $res = { + DBIC_DSN => $self->_dbi_connect_info->[0], + DBI_VER => DBI->VERSION, + DBIC_VER => DBIx::Class->VERSION, + DBIC_DRIVER => ref $self, + }; + + for my $inf ( + #keys %DBI::Const::GetInfoType::GetInfoType, + qw/ + SQL_CURSOR_COMMIT_BEHAVIOR + SQL_CURSOR_ROLLBACK_BEHAVIOR + SQL_CURSOR_SENSITIVITY + SQL_DATA_SOURCE_NAME + SQL_DBMS_NAME + SQL_DBMS_VER + SQL_DEFAULT_TXN_ISOLATION + SQL_DM_VER + SQL_DRIVER_NAME + SQL_DRIVER_ODBC_VER + SQL_DRIVER_VER + SQL_EXPRESSIONS_IN_ORDERBY + SQL_GROUP_BY + SQL_IDENTIFIER_CASE + SQL_IDENTIFIER_QUOTE_CHAR + SQL_MAX_CATALOG_NAME_LEN + SQL_MAX_COLUMN_NAME_LEN + SQL_MAX_IDENTIFIER_LEN + SQL_MAX_TABLE_NAME_LEN + SQL_MULTIPLE_ACTIVE_TXN + SQL_MULT_RESULT_SETS + SQL_NEED_LONG_DATA_LEN + SQL_NON_NULLABLE_COLUMNS + SQL_ODBC_VER + SQL_QUALIFIER_NAME_SEPARATOR + SQL_QUOTED_IDENTIFIER_CASE + SQL_TXN_CAPABLE + SQL_TXN_ISOLATION_OPTION + / + ) { + my $v = $self->_dbh_get_info($inf); + next unless defined $v; + + #my $key = sprintf( '%s(%s)', $inf, $DBI::Const::GetInfoType::GetInfoType{$inf} ); + my $expl = DBI::Const::GetInfoReturn::Explain($inf, $v); + $res->{$inf} = DBI::Const::GetInfoReturn::Format($inf, $v) . ( $expl ? " ($expl)" : '' ); + } + + $res; } sub _determine_driver { @@ -1134,7 +1204,8 @@ sub _determine_driver { if ($self->_dbh) { # we are connected $driver = $self->_dbh->{Driver}{Name}; $started_connected = 1; - } else { + } + else { # if connect_info is a CODEREF, we have no choice but to connect if (ref $self->_dbi_connect_info->[0] && reftype $self->_dbi_connect_info->[0] eq 'CODE') { @@ -1158,6 +1229,18 @@ sub _determine_driver { bless $self, $storage_class; $self->_rebless(); } + else { + $self->_warn_undetermined_driver( + 'This version of DBIC does not yet seem to supply a driver for ' + . "your particular RDBMS and/or connection method ('$driver')." + ); + } + } + else { + $self->_warn_undetermined_driver( + 'Unable to extract a driver name from connect info - this ' + . 'should not have happened.' + ); } } @@ -1165,6 +1248,15 @@ sub _determine_driver { Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; + if ($self->can('source_bind_attributes')) { + $self->throw_exception( + "Your storage subclass @{[ ref $self ]} provides (or inherits) the method " + . 'source_bind_attributes() for which support has been removed as of Jan 2013. ' + . 'If you are not sure how to proceed please contact the development team via ' + . 'http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT' + ); + } + $self->_init; # run driver-specific initializations $self->_run_connection_actions @@ -1172,6 +1264,48 @@ sub _determine_driver { } } +sub _determine_connector_driver { + my ($self, $conn) = @_; + + my $dbtype = $self->_dbh_get_info('SQL_DBMS_NAME'); + + if (not $dbtype) { + $self->_warn_undetermined_driver( + 'Unable to retrieve RDBMS type (SQL_DBMS_NAME) of the engine behind your ' + . "$conn connector - this should not have happened." + ); + return; + } + + $dbtype =~ s/\W/_/gi; + + my $subclass = "DBIx::Class::Storage::DBI::${conn}::${dbtype}"; + return if $self->isa($subclass); + + if ($self->load_optional_class($subclass)) { + bless $self, $subclass; + $self->_rebless; + } + else { + $self->_warn_undetermined_driver( + 'This version of DBIC does not yet seem to supply a driver for ' + . "your particular RDBMS and/or connection method ('$conn/$dbtype')." + ); + } +} + +sub _warn_undetermined_driver { + my ($self, $msg) = @_; + + require Data::Dumper::Concise; + + carp_once ($msg . ' While we will attempt to continue anyway, the results ' + . 'are likely to be underwhelming. Please upgrade DBIC, and if this message ' + . "does not go away, file a bugreport including the following info:\n" + . Data::Dumper::Concise::Dumper($self->_describe_connection) + ); +} + sub _do_connection_actions { my $self = shift; my $method_prefix = shift; @@ -1254,10 +1388,17 @@ sub _connect { $dbh = DBI->connect(@info); } - if (!$dbh) { - die $DBI::errstr; - } + die $DBI::errstr unless $dbh; + + die sprintf ("%s fresh DBI handle with a *false* 'Active' attribute. " + . 'This handle is disconnected as far as DBIC is concerned, and we can ' + . 'not continue', + ref $info[0] eq 'CODE' + ? "Connection coderef $info[0] returned a" + : 'DBI->connect($schema->storage->connect_info) resulted in a' + ) unless $dbh->FETCH('Active'); + # sanity checks unless asked otherwise unless ($self->unsafe) { $self->throw_exception( @@ -1345,7 +1486,7 @@ sub _exec_txn_begin { sub txn_commit { my $self = shift; - $self->_verify_pid if $self->_dbh; + $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; $self->throw_exception("Unable to txn_commit() on a disconnected storage") unless $self->_dbh; @@ -1376,7 +1517,7 @@ sub _exec_txn_commit { sub txn_rollback { my $self = shift; - $self->_verify_pid if $self->_dbh; + $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; $self->throw_exception("Unable to txn_rollback() on a disconnected storage") unless $self->_dbh; @@ -1409,7 +1550,7 @@ for my $meth (qw/svp_begin svp_release svp_rollback/) { no strict qw/refs/; *{__PACKAGE__ ."::$meth"} = subname $meth => sub { my $self = shift; - $self->_verify_pid if $self->_dbh; + $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; $self->throw_exception("Unable to $meth() on a disconnected storage") unless $self->_dbh; $self->next::method(@_); @@ -1427,10 +1568,13 @@ sub _prep_for_execute { sub _gen_sql_bind { my ($self, $op, $ident, $args) = @_; - my ($sql, @bind) = $self->sql_maker->$op( - blessed($ident) ? $ident->from : $ident, - @$args, - ); + my ($colinfos, $from); + if ( blessed($ident) ) { + $from = $ident->from; + $colinfos = $ident->columns_info; + } + + my ($sql, @bind) = $self->sql_maker->$op( ($from || $ident), @$args ); if ( ! $ENV{DBIC_DT_SEARCH_OK} @@ -1447,7 +1591,7 @@ sub _gen_sql_bind { } return( $sql, $self->_resolve_bindattrs( - $ident, [ @{$args->[2]{bind}||[]}, @bind ] + $ident, [ @{$args->[2]{bind}||[]}, @bind ], $colinfos )); } @@ -1527,30 +1671,9 @@ sub _query_end { if $self->debug; } -my $sba_compat; sub _dbi_attrs_for_bind { my ($self, $ident, $bind) = @_; - if (! defined $sba_compat) { - $self->_determine_driver; - $sba_compat = $self->can('source_bind_attributes') == \&source_bind_attributes - ? 0 - : 1 - ; - } - - my $sba_attrs; - if ($sba_compat) { - my $class = ref $self; - carp_unique ( - "The source_bind_attributes() override in $class relies on a deprecated codepath. " - .'You are strongly advised to switch your code to override bind_attribute_by_datatype() ' - .'instead. This legacy compat shim will also disappear some time before DBIC 0.09' - ); - - my $sba_attrs = $self->source_bind_attributes - } - my @attrs; for (map { $_->[0] } @$bind) { @@ -1567,9 +1690,6 @@ sub _dbi_attrs_for_bind { } $cache->{$_->{sqlt_datatype}}; } - elsif ($sba_attrs and $_->{dbic_colname}) { - $sba_attrs->{$_->{dbic_colname}} || undef; - } else { undef; # always push something at this position } @@ -1588,14 +1708,17 @@ sub _execute { '_dbh_execute', $sql, $bind, - $self->_dbi_attrs_for_bind($ident, $bind) + $ident, ); } sub _dbh_execute { - my ($self, undef, $sql, $bind, $bind_attrs) = @_; + my ($self, undef, $sql, $bind, $ident) = @_; $self->_query_start( $sql, $bind ); + + my $bind_attrs = $self->_dbi_attrs_for_bind($ident, $bind); + my $sth = $self->_sth($sql); for my $i (0 .. $#$bind) { @@ -1631,9 +1754,7 @@ sub _dbh_execute { } sub _prefetch_autovalues { - my ($self, $source, $to_insert) = @_; - - my $colinfo = $source->columns_info; + my ($self, $source, $colinfo, $to_insert) = @_; my %values; for my $col (keys %$colinfo) { @@ -1663,7 +1784,9 @@ sub _prefetch_autovalues { sub insert { my ($self, $source, $to_insert) = @_; - my $prefetched_values = $self->_prefetch_autovalues($source, $to_insert); + my $col_infos = $source->columns_info; + + my $prefetched_values = $self->_prefetch_autovalues($source, $col_infos, $to_insert); # fuse the values, but keep a separate list of prefetched_values so that # they can be fused once again with the final return @@ -1671,7 +1794,6 @@ sub insert { # FIXME - we seem to assume undef values as non-supplied. This is wrong. # Investigate what does it take to s/defined/exists/ - my $col_infos = $source->columns_info; my %pcols = map { $_ => 1 } $source->primary_columns; my (%retrieve_cols, $autoinc_supplied, $retrieve_autoinc_col); for my $col ($source->columns) { @@ -1805,7 +1927,7 @@ sub insert_bulk { # can't just hand SQLA a set of some known "values" (e.g. hashrefs that # can be later matched up by address), because we want to supply a real # value on which perhaps e.g. datatype checks will be performed - my ($proto_data, $value_type_idx); + my ($proto_data, $value_type_by_col_idx); for my $i (@col_range) { my $colname = $cols->[$i]; if (ref $data->[0][$i] eq 'SCALAR') { @@ -1824,18 +1946,18 @@ sub insert_bulk { # store value-less (attrs only) bind info - we will be comparing all # supplied binds against this for sanity - $value_type_idx->{$i} = [ map { $_->[0] } @$resolved_bind ]; + $value_type_by_col_idx->{$i} = [ map { $_->[0] } @$resolved_bind ]; $proto_data->{$colname} = \[ $sql, map { [ # inject slice order to use for $proto_bind construction - { %{$resolved_bind->[$_][0]}, _bind_data_slice_idx => $i } + { %{$resolved_bind->[$_][0]}, _bind_data_slice_idx => $i, _literal_bind_subindex => $_+1 } => $resolved_bind->[$_][1] ] } (0 .. $#bind) ]; } else { - $value_type_idx->{$i} = 0; + $value_type_by_col_idx->{$i} = undef; $proto_data->{$colname} = \[ '?', [ { dbic_colname => $colname, _bind_data_slice_idx => $i } @@ -1851,7 +1973,7 @@ sub insert_bulk { [ $proto_data ], ); - if (! @$proto_bind and keys %$value_type_idx) { + if (! @$proto_bind and keys %$value_type_by_col_idx) { # if the bindlist is empty and we had some dynamic binds, this means the # storage ate them away (e.g. the NoBindVars component) and interpolated # them directly into the SQL. This obviously can't be good for multi-inserts @@ -1885,7 +2007,7 @@ sub insert_bulk { for my $row_idx (1..$#$data) { # we are comparing against what we got from [0] above, hence start from 1 my $val = $data->[$row_idx][$col_idx]; - if (! exists $value_type_idx->{$col_idx}) { # literal no binds + if (! exists $value_type_by_col_idx->{$col_idx}) { # literal no binds if (ref $val ne 'SCALAR') { $bad_slice_report_cref->( "Incorrect value (expecting SCALAR-ref \\'$$reference_val')", @@ -1901,7 +2023,7 @@ sub insert_bulk { ); } } - elsif (! $value_type_idx->{$col_idx} ) { # regular non-literal value + elsif (! defined $value_type_by_col_idx->{$col_idx} ) { # regular non-literal value if (ref $val eq 'SCALAR' or (ref $val eq 'REF' and ref $$val eq 'ARRAY') ) { $bad_slice_report_cref->("Literal SQL found where a plain bind value is expected", $row_idx, $col_idx); } @@ -1930,7 +2052,7 @@ sub insert_bulk { # need to check the bind attrs - a bind will happen only once for # the entire dataset, so any changes further down will be ignored. elsif (! Data::Compare::Compare( - $value_type_idx->{$col_idx}, + $value_type_by_col_idx->{$col_idx}, [ map { $_->[0] } @@ -2007,23 +2129,17 @@ sub _dbh_execute_for_fetch { # alphabetical ordering by colname). We actually do want to # preserve this behavior so that prepare_cached has a better # chance of matching on unrelated calls - my %data_reorder = map { $proto_bind->[$_][0]{_bind_data_slice_idx} => $_ } @idx_range; my $fetch_row_idx = -1; # saner loop this way my $fetch_tuple = sub { return undef if ++$fetch_row_idx > $#$data; - return [ map - { (ref $_ eq 'REF' and ref $$_ eq 'ARRAY') - ? map { $_->[-1] } @{$$_}[1 .. $#$$_] - : $_ - } - map - { $data->[$fetch_row_idx][$_]} - sort - { $data_reorder{$a} <=> $data_reorder{$b} } - keys %data_reorder - ]; + return [ map { defined $_->{_literal_bind_subindex} + ? ${ $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ]} + ->[ $_->{_literal_bind_subindex} ] + ->[1] + : $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ] + } map { $_->[0] } @$proto_bind]; }; my $tuple_status = []; @@ -2197,12 +2313,20 @@ sub _select_args { } # try to simplify the joinmap further (prune unreferenced type-single joins) - $ident = $self->_prune_unused_joins ($ident, $select, $where, $attrs); + if ( + ref $ident + and + reftype $ident eq 'ARRAY' + and + @$ident != 1 + ) { + $ident = $self->_prune_unused_joins ($ident, $select, $where, $attrs); + } ### # This would be the point to deflate anything found in $where # (and leave $attrs->{bind} intact). Problem is - inflators historically - # expect a row object. And all we have is a resultsource (it is trivial + # expect a result object. And all we have is a resultsource (it is trivial # to extract deflator coderefs via $alias2source above). # # I don't see a way forward other than changing the way deflators are @@ -2221,15 +2345,6 @@ sub _count_select { return { count => '*' }; } -sub source_bind_attributes { - shift->throw_exception( - 'source_bind_attributes() was never meant to be a callable public method - ' - .'please contact the DBIC dev-team and describe your use case so that a reasonable ' - .'solution can be provided' - ."\nhttp://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT" - ); -} - =head2 select =over 4 @@ -2476,7 +2591,10 @@ Given a datatype from column info, returns a database specific bind attribute for C<< $dbh->bind_param($val,$attribute) >> or nothing if we will let the database planner just handle it. -Generally only needed for special case column types, like bytea in postgres. +This method is always called after the driver has been determined and a DBI +connection has been established. Therefore you can refer to C +and/or C directly, without worrying about loading +the correct modules. =cut @@ -2509,7 +2627,7 @@ sub is_datatype_numeric { =over 4 -=item Arguments: $schema \@databases, $version, $directory, $preversion, \%sqlt_args +=item Arguments: $schema, \@databases, $version, $directory, $preversion, \%sqlt_args =back @@ -2571,7 +2689,7 @@ sub create_ddl_dir { } else { -d $dir or - (require File::Path and File::Path::make_path ("$dir")) # make_path does not like objects (i.e. Path::Class::Dir) + (require File::Path and File::Path::mkpath (["$dir"])) # mkpath does not like objects (i.e. Path::Class::Dir) or $self->throw_exception( "Failed to create '$dir': " . ($! || $@ || 'error unknown') @@ -2859,6 +2977,8 @@ sub lag_behind_master { =item Arguments: $relname, $join_count +=item Return Value: $alias + =back L uses L names as table aliases in @@ -2950,6 +3070,13 @@ sub _is_text_lob_type { |national\s*character\s*varying))\z/xi); } +# Determine if a data_type is some type of a binary type +sub _is_binary_type { + my ($self, $data_type) = @_; + $data_type && ($self->_is_binary_lob_type($data_type) + || $data_type =~ /(?:var)?(?:binary|bit|graphic)(?:\s*varying)?/i); +} + 1; =head1 USAGE NOTES @@ -2971,11 +3098,9 @@ cases if you choose the C<< AutoCommit => 0 >> path, just as you would be with raw DBI. -=head1 AUTHORS - -Matt S. Trout +=head1 AUTHOR AND CONTRIBUTORS -Andy Grundman +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/Storage/DBI/ACCESS.pm b/lib/DBIx/Class/Storage/DBI/ACCESS.pm index a6f174e..9384117 100644 --- a/lib/DBIx/Class/Storage/DBI/ACCESS.pm +++ b/lib/DBIx/Class/Storage/DBI/ACCESS.pm @@ -70,11 +70,9 @@ sub insert { $columns_info->{$_}{is_auto_increment} } keys %$columns_info; - if (not $autoinc_col) { - $self->throw_exception( -'empty insert only supported for tables with an autoincrement column' - ); - } + $self->throw_exception( + 'empty insert only supported for tables with an autoincrement column' + ) unless $autoinc_col; my $table = $source->from; $table = $$table if ref $table; diff --git a/lib/DBIx/Class/Storage/DBI/ADO.pm b/lib/DBIx/Class/Storage/DBI/ADO.pm index 8cca22d..0e5c286 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO.pm @@ -1,5 +1,8 @@ package DBIx::Class::Storage::DBI::ADO; +use warnings; +use strict; + use base 'DBIx::Class::Storage::DBI'; use mro 'c3'; @@ -19,31 +22,7 @@ should be transparent to the user. =cut -sub _rebless { - my $self = shift; - - my $dbtype = $self->_dbh_get_info('SQL_DBMS_NAME'); - - if (not $dbtype) { - warn "Unable to determine ADO driver, failling back to generic support.\n"; - return; - } - - $dbtype =~ s/\W/_/gi; - - my $subclass = "DBIx::Class::Storage::DBI::ADO::${dbtype}"; - - return if $self->isa($subclass); - - if ($self->load_optional_class($subclass)) { - bless $self, $subclass; - $self->_rebless; - } - else { - warn "Expected driver '$subclass' not found, using generic support. " . - "Please file an RT.\n"; - } -} +sub _rebless { shift->_determine_connector_driver('ADO') } # cleanup some warnings from DBD::ADO # RT#65563, not fixed as of DBD::ADO v2.98 diff --git a/lib/DBIx/Class/Storage/DBI/ADO/CursorUtils.pm b/lib/DBIx/Class/Storage/DBI/ADO/CursorUtils.pm index 93053ce..63e6038 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/CursorUtils.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/CursorUtils.pm @@ -8,7 +8,7 @@ use base 'Exporter'; our @EXPORT_OK = qw/_normalize_guids _strip_trailing_binary_nulls/; sub _strip_trailing_binary_nulls { - my ($select, $col_infos, $data) = @_; + my ($select, $col_infos, $data, $storage) = @_; foreach my $select_idx (0..$#$select) { @@ -18,7 +18,7 @@ sub _strip_trailing_binary_nulls { or next; $data->[$select_idx] =~ s/\0+\z// - if $data_type =~ /binary|image/i; + if $storage->_is_binary_type($data_type); } } diff --git a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm index 0d38311..6fb1b19 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm @@ -144,7 +144,7 @@ sub select_single { _normalize_guids($select, $col_infos, \@row, $self); - _strip_trailing_binary_nulls($select, $col_infos, \@row); + _strip_trailing_binary_nulls($select, $col_infos, \@row, $self); return @row; } diff --git a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm index d421145..9c02e9a 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm @@ -49,7 +49,7 @@ sub _dbh_next { my $select = $self->args->[1]; _normalize_guids($select, $col_infos, \@row, $storage); - _strip_trailing_binary_nulls($select, $col_infos, \@row); + _strip_trailing_binary_nulls($select, $col_infos, \@row, $storage); return @row; } @@ -67,7 +67,7 @@ sub _dbh_all { for (@rows) { _normalize_guids($select, $col_infos, $_, $storage); - _strip_trailing_binary_nulls($select, $col_infos, $_); + _strip_trailing_binary_nulls($select, $col_infos, $_, $storage); } return @rows; diff --git a/lib/DBIx/Class/Storage/DBI/Cursor.pm b/lib/DBIx/Class/Storage/DBI/Cursor.pm index bf17e90..a71036e 100644 --- a/lib/DBIx/Class/Storage/DBI/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/Cursor.pm @@ -9,7 +9,7 @@ use Try::Tiny; use namespace::clean; __PACKAGE__->mk_group_accessors('simple' => - qw/sth storage args pos attrs _dbh_gen/ + qw/sth storage args attrs/ ); =head1 NAME @@ -20,7 +20,12 @@ resultset. =head1 SYNOPSIS my $cursor = $schema->resultset('CD')->cursor(); - my $first_cd = $cursor->next; + + # raw values off the database handle in resultset columns/select order + my @next_cd_column_values = $cursor->next; + + # list of all raw values as arrayrefs + my @all_cds_column_values = $cursor->all; =head1 DESCRIPTION @@ -48,9 +53,10 @@ sub new { my $new = { storage => $storage, args => $args, - pos => 0, attrs => $attrs, _dbh_gen => $storage->{_dbh_gen}, + _pos => 0, + _done => 0, }; return bless ($new, $class); @@ -78,13 +84,15 @@ sub _dbh_next { if ( $self->{attrs}{software_limit} && $self->{attrs}{rows} - && $self->{pos} >= $self->{attrs}{rows} + && $self->{_pos} >= $self->{attrs}{rows} ) { $self->sth->finish if $self->sth->{Active}; $self->sth(undef); - $self->{done} = 1; + $self->{_done} = 1; } - return if $self->{done}; + + return if $self->{_done}; + unless ($self->sth) { $self->sth(($storage->_select(@{$self->{args}}))[1]); if ($self->{attrs}{software_limit}) { @@ -95,10 +103,10 @@ sub _dbh_next { } my @row = $self->sth->fetchrow_array; if (@row) { - $self->{pos}++; + $self->{_pos}++; } else { $self->sth(undef); - $self->{done} = 1; + $self->{_done} = 1; } return @row; } @@ -163,8 +171,8 @@ sub _soft_reset { my ($self) = @_; $self->sth(undef); - delete $self->{done}; - $self->{pos} = 0; + $self->{_done} = 0; + $self->{_pos} = 0; } sub _check_dbh_gen { diff --git a/lib/DBIx/Class/Storage/DBI/Informix.pm b/lib/DBIx/Class/Storage/DBI/Informix.pm index db953d4..ca6bf55 100644 --- a/lib/DBIx/Class/Storage/DBI/Informix.pm +++ b/lib/DBIx/Class/Storage/DBI/Informix.pm @@ -32,7 +32,6 @@ This class implements storage-specific support for the Informix RDBMS sub _execute { my $self = shift; - my ($op) = @_; my ($rv, $sth, @rest) = $self->next::method(@_); $self->__last_insert_id($sth->{ix_sqlerrd}[1]) diff --git a/lib/DBIx/Class/Storage/DBI/MSSQL.pm b/lib/DBIx/Class/Storage/DBI/MSSQL.pm index b20db9f..679fe7c 100644 --- a/lib/DBIx/Class/Storage/DBI/MSSQL.pm +++ b/lib/DBIx/Class/Storage/DBI/MSSQL.pm @@ -69,7 +69,6 @@ sub _prep_for_execute { sub _execute { my $self = shift; - my ($op) = @_; # always list ctx - we need the $sth my ($rv, $sth, @bind) = $self->next::method(@_); @@ -119,8 +118,8 @@ sub _select_args_to_query { scalar $self->_extract_order_criteria ($attrs->{order_by}) ) { $self->throw_exception( - 'An ordered subselect encountered - this is not safe! Please see "Ordered Subselects" in DBIx::Class::Storage::DBI::MSSQL - ') unless $attrs->{unsafe_subselect_ok}; + 'An ordered subselect encountered - this is not safe! Please see "Ordered Subselects" in DBIx::Class::Storage::DBI::MSSQL' + ) unless $attrs->{unsafe_subselect_ok}; my $max = $self->sql_maker->__max_int; $sql =~ s/^ \s* SELECT \s/SELECT TOP $max /xi; } diff --git a/lib/DBIx/Class/Storage/DBI/ODBC.pm b/lib/DBIx/Class/Storage/DBI/ODBC.pm index d9852e7..3462de1 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC.pm @@ -4,31 +4,9 @@ use warnings; use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; -sub _rebless { - my ($self) = @_; - - if (my $dbtype = $self->_dbh_get_info('SQL_DBMS_NAME')) { - # Translate the backend name into a perl identifier - $dbtype =~ s/\W/_/gi; - my $subclass = "DBIx::Class::Storage::DBI::ODBC::${dbtype}"; - - return if $self->isa($subclass); - - if ($self->load_optional_class($subclass)) { - bless $self, $subclass; - $self->_rebless; - } - else { - warn "Expected driver '$subclass' not found, using generic support. " . - "Please file an RT.\n"; - } - } - else { - warn "Could not determine your database type, using generic support.\n"; - } -} +sub _rebless { shift->_determine_connector_driver('ODBC') } -# Whether or not we are connecting via the freetds ODBC driver. +# Whether or not we are connecting via the freetds ODBC driver sub _using_freetds { my $self = shift; @@ -55,10 +33,10 @@ sub _disable_odbc_array_ops { my $self = shift; my $dbh = $self->_get_dbh; - if (eval { DBD::ODBC->VERSION('1.35_01') }) { + if (eval { DBD::ODBC->VERSION(1.35_01) }) { $dbh->{odbc_array_operations} = 0; } - elsif (eval { DBD::ODBC->VERSION('1.33_01') }) { + elsif (eval { DBD::ODBC->VERSION(1.33_01) }) { $dbh->{odbc_disable_array_operations} = 1; } } diff --git a/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm index 3aa9b9b..073837f 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm @@ -36,12 +36,13 @@ L. sudo aptitude install tdsodbc libdbd-odbc-perl unixodbc -In case it is not already there put the following in C: +In case it is not already there put the following (adjust for non-64bit arch) in +C: [FreeTDS] Description = FreeTDS - Driver = /usr/lib/odbc/libtdsodbc.so - Setup = /usr/lib/odbc/libtdsS.so + Driver = /usr/lib/x86_64-linux-gnu/odbc/libtdsodbc.so + Setup = /usr/lib/x86_64-linux-gnu/odbc/libtdsS.so UsageCount = 1 Set your C<$dsn> in L as follows: @@ -142,7 +143,7 @@ sub connect_call_use_mars { } if (my ($data_source) = $dsn =~ /^dbi:ODBC:([\w-]+)\z/i) { # prefix with DSN - warn "Bare DSN in ODBC connect string, rewriting as 'dsn=$data_source'" + carp_unique "Bare DSN in ODBC connect string, rewriting as 'dsn=$data_source'" ." for MARS\n"; $dsn = "dbi:ODBC:dsn=$data_source"; } diff --git a/lib/DBIx/Class/Storage/DBI/Oracle.pm b/lib/DBIx/Class/Storage/DBI/Oracle.pm index 2457596..b0184e8 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle.pm @@ -40,9 +40,9 @@ no matter the database version, add to your Schema class. -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -David Jack Olrik C<< >> +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm index c107934..af68023 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm @@ -203,7 +203,7 @@ sub _dbh_get_autoinc_seq { } else { $self->throw_exception( sprintf ( - "Unable to introspect trigger '%s' for column %s.%s (references multiple sequences). " + "Unable to introspect trigger '%s' for column '%s.%s' (references multiple sequences). " . "You need to specify the correct 'sequence' explicitly in '%s's column_info.", $triggers[0]{name}, $source_name, @@ -225,7 +225,7 @@ sub _dbh_get_autoinc_seq { } else { $self->throw_exception( sprintf ( - "Unable to reliably select a BEFORE INSERT trigger for column %s.%s (possibilities: %s). " + "Unable to reliably select a BEFORE INSERT trigger for column '%s.%s' (possibilities: %s). " . "You need to specify the correct 'sequence' explicitly in '%s's column_info.", $source_name, $col, @@ -246,7 +246,7 @@ sub _dbh_get_autoinc_seq { } $self->throw_exception( sprintf ( - "No suitable BEFORE INSERT triggers found for column %s.%s. " + "No suitable BEFORE INSERT triggers found for column '%s.%s'. " . "You need to specify the correct 'sequence' explicitly in '%s's column_info.", $source_name, $col, @@ -284,9 +284,10 @@ sub _ping { } sub _dbh_execute { - my ($self, $dbh, $sql, $bind) = @_; + #my ($self, $dbh, $sql, $bind, $ident) = @_; + my ($self, $bind) = @_[0,3]; - # Turn off sth caching for multi-part LOBs. See _prep_for_execute above. + # Turn off sth caching for multi-part LOBs. See _prep_for_execute below local $self->{disable_sth_caching} = 1 if first { ($_->[0]{_ora_lob_autosplit_part}||0) > @@ -511,7 +512,7 @@ sub _prep_for_execute { my ($final_sql, @final_binds); if ($op eq 'update') { - $self->throw_exception('Update with complex WHERE clauses currently not supported') + $self->throw_exception('Update with complex WHERE clauses involving BLOB columns currently not supported') if $sql =~ /\bWHERE\b .+ \bWHERE\b/xs; my $where_sql; diff --git a/lib/DBIx/Class/Storage/DBI/Pg.pm b/lib/DBIx/Class/Storage/DBI/Pg.pm index d38f84c..3e59028 100644 --- a/lib/DBIx/Class/Storage/DBI/Pg.pm +++ b/lib/DBIx/Class/Storage/DBI/Pg.pm @@ -48,7 +48,7 @@ sub last_insert_id { for my $col (@cols) { my $seq = ( $col_info->{$col}{sequence} ||= $self->dbh_do('_dbh_get_autoinc_seq', $source, $col) ) or $self->throw_exception( sprintf( - 'could not determine sequence for column %s.%s, please consider adding a schema-qualified sequence to its column info', + "Could not determine sequence for column '%s.%s', please consider adding a schema-qualified sequence to its column info", $source->name, $col, )); @@ -95,7 +95,7 @@ sub _dbh_get_autoinc_seq { $seq_expr = '' unless defined $seq_expr; $schema = "$schema." if defined $schema && length $schema; $self->throw_exception( sprintf ( - 'no sequence found for %s%s.%s, check the RDBMS table definition or explicitly set the '. + "No sequence found for '%s%s.%s', check the RDBMS table definition or explicitly set the ". "'sequence' for this column in %s", $schema ? "$schema." : '', $table, diff --git a/lib/DBIx/Class/Storage/DBI/Replicated.pm b/lib/DBIx/Class/Storage/DBI/Replicated.pm index 51fab90..adfe403 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated.pm @@ -20,6 +20,8 @@ use Try::Tiny; use namespace::clean -except => 'meta'; +=encoding utf8 + =head1 NAME DBIx::Class::Storage::DBI::Replicated - BETA Replicated database support @@ -330,8 +332,6 @@ my $method_dispatch = { _arm_global_destructor _verify_pid - source_bind_attributes - get_use_dbms_capability set_use_dbms_capability get_dbms_capability @@ -339,6 +339,10 @@ my $method_dispatch = { _dbh_details _dbh_get_info + _determine_connector_driver + _describe_connection + _warn_undetermined_driver + sql_limit_dialect sql_quote_char sql_name_sep @@ -352,6 +356,7 @@ my $method_dispatch = { _max_column_bytesize _is_lob_type _is_binary_lob_type + _is_binary_type _is_text_lob_type sth @@ -393,7 +398,7 @@ if (DBIx::Class::_ENV_::DBICTEST) { for my $method (@{$method_dispatch->{unimplemented}}) { __PACKAGE__->meta->add_method($method, sub { my $self = shift; - $self->throw_exception("$method must not be called on ".(blessed $self).' objects'); + $self->throw_exception("$method() must not be called on ".(blessed $self).' objects'); }); } @@ -442,6 +447,11 @@ C, C, C and C. around connect_info => sub { my ($next, $self, $info, @extra) = @_; + $self->throw_exception( + 'connect_info can not be retrieved from a replicated storage - ' + . 'accessor must be called on a specific pool instance' + ) unless defined $info; + my $merge = Hash::Merge->new('LEFT_PRECEDENT'); my %opts; diff --git a/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm b/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm index 82d3b6a..aec2ec1 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated/Balancer.pm @@ -239,7 +239,7 @@ sub _get_forced_pool { } elsif(my $replicant = $self->pool->replicants->{$forced_pool}) { return $replicant; } else { - $self->master->throw_exception("$forced_pool is not a named replicant."); + $self->master->throw_exception("'$forced_pool' is not a named replicant."); } } diff --git a/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm b/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm index 834a4d5..b830921 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm @@ -45,12 +45,10 @@ sub last_insert_id { shift->_identity } sub _prefetch_autovalues { my $self = shift; - my ($source, $to_insert) = @_; + my ($source, $colinfo, $to_insert) = @_; my $values = $self->next::method(@_); - my $colinfo = $source->columns_info; - my $identity_col = first { $colinfo->{$_}{is_auto_increment} } keys %$colinfo; diff --git a/lib/DBIx/Class/Storage/DBI/SQLite.pm b/lib/DBIx/Class/Storage/DBI/SQLite.pm index 6943c77..14c07d2 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLite.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLite.pm @@ -8,6 +8,7 @@ use mro 'c3'; use DBIx::Class::Carp; use Scalar::Util 'looks_like_number'; +use Try::Tiny; use namespace::clean; __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::SQLite'); @@ -91,6 +92,86 @@ sub _exec_svp_rollback { $self->_dbh->do("ROLLBACK TRANSACTION TO SAVEPOINT $name"); } +sub _ping { + my $self = shift; + + # Be extremely careful what we do here. SQLite is notoriously bad at + # synchronizing its internal transaction state with {AutoCommit} + # https://metacpan.org/source/ADAMK/DBD-SQLite-1.37/lib/DBD/SQLite.pm#L921 + # There is a function http://www.sqlite.org/c3ref/get_autocommit.html + # but DBD::SQLite does not expose it (nor does it seem to properly use it) + + # Therefore only execute a "ping" when we have no other choice *AND* + # scrutinize the thrown exceptions to make sure we are where we think we are + my $dbh = $self->_dbh or return undef; + return undef unless $dbh->FETCH('Active'); + return undef unless $dbh->ping; + + # since we do not have access to sqlite3_get_autocommit(), do a trick + # to attempt to *safely* determine what state are we *actually* in. + # FIXME + # also using T::T here leads to bizarre leaks - will figure it out later + my $really_not_in_txn = do { + local $@; + + # older versions of DBD::SQLite do not properly detect multiline BEGIN/COMMIT + # statements to adjust their {AutoCommit} state. Hence use such a statement + # pair here as well, in order to escape from poking {AutoCommit} needlessly + # https://rt.cpan.org/Public/Bug/Display.html?id=80087 + eval { + # will fail instantly if already in a txn + $dbh->do("-- multiline\nBEGIN"); + $dbh->do("-- multiline\nCOMMIT"); + 1; + } or do { + ($@ =~ /transaction within a transaction/) + ? 0 + : undef + ; + }; + }; + + my $ping_fail; + + # if we were unable to determine this - we may very well be dead + if (not defined $really_not_in_txn) { + $ping_fail = 1; + } + # check the AC sync-state + elsif ($really_not_in_txn xor $dbh->{AutoCommit}) { + carp_unique (sprintf + 'Internal transaction state of handle %s (apparently %s a transaction) does not seem to ' + . 'match its AutoCommit attribute setting of %s - this is an indication of a ' + . 'potentially serious bug in your transaction handling logic', + $dbh, + $really_not_in_txn ? 'NOT in' : 'in', + $dbh->{AutoCommit} ? 'TRUE' : 'FALSE', + ); + + # it is too dangerous to execute anything else in this state + # assume everything works (safer - worst case scenario next statement throws) + return 1; + } + else { + # do the actual test + $ping_fail = ! try { $dbh->do('SELECT * FROM sqlite_master LIMIT 1'); 1 }; + } + + if ($ping_fail) { + # it is possible to have a proper "connection", and have "ping" return + # false anyway (e.g. corrupted file). In such cases DBD::SQLite still + # keeps the actual file handle open. We don't really want this to happen, + # so force-close the handle via DBI itself + # + local $@; # so that we do not clober the real error as set above + eval { $dbh->disconnect }; # if it fails - it fails + return undef # the actual RV of _ping() + } + else { + return 1; + } +} + sub deployment_statements { my $self = shift; my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_; @@ -110,7 +191,7 @@ sub deployment_statements { sub bind_attribute_by_data_type { $_[1] =~ /^ (?: int(?:eger)? | (?:tiny|small|medium)int ) $/ix - ? do { require DBI; DBI::SQL_INTEGER() } + ? DBI::SQL_INTEGER() : undef ; } @@ -176,9 +257,9 @@ sub connect_call_use_foreign_keys { 1; -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S. Trout +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/Storage/DBI/Sybase.pm b/lib/DBIx/Class/Storage/DBI/Sybase.pm index 32f7996..02464e4 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase.pm @@ -28,7 +28,7 @@ sub _rebless { try { $dbtype = @{$self->_get_dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2] } catch { - $self->throw_exception("Unable to estable connection to determine database type: $_") + $self->throw_exception("Unable to establish connection to determine database type: $_") }; if ($dbtype) { diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm index f7121e1..346dcd9 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm @@ -255,7 +255,7 @@ sub _is_lob_column { sub _prep_for_execute { my $self = shift; - my ($op, $ident) = @_; + my $ident = $_[1]; # ### This is commented out because all tests pass. However I am leaving it @@ -263,6 +263,8 @@ sub _prep_for_execute { ### BTW it doesn't currently work exactly - need better sensitivity to # currently set value # + #my ($op, $ident) = @_; + # # inherit these from the parent for the duration of _prep_for_execute # Don't know how to make a localizing loop with if's, otherwise I would #local $self->{_autoinc_supplied_for_op} @@ -322,8 +324,6 @@ sub _native_data_type { sub _execute { my $self = shift; - my ($op) = @_; - my ($rv, $sth, @bind) = $self->next::method(@_); $self->_identity( ($sth->fetchall_arrayref)->[0][0] ) @@ -1068,6 +1068,18 @@ for information on changing the setting on the server side. See L to setup date formats for L. +=head1 LIMITED QUERIES + +Because ASE does not have a good way to limit results in SQL that works for all +types of queries, the limit dialect is set to +L. + +Fortunately, ASE and L support cursors properly, so when +L is too slow you can use +the L +L attribute to simulate limited queries by skipping over +records. + =head1 TEXT/IMAGE COLUMNS L compiled with FreeTDS will B allow you to insert or update diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm index 8eeee49..b5ade31 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm @@ -1,5 +1,8 @@ package DBIx::Class::Storage::DBI::Sybase::ASE::NoBindVars; +use warnings; +use strict; + use base qw/ DBIx::Class::Storage::DBI::NoBindVars DBIx::Class::Storage::DBI::Sybase::ASE diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/MSSQL.pm b/lib/DBIx/Class/Storage/DBI/Sybase/MSSQL.pm index 9433bf0..aeb6aab 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/MSSQL.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/MSSQL.pm @@ -37,11 +37,9 @@ This subclass supports MSSQL connected via L. $schema->storage_type('::DBI::Sybase::MSSQL'); $schema->connect_info('dbi:Sybase:....', ...); -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Brandon L Black - -Justin Hunter +See L and L in DBIx::Class =head1 LICENSE diff --git a/lib/DBIx/Class/Storage/DBI/UniqueIdentifier.pm b/lib/DBIx/Class/Storage/DBI/UniqueIdentifier.pm index 8621da0..6d48a4a 100644 --- a/lib/DBIx/Class/Storage/DBI/UniqueIdentifier.pm +++ b/lib/DBIx/Class/Storage/DBI/UniqueIdentifier.pm @@ -59,9 +59,7 @@ sub _is_guid_type { sub _prefetch_autovalues { my $self = shift; - my ($source, $to_insert) = @_; - - my $col_info = $source->columns_info; + my ($source, $col_info, $to_insert) = @_; my %guid_cols; my @pk_cols = $source->primary_columns; @@ -92,7 +90,7 @@ sub _prefetch_autovalues { if (not defined $guid_method) { $self->throw_exception( - 'You must set new_guid on your storage. See perldoc ' + 'You must set new_guid() on your storage. See perldoc ' .'DBIx::Class::Storage::DBI::UniqueIdentifier' ); } diff --git a/lib/DBIx/Class/Storage/DBI/mysql.pm b/lib/DBIx/Class/Storage/DBI/mysql.pm index dc7ff90..ae55f1f 100644 --- a/lib/DBIx/Class/Storage/DBI/mysql.pm +++ b/lib/DBIx/Class/Storage/DBI/mysql.pm @@ -5,6 +5,9 @@ use warnings; use base qw/DBIx::Class::Storage::DBI/; +use List::Util 'first'; +use namespace::clean; + __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::MySQL'); __PACKAGE__->sql_limit_dialect ('LimitXY'); __PACKAGE__->sql_quote_char ('`'); @@ -32,6 +35,56 @@ sub _dbh_last_insert_id { $dbh->{mysql_insertid}; } +sub _prep_for_execute { + my $self = shift; + #(my $op, $ident, $args) = @_; + + # Only update and delete need special double-subquery treatment + # Insert referencing the same table (i.e. SELECT MAX(id) + 1) seems + # to work just fine on MySQL + return $self->next::method(@_) if ( $_[0] eq 'select' or $_[0] eq 'insert' ); + + + # FIXME FIXME FIXME - this is a terrible, gross, incomplete hack + # it should be trivial for mst to port this to DQ (and a good + # exercise as well, since we do not yet have such wide tree walking + # in place). For the time being this will work in limited cases, + # mainly complex update/delete, which is really all we want it for + # currently (allows us to fix some bugs without breaking MySQL in + # the process, and is also crucial for Shadow to be usable) + + # extract the source name, construct modification indicator re + my $sm = $self->sql_maker; + + my $target_name = $_[1]->from; + + if (ref $target_name) { + if ( + ref $target_name eq 'SCALAR' + and + $$target_name =~ /^ (?: + \` ( [^`]+ ) \` #` + | ( [\w\-]+ ) + ) $/x + ) { + # this is just a plain-ish name, which has been literal-ed for + # whatever reason + $target_name = first { defined $_ } ($1, $2); + } + else { + # this is something very complex, perhaps a custom result source or whatnot + # can't deal with it + undef $target_name; + } + } + + local $sm->{_modification_target_referenced_re} = + qr/ (?next::method(@_); +} + # here may seem like an odd place to override, but this is the first # method called after we are connected *and* the driver is determined # ($self is reblessed). See code flow in ::Storage::DBI::_populate_dbh diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm index 3efd488..a8eca16 100644 --- a/lib/DBIx/Class/Storage/DBIHacks.pm +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -72,20 +72,44 @@ sub _adjust_select_args_for_complex_prefetch { $self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute') if (ref $from ne 'ARRAY' || ref $from->[0] ne 'HASH' || ref $from->[1] ne 'ARRAY'); - # generate inner/outer attribute lists, remove stuff that doesn't apply my $outer_attrs = { %$attrs }; delete $outer_attrs->{$_} for qw/where bind rows offset group_by having/; - my $inner_attrs = { %$attrs, _is_internal_subuery => 1 }; + my $inner_attrs = { %$attrs }; delete $inner_attrs->{$_} for qw/for collapse _prefetch_selector_range select as/; + # if the user did not request it, there is no point using it inside + delete $inner_attrs->{order_by} if delete $inner_attrs->{_order_is_artificial}; + # generate the inner/outer select lists # for inside we consider only stuff *not* brought in by the prefetch # on the outside we substitute any function for its alias my $outer_select = [ @$select ]; my $inner_select = []; + my ($root_source, $root_source_offset); + + for my $i (0 .. $#$from) { + my $node = $from->[$i]; + my $h = (ref $node eq 'HASH') ? $node + : (ref $node eq 'ARRAY' and ref $node->[0] eq 'HASH') ? $node->[0] + : next + ; + + if ( ($h->{-alias}||'') eq $attrs->{alias} and $root_source = $h->{-rsrc} ) { + $root_source_offset = $i; + last; + } + } + + $self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute') + unless $root_source; + + # use the heavy duty resolver to take care of aliased/nonaliased naming + my $colinfo = $self->_resolve_column_info($from); + my $selected_root_columns; + my ($p_start, $p_end) = @{$outer_attrs->{_prefetch_selector_range}}; for my $i (0 .. $p_start - 1, $p_end + 1 .. $#$outer_select) { my $sel = $outer_select->[$i]; @@ -94,12 +118,44 @@ sub _adjust_select_args_for_complex_prefetch { $sel->{-as} ||= $attrs->{as}[$i]; $outer_select->[$i] = join ('.', $attrs->{alias}, ($sel->{-as} || "inner_column_$i") ); } + elsif (! ref $sel and my $ci = $colinfo->{$sel}) { + $selected_root_columns->{$ci->{-colname}} = 1; + } push @$inner_select, $sel; push @{$inner_attrs->{as}}, $attrs->{as}[$i]; } + # We will need to fetch all native columns in the inner subquery, which may be a part + # of an *outer* join condition. We can not just fetch everything because a potential + # has_many restricting join collapse *will not work* on heavy data types. + # Time for more horrible SQL parsing, aughhhh + + # MASSIVE FIXME - in fact when we are fully transitioned to DQ and the support is + # is sane - we will need to trim the select list to *only* fetch stuff that is + # necessary to build joins. In the current implementation if I am selecting a blob + # and the group_by kicks in - we are fucked, and all the user can do is not select + # that column. This is silly! + + my $retardo_sqla_cache = {}; + for my $cond ( map { $_->[1] } @{$from}[$root_source_offset + 1 .. $#$from] ) { + for my $col (@{$self->_extract_condition_columns($cond, $retardo_sqla_cache)}) { + my $ci = $colinfo->{$col}; + if ( + $ci + and + $ci->{-source_alias} eq $attrs->{alias} + and + ! $selected_root_columns->{$ci->{-colname}}++ + ) { + # adding it to both to keep limits not supporting dark selectors happy + push @$inner_select, $ci->{-fq_colname}; + push @{$inner_attrs->{as}}, $ci->{-fq_colname}; + } + } + } + # construct the inner $from and lock it in a subquery # we need to prune first, because this will determine if we need a group_by below # the fake group_by is so that the pruner throws away all non-selecting, non-restricting @@ -162,28 +218,35 @@ sub _adjust_select_args_for_complex_prefetch { # - it is part of the restrictions, in which case we need to collapse the outer # result by tackling yet another group_by to the outside of the query + # work on a shallow copy $from = [ @$from ]; - # so first generate the outer_from, up to the substitution point my @outer_from; - while (my $j = shift @$from) { - $j = [ $j ] unless ref $j eq 'ARRAY'; # promote the head-from to an AoH - if ($j->[0]{-alias} eq $attrs->{alias}) { # time to swap + # we may not be the head + if ($root_source_offset) { + # first generate the outer_from, up to the substitution point + @outer_from = splice @$from, 0, $root_source_offset; - push @outer_from, [ - { - -alias => $attrs->{alias}, - -rsrc => $j->[0]{-rsrc}, - $attrs->{alias} => $inner_subq, - }, - @{$j}[1 .. $#$j], - ]; - last; # we'll take care of what's left in $from below - } - else { - push @outer_from, $j; - } + my $root_node = shift @$from; + + push @outer_from, [ + { + -alias => $attrs->{alias}, + -rsrc => $root_node->[0]{-rsrc}, + $attrs->{alias} => $inner_subq, + }, + @{$root_node}[1 .. $#$root_node], + ]; + } + else { + my $root_node = shift @$from; + + @outer_from = { + -alias => $attrs->{alias}, + -rsrc => $root_node->{-rsrc}, + $attrs->{alias} => $inner_subq, + }; } # scan the *remaining* from spec against different attributes, and see which joins are needed @@ -214,9 +277,6 @@ sub _adjust_select_args_for_complex_prefetch { } } - # demote the outer_from head - $outer_from[0] = $outer_from[0][0]; - if ($need_outer_group_by and ! $outer_attrs->{group_by}) { my $unprocessed_order_chunks; @@ -589,11 +649,11 @@ sub _inner_join_to_node { # yet another atrocity: attempt to extract all columns from a # where condition by hooking _quote sub _extract_condition_columns { - my ($self, $cond, $sql_maker) = @_; + my ($self, $cond, $sql_maker_cache) = @_; return [] unless $cond; - $sql_maker ||= $self->{_sql_ident_capturer} ||= do { + my $sm = $sql_maker_cache->{condparser} ||= $self->{_sql_ident_capturer} ||= do { # FIXME - replace with a Moo trait my $orig_sm_class = ref $self->sql_maker; my $smic_class = "${orig_sm_class}::_IdentCapture_"; @@ -636,9 +696,9 @@ sub _extract_condition_columns { $smic_class->new(); }; - $sql_maker->_recurse_where($cond); + $sm->_recurse_where($cond); - return [ sort keys %{$sql_maker->_get_captured_idents} ]; + return [ sort keys %{$sm->_get_captured_idents} ]; } sub _extract_order_criteria { diff --git a/lib/DBIx/Class/Storage/Statistics.pm b/lib/DBIx/Class/Storage/Statistics.pm index eb536cd..7e491cd 100644 --- a/lib/DBIx/Class/Storage/Statistics.pm +++ b/lib/DBIx/Class/Storage/Statistics.pm @@ -202,12 +202,12 @@ sub query_end { 1; -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Cory G. Watson +See L and L in DBIx::Class =head1 LICENSE -You may distribute this code under the same license as Perl itself. +You may distribute this code under the same terms as Perl itself. =cut diff --git a/lib/DBIx/Class/Storage/TxnScopeGuard.pm b/lib/DBIx/Class/Storage/TxnScopeGuard.pm index 3263096..18e2260 100644 --- a/lib/DBIx/Class/Storage/TxnScopeGuard.pm +++ b/lib/DBIx/Class/Storage/TxnScopeGuard.pm @@ -5,12 +5,9 @@ use warnings; use Try::Tiny; use Scalar::Util qw/weaken blessed refaddr/; use DBIx::Class; -use DBIx::Class::Exception; use DBIx::Class::Carp; use namespace::clean; -my ($guards_count, $compat_handler, $foreign_handler); - sub new { my ($class, $storage) = @_; @@ -34,41 +31,6 @@ sub new { bless $guard, ref $class || $class; - # install a callback carefully - if (DBIx::Class::_ENV_::INVISIBLE_DOLLAR_AT and !$guards_count) { - - # if the thrown exception is a plain string, wrap it in our - # own exception class - # this is actually a pretty cool idea, may very well keep it - # after perl is fixed - $compat_handler ||= bless( - sub { - $@ = (blessed($_[0]) or ref($_[0])) - ? $_[0] - : bless ( { msg => $_[0] }, 'DBIx::Class::Exception') - ; - die; - }, - '__TxnScopeGuard__FIXUP__', - ); - - if ($foreign_handler = $SIG{__DIE__}) { - $SIG{__DIE__} = bless ( - sub { - # we trust the foreign handler to do whatever it wants, all we do is set $@ - eval { $compat_handler->(@_) }; - $foreign_handler->(@_); - }, - '__TxnScopeGuard__FIXUP__', - ); - } - else { - $SIG{__DIE__} = $compat_handler; - } - } - - $guards_count++; - $guard; } @@ -85,33 +47,10 @@ sub commit { sub DESTROY { my $self = shift; - $guards_count--; - - # don't touch unless it's ours, and there are no more of us left - if ( - DBIx::Class::_ENV_::INVISIBLE_DOLLAR_AT - and - !$guards_count - ) { - - if (ref $SIG{__DIE__} eq '__TxnScopeGuard__FIXUP__') { - # restore what we saved - if ($foreign_handler) { - $SIG{__DIE__} = $foreign_handler; - } - else { - delete $SIG{__DIE__}; - } - } - - # make sure we do not leak the foreign one in case it exists - undef $foreign_handler; - } - return if $self->{inactivated}; # if our dbh is not ours anymore, the $dbh weakref will go undef - $self->{storage}->_verify_pid; + $self->{storage}->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; return unless $self->{dbh}; my $exception = $@ if ( @@ -164,7 +103,7 @@ sub DESTROY { } } - $@ = $exception unless DBIx::Class::_ENV_::INVISIBLE_DOLLAR_AT; + $@ = $exception; } 1; diff --git a/lib/SQL/Translator/Parser/DBIx/Class.pm b/lib/SQL/Translator/Parser/DBIx/Class.pm index 755ac4a..dc13790 100644 --- a/lib/SQL/Translator/Parser/DBIx/Class.pm +++ b/lib/SQL/Translator/Parser/DBIx/Class.pm @@ -16,7 +16,7 @@ use Exporter; use SQL::Translator::Utils qw(debug normalize_name); use DBIx::Class::Carp qw/^SQL::Translator|^DBIx::Class|^Try::Tiny/; use DBIx::Class::Exception; -use Scalar::Util qw/weaken blessed/; +use Scalar::Util 'blessed'; use Try::Tiny; use namespace::clean; @@ -40,11 +40,6 @@ sub parse { $dbicschema ||= $args->{'package'}; my $limit_sources = $args->{'sources'}; - # this is a hack to prevent schema leaks due to a retarded SQLT implementation - # DO NOT REMOVE (until SQLT2 is out, the all of this will be rewritten anyway) - ref $_ and weaken $_ - for $_[1], $dbicschema, @{$args}{qw/DBIx::Schema DBIx::Class::Schema package/}; - DBIx::Class::Exception->throw('No DBIx::Class::Schema') unless ($dbicschema); if (!ref $dbicschema) { eval "require $dbicschema" @@ -154,7 +149,7 @@ sub parse { my $relsource = try { $source->related_source($rel) }; unless ($relsource) { - warn "Ignoring relationship '$rel' - related resultsource '$rel_info->{class}' is not registered with this schema\n"; + carp "Ignoring relationship '$rel' - related resultsource '$rel_info->{class}' is not registered with this schema\n"; next; }; diff --git a/maint/Makefile.PL.inc/11_authortests.pl b/maint/Makefile.PL.inc/11_authortests.pl index 3b9c174..f9f78ee 100644 --- a/maint/Makefile.PL.inc/11_authortests.pl +++ b/maint/Makefile.PL.inc/11_authortests.pl @@ -9,23 +9,58 @@ File::Find::find(sub { ); }, 'xt'); -my $xt_tests = join (' ', map { File::Spec->catfile($_, '*.t') } sort keys %$xt_dirs ); +my @xt_tests = map { File::Spec->catfile($_, '*.t') } sort keys %$xt_dirs; # this will add the xt tests to the `make test` target among other things -Meta->tests(join (' ', map { $_ || () } Meta->tests, $xt_tests ) ); +Meta->tests(join (' ', map { $_ || () } Meta->tests, @xt_tests ) ); -# inject an explicit xt test run for making a tarball (distdir is exempt) +# inject an explicit xt test run, mainly to check the contents of +# lib and the generated POD's *before* anything is copied around +# +# at the end rerun the whitespace test in the distdir, to make sure everything +# is pristine postamble <<"EOP"; -.PHONY: test_xt +dbic_clonedir_copy_generated_pod : test_xt -dist : test_xt +test_xt : pm_to_blib +@{[ + # When xt tests are explicitly requested, we want to run with RELEASE_TESTING=1 + # so that all optdeps are turned into a hard failure + # However portably modifying ENV for a single command is surprisingly hard + # So instead we (ab)use perl's ability to stack -e options, and simply modify + # the ENV from within perl itself + $mm_proto->test_via_harness( + # perl cmd + join( ' ', + '$(ABSPERLRUN)', + map { $mm_proto->quote_literal($_) } qw(-e $ENV{RELEASE_TESTING}=1;$ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}=1;) + ), + # test list + join( ' ', + map { $mm_proto->quote_literal($_) } @xt_tests + ), + ) +]} -test_xt : -\tPERL_DL_NONLAZY=1 RELEASE_TESTING=1 \$(FULLPERLRUN) "-MExtUtils::Command::MM" "-e" "test_harness(\$(TEST_VERBOSE), 'inc', '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $xt_tests +create_distdir : dbic_distdir_retest_whitespace -EOP +dbic_distdir_retest_whitespace : +\t@{[ + $mm_proto->cd ( + '$(DISTVNAME)', + $mm_proto->test_via_harness( + # perl cmd + join( ' ', + '$(ABSPERLRUN)', + map { $mm_proto->quote_literal($_) } qw(-Ilib -e $ENV{RELEASE_TESTING}=1;$ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}=1;) + ), + 'xt/whitespace.t' + ) + ) +]} +EOP # keep the Makefile.PL eval happy 1; diff --git a/maint/Makefile.PL.inc/12_authordeps.pl b/maint/Makefile.PL.inc/12_authordeps.pl index c4944d0..7068fcb 100644 --- a/maint/Makefile.PL.inc/12_authordeps.pl +++ b/maint/Makefile.PL.inc/12_authordeps.pl @@ -66,6 +66,9 @@ EOW # this will run after the Makefile is written and the main Makefile.PL terminates # END { + # shit already hit the fan + return if $?; + # Re-write META.yml at the end to _exclude_ all forced build-requires (we do not # want to ship this) We are also not using M::I::AuthorRequires as this will be # an extra dep, and deps in Makefile.PL still suck @@ -91,6 +94,12 @@ END { Meta->write; } + # strip possible crlf from META + if ($^O eq 'MSWin32' or $^O eq 'cygwin') { + local $ENV{PERLIO} = 'unix'; + system( $^X, qw( -MExtUtils::Command -e dos2unix -- META.yml), ); + } + # test that we really took things away (just in case, happened twice somehow) if (! -f 'META.yml') { warn "No META.yml generated?! aborting...\n"; diff --git a/maint/Makefile.PL.inc/21_meta_noindex.pl b/maint/Makefile.PL.inc/21_meta_noindex.pl index 9913b85..73527c6 100644 --- a/maint/Makefile.PL.inc/21_meta_noindex.pl +++ b/maint/Makefile.PL.inc/21_meta_noindex.pl @@ -5,9 +5,11 @@ no_index directory => $_ for (qw| lib/DBIx/Class/Admin lib/DBIx/Class/PK/Auto lib/DBIx/Class/CDBICompat + maint |); no_index package => $_ for (qw/ DBIx::Class::Storage::DBIHacks + DBIx::Class::Storage::BlockRunner DBIx::Class::Carp DBIx::Class::ResultSet::Pager /); diff --git a/maint/Makefile.PL.inc/29_handle_version.pl b/maint/Makefile.PL.inc/29_handle_version.pl new file mode 100644 index 0000000..a5f8ad2 --- /dev/null +++ b/maint/Makefile.PL.inc/29_handle_version.pl @@ -0,0 +1,48 @@ + +my $dbic_ver_re = qr/ (\d) \. (\d{2}) (\d{3}) (?: _ (\d{2}) )? /x; # not anchored!!! + +my $version_string = Meta->version; +my $version_value = eval $version_string; + +my ($v_maj, $v_min, $v_point, $v_dev) = $version_string =~ /^$dbic_ver_re$/ + or die sprintf ( + "Invalid version %s (as specified in %s)\nCurrently valid version formats are M.VVPPP or M.VVPPP_DD\n", + $version_string, + Meta->{values}{version_from} || Meta->{values}{all_from} || 'Makefile.PL', + ) +; + +if ($v_maj != 0 or $v_min > 8) { + die "Illegal version $version_string - we are still in the 0.08 cycle\n" +} + + +# all odd releases *after* 0.08200 generate a -TRIAL, no exceptions +Meta->makemaker_args->{DISTVNAME} = Meta->name . "-$version_string-TRIAL" + if ( $v_point > 200 and int($v_point / 100) % 2 ); + + +my $tags = { map { chomp $_; $_ => 1} `git tag` }; +# git may not be available +if (keys %$tags) { + my $shipped_versions; + my $shipped_dev_versions; + + for (keys %$tags) { + if ($_ =~ /^v$dbic_ver_re$/) { + if (defined $4) { + $shipped_dev_versions->{"$1.$2$3$4"} = 1; + } + else { + $shipped_versions->{"$1.$2$3"} = 1; + } + delete $tags->{$_}; + } + } + + die sprintf "Tags in unknown format found: %s\n", join ', ', keys %$tags + if keys %$tags; +} + +# keep the Makefile.PL eval happy +1; diff --git a/maint/Makefile.PL.inc/50_redefine_makefile_flow.pl b/maint/Makefile.PL.inc/50_redefine_makefile_flow.pl new file mode 100644 index 0000000..3813e80 --- /dev/null +++ b/maint/Makefile.PL.inc/50_redefine_makefile_flow.pl @@ -0,0 +1,63 @@ +# Split create_distdir into several subtargets, allowing us to generate +# stuff, inject it into lib/, manifest it, and then clean all of it up +{ + package MY; + sub distdir { + (my $snippet = shift->SUPER::distdir(@_)) =~ s/^create_distdir :/create_distdir_copy_manifested :/; + return <<"EOM"; +$snippet + +create_distdir : clonedir_generate_files clonedir_post_generate_files fresh_manifest create_distdir_copy_manifested clonedir_cleanup_generated_files +\t\$(NOECHO) \$(NOOP) + +clonedir_generate_files : +\t\$(NOECHO) \$(NOOP) + +clonedir_post_generate_files : +\t\$(NOECHO) \$(NOOP) + +clonedir_cleanup_generated_files : +\t\$(NOECHO) \$(NOOP) + +EOM + } +} + +# EU::MM BUG - workaround +# somehow the init_PM of EUMM (in MM_Unix) interprets ResultClass.pod.proto +# as a valid ResultClass.pod. While this has no effect on dist-building +# it royally screws up the local Makefile.PL $TO_INST_PM and friends, +# making it impossible to make/make test from a checkout +# just rip it out here (remember - this is only executed under author mode) +{ + package MY; + sub init_PM { + my $self = shift; + my $rv = $self->SUPER::init_PM(@_); + delete @{$self->{PM}}{qw(lib/DBIx/Class/Manual/ResultClass.pod lib/DBIx/Class/Manual/ResultClass.pod.proto)}; + $rv + } +} + +# make the install (and friends) target a noop - instead of +# doing a perl Makefile.PL && make && make install (which will leave pod +# behind), one ought to assemble a distdir first + +{ + package MY; + sub install { + (my $snippet = shift->SUPER::install(@_)) + =~ s/^( (?: install [^\:]+ | \w+_install \s) \:+ )/$1 block_install_from_checkout/mxg; + return <<"EOM"; +$snippet + +block_install_from_checkout : +\t\$(NOECHO) \$(ECHO) Installation directly from a checkout is not possible. You need to prepare a distdir, enter it, and run the installation from within. +\t\$(NOECHO) \$(FALSE) + +EOM + } +} + +# keep the Makefile.PL eval happy +1; diff --git a/maint/Makefile.PL.inc/51_autogen_README.pl b/maint/Makefile.PL.inc/51_autogen_README.pl deleted file mode 100644 index 28646c5..0000000 --- a/maint/Makefile.PL.inc/51_autogen_README.pl +++ /dev/null @@ -1,22 +0,0 @@ -# Makefile syntax allows adding extra dep-specs for already-existing targets, -# and simply appends them on *LAST*-come *FIRST*-serve basis. -# This allows us to inject extra depenencies for standard EUMM targets - -postamble <<"EOP"; - -.PHONY: dbic_clonedir_cleanup_readme dbic_clonedir_gen_readme - -distdir : dbic_clonedir_cleanup_readme - -create_distdir : dbic_clonedir_gen_readme - -dbic_clonedir_gen_readme : -\tpod2text lib/DBIx/Class.pm > README - -dbic_clonedir_cleanup_readme : -\t\$(RM_F) README - -EOP - -# keep the Makefile.PL eval happy -1; diff --git a/maint/Makefile.PL.inc/51_autohandle_MANIFEST.pl b/maint/Makefile.PL.inc/51_autohandle_MANIFEST.pl new file mode 100644 index 0000000..f12ee30 --- /dev/null +++ b/maint/Makefile.PL.inc/51_autohandle_MANIFEST.pl @@ -0,0 +1,16 @@ +# make sure manifest is deleted and generated anew on distdir +# preparation, and is deleted on realclean + +postamble <<"EOM"; + +fresh_manifest : remove_manifest manifest + +remove_manifest : +\t\$(RM_F) MANIFEST + +realclean :: remove_manifest + +EOM + +# keep the Makefile.PL eval happy +1; diff --git a/maint/Makefile.PL.inc/52_autogen_README.pl b/maint/Makefile.PL.inc/52_autogen_README.pl new file mode 100644 index 0000000..0f4a38c --- /dev/null +++ b/maint/Makefile.PL.inc/52_autogen_README.pl @@ -0,0 +1,23 @@ +# When a long-standing branch is updated a README may still linger around +unlink 'README' if -f 'README'; + +# Makefile syntax allows adding extra dep-specs for already-existing targets, +# and simply appends them on *LAST*-come *FIRST*-serve basis. +# This allows us to inject extra depenencies for standard EUMM targets + +require File::Spec; +my $dir = File::Spec->catdir(qw(maint .Generated_Pod)); +my $fn = File::Spec->catfile($dir, 'README'); + +postamble <<"EOP"; + +clonedir_generate_files : dbic_clonedir_gen_readme + +dbic_clonedir_gen_readme : +\t@{[ $mm_proto->oneliner('mkpath', ['-MExtUtils::Command']) ]} $dir +\tpod2text lib/DBIx/Class.pm > $fn + +EOP + +# keep the Makefile.PL eval happy +1; diff --git a/maint/Makefile.PL.inc/52_inject_dbicadmin_pod.pl b/maint/Makefile.PL.inc/52_inject_dbicadmin_pod.pl deleted file mode 100644 index e9f0980..0000000 --- a/maint/Makefile.PL.inc/52_inject_dbicadmin_pod.pl +++ /dev/null @@ -1,19 +0,0 @@ -# Makefile syntax allows adding extra dep-specs for already-existing targets, -# and simply appends them on *LAST*-come *FIRST*-serve basis. -# This allows us to inject extra depenencies for standard EUMM targets - -postamble <<"EOP"; - -.PHONY: dbic_distdir_dbicadmin_pod_inject - -distdir : dbic_distdir_dbicadmin_pod_inject - -# The pod self-injection code is in fact a hidden option in -# dbicadmin itself, we execute the one in the distdir -dbic_distdir_dbicadmin_pod_inject : -\t\$(ABSPERL) -I\$(DISTVNAME)/lib \$(DISTVNAME)/script/dbicadmin --selfinject-pod - -EOP - -# keep the Makefile.PL eval happy -1; diff --git a/maint/Makefile.PL.inc/53_autogen_optdeps_pod.pl b/maint/Makefile.PL.inc/53_autogen_optdeps_pod.pl deleted file mode 100644 index 7c33931..0000000 --- a/maint/Makefile.PL.inc/53_autogen_optdeps_pod.pl +++ /dev/null @@ -1,21 +0,0 @@ -# generate the pod as both a clone-dir step, and a makefile distdir step -my $ver = Meta->version; - -print "Regenerating Optional/Dependencies.pod\n"; -require DBIx::Class::Optional::Dependencies; -DBIx::Class::Optional::Dependencies->_gen_pod ($ver); - -postamble <<"EOP"; - -.PHONY: dbic_clonedir_gen_optdeps_pod - -create_distdir : dbic_clonedir_gen_optdeps_pod - -dbic_clonedir_gen_optdeps_pod : -\t\$(ABSPERL) -Ilib -MDBIx::Class::Optional::Dependencies -e 'DBIx::Class::Optional::Dependencies->_gen_pod($ver)' - -EOP - - -# keep the Makefile.PL eval happy -1; diff --git a/maint/Makefile.PL.inc/53_autogen_pod.pl b/maint/Makefile.PL.inc/53_autogen_pod.pl new file mode 100644 index 0000000..ec6c1a1 --- /dev/null +++ b/maint/Makefile.PL.inc/53_autogen_pod.pl @@ -0,0 +1,143 @@ +use File::Path(); +use File::Glob(); + +# leftovers in old checkouts +unlink 'lib/DBIx/Class/Optional/Dependencies.pod' + if -f 'lib/DBIx/Class/Optional/Dependencies.pod'; +File::Path::rmtree( File::Glob::bsd_glob('.generated_pod'), { verbose => 0 } ) + if -d '.generated_pod'; + +my $pod_dir = 'maint/.Generated_Pod'; +my $ver = Meta->version; + +# cleanup the generated pod dir (again - kill leftovers from old checkouts) +if (-d $pod_dir) { + File::Path::rmtree( File::Glob::bsd_glob("$pod_dir/*"), { verbose => 0 } ); +} +else { + mkdir $pod_dir or die "Unable to create $pod_dir: $!"; +} + +# generate the OptDeps pod both in the clone-dir and during the makefile distdir +{ + print "Regenerating Optional/Dependencies.pod\n"; + + # this should always succeed - hence no error checking + # if someone breaks OptDeps - travis should catch it + require DBIx::Class::Optional::Dependencies; + DBIx::Class::Optional::Dependencies->_gen_pod ($ver, "$pod_dir/lib"); + + postamble <<"EOP"; + +clonedir_generate_files : dbic_clonedir_gen_optdeps_pod + +dbic_clonedir_gen_optdeps_pod : +\t@{[ + $mm_proto->oneliner("DBIx::Class::Optional::Dependencies->_gen_pod(q($ver), q($pod_dir/lib))", [qw/-Ilib -MDBIx::Class::Optional::Dependencies/]) +]} + +EOP +} + + +# generate the script/dbicadmin pod +{ + print "Regenerating script/dbicadmin.pod\n"; + + # generating it in the root of $pod_dir + # it will *not* be copied over due to not being listed at the top + # of MANIFEST.SKIP - this is a *good* thing + # we only want to ship a script/dbicadmin, with the POD appended + # (see inject_dbicadmin_pod.pl), but still want to spellcheck and + # whatnot the intermediate step + my $pod_fn = "$pod_dir/dbicadmin.pod"; + + # if the author doesn't have the prereqs, don't fail the initial "perl Makefile.pl" step + my $great_success; + { + local @ARGV = ('--documentation-as-pod', $pod_fn); + local *CORE::GLOBAL::exit = sub { $great_success++; die; }; + do 'script/dbicadmin'; + } + if (!$great_success and ($@ || $!) ) { + printf ("FAILED!!! Subsequent `make dist` will fail. %s\n", + $ENV{DBICDIST_DEBUG} + ? 'Full error: ' . ($@ || $!) + : 'Re-run with $ENV{DBICDIST_DEBUG} set for more info' + ); + } + + postamble <<"EOP"; + +clonedir_generate_files : dbic_clonedir_gen_dbicadmin_pod + +dbic_clonedir_gen_dbicadmin_pod : +\t\$(ABSPERLRUN) -Ilib -- script/dbicadmin --documentation-as-pod @{[ $mm_proto->quote_literal($pod_fn) ]} + +EOP +} + + +# generate the inherit pods only during distbuilding phase +# it is too slow to do at regular Makefile.PL +{ + postamble <<"EOP"; + +clonedir_generate_files : dbic_clonedir_gen_inherit_pods + +dbic_clonedir_gen_inherit_pods : +\t\$(ABSPERLRUN) -Ilib maint/gen_pod_inherit + +EOP +} + + +# on some OSes generated files may have an incorrect \n - fix it +# so that the xt tests pass on a fresh checkout (also shipping a +# dist with CRLFs is beyond obnoxious) +if ($^O eq 'MSWin32' or $^O eq 'cygwin') { + { + local $ENV{PERLIO} = 'unix'; + system( $^X, qw( -MExtUtils::Command -e dos2unix -- ), $pod_dir ); + } + + postamble <<"EOP"; + +clonedir_post_generate_files : pod_crlf_fixup + +pod_crlf_fixup : +@{[ $crlf_fixup->($pod_dir) ]} + +EOP +} + +{ + postamble <<"EOP"; + +clonedir_post_generate_files : dbic_clonedir_copy_generated_pod + +dbic_clonedir_copy_generated_pod : +\t\$(RM_F) $pod_dir.packlist +\t@{[ + $mm_proto->oneliner("install([ from_to => {q($pod_dir) => File::Spec->curdir(), write => q($pod_dir.packlist)}, verbose => 0, uninstall_shadows => 0, skip => [] ])", ['-MExtUtils::Install']) +]} + +EOP +} + + +# everything that came from $pod_dir, needs to be removed from the workdir +{ + postamble <<"EOP"; + +clonedir_cleanup_generated_files : dbic_clonedir_cleanup_generated_pod_copies + +dbic_clonedir_cleanup_generated_pod_copies : +\t@{[ $mm_proto->oneliner('chomp && unlink || die', ['-n']) ]} $pod_dir.packlist +\t\$(RM_F) $pod_dir.packlist + +EOP +} + +# keep the Makefile.PL eval happy +1; diff --git a/maint/Makefile.PL.inc/54_autogen_inherited_pod.pl b/maint/Makefile.PL.inc/54_autogen_inherited_pod.pl deleted file mode 100644 index 6b0e3c8..0000000 --- a/maint/Makefile.PL.inc/54_autogen_inherited_pod.pl +++ /dev/null @@ -1,6 +0,0 @@ -# FIXME Disabled due to unsolved issues, ask theorbtwo -#require Module::Install::Pod::Inherit; -#PodInherit(); - -# keep the Makefile.PL eval happy -1; diff --git a/maint/Makefile.PL.inc/56_autogen_testddl.pl b/maint/Makefile.PL.inc/56_autogen_testddl.pl new file mode 100644 index 0000000..a9425d3 --- /dev/null +++ b/maint/Makefile.PL.inc/56_autogen_testddl.pl @@ -0,0 +1,33 @@ +require File::Spec; +my $ddl_fn = File::Spec->catfile(qw(t lib sqlite.sql)); + +# If the author doesn't have the prereqs, we will end up obliterating +# the ddl file, and all tests will fail, therefore don't do anything +# on error +# The EUMM build-stage generation will run unconditionally and +# errors will not be trapped +require DBIx::Class::Optional::Dependencies; +if ( DBIx::Class::Optional::Dependencies->req_ok_for ('deploy') ) { + print "Regenerating t/lib/sqlite.sql\n"; + if (my $out = ` "$^X" -Ilib maint/gen_schema `) { + open (my $fh, '>:unix', $ddl_fn) or die "Unable to open $ddl_fn: $!"; + print $fh $out; + close $fh; + + # if we don't do it some git tools (e.g. gitk) get confused that the + # ddl file is modified, when it clearly isn't + system('git status --porcelain >' . File::Spec->devnull); + } +} + +postamble <<"EOP"; + +clonedir_generate_files : dbic_clonedir_regen_test_ddl + +dbic_clonedir_regen_test_ddl : +\t\$(ABSPERLRUN) -Ilib -- maint/gen_schema > @{[ $mm_proto->quote_literal($ddl_fn) ]} +@{[ $crlf_fixup->($ddl_fn) ]} +EOP + +# keep the Makefile.PL eval happy +1; diff --git a/maint/Makefile.PL.inc/59_autogen_MANIFEST.pl b/maint/Makefile.PL.inc/59_autogen_MANIFEST.pl deleted file mode 100644 index 1dbd861..0000000 --- a/maint/Makefile.PL.inc/59_autogen_MANIFEST.pl +++ /dev/null @@ -1,16 +0,0 @@ -# Makefile syntax allows adding extra dep-specs for already-existing targets, -# and simply appends them on *LAST*-come *FIRST*-serve basis. -# This allows us to inject extra depenencies for standard EUMM targets - -print "Removing MANIFEST, will regenerate on next `make dist(dir)`\n"; -unlink 'MANIFEST'; - -# preamble. so that the manifest target is first, hence executes last -preamble <<"EOP"; - -create_distdir : manifest - -EOP - -# keep the Makefile.PL eval happy -1; diff --git a/maint/Makefile.PL.inc/61_inject_dbicadmin_pod.pl b/maint/Makefile.PL.inc/61_inject_dbicadmin_pod.pl new file mode 100644 index 0000000..218527f --- /dev/null +++ b/maint/Makefile.PL.inc/61_inject_dbicadmin_pod.pl @@ -0,0 +1,22 @@ +# without having the pod in the file itself, perldoc may very +# well show a *different* document, because perl and perldoc +# search @INC differently (crazy right?) +# +# make sure we delete and re-create the file - just an append +# will not do what one expects, because on unixy systems the +# target is symlinked to the original +postamble <<"EOP"; + +create_distdir : dbic_distdir_dbicadmin_pod_inject + +dbic_distdir_dbicadmin_pod_inject : +\t\$(RM_F) \$(DISTVNAME)/script/dbicadmin +\t@{[ $mm_proto->oneliner('cat', ['-MExtUtils::Command']) ]} script/dbicadmin maint/.Generated_Pod/dbicadmin.pod > \$(DISTVNAME)/script/dbicadmin + +# FIXME also on win32 EU::Command::cat() adds crlf even if the +# source files do not contain any :( +@{[ $crlf_fixup->('$(DISTVNAME)/script/dbicadmin') ]} +EOP + +# keep the Makefile.PL eval happy +1; diff --git a/maint/gen_pod_inherit b/maint/gen_pod_inherit new file mode 100755 index 0000000..db0f65a --- /dev/null +++ b/maint/gen_pod_inherit @@ -0,0 +1,78 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +my $lib_dir = 'lib'; +my $pod_dir = 'maint/.Generated_Pod'; + +my $result_metapod_fn = "$lib_dir/DBIx/Class/Manual/ResultClass.pod"; + +die "POD generator must be executed from the dist root\n" + unless -d $lib_dir and -d $pod_dir; + +require File::Copy; +File::Copy::copy( + "$result_metapod_fn.proto", + "$result_metapod_fn", +) or die "Copying ResultClass proto pod ($result_metapod_fn) failed: $!"; + +# cleanup +END { + local ($@, $!, $?); + unlink $result_metapod_fn; +} + +require Pod::Inherit; + +Pod::Inherit->new({ + input_files => $lib_dir, + out_dir => "$pod_dir/lib", + force_permissions => 1, + class_map => { + "DBIx::Class::Relationship::HasMany" => "DBIx::Class::Relationship", + "DBIx::Class::Relationship::HasOne" => "DBIx::Class::Relationship", + "DBIx::Class::Relationship::BelongsTo" => "DBIx::Class::Relationship", + "DBIx::Class::Relationship::ManyToMany" => "DBIx::Class::Relationship", + "DBIx::Class::ResultSourceProxy" => "DBIx::Class::ResultSource", + }, + # skip the deprecated classes that give out *DEPRECATED* warnings + skip_classes => [ qw( + lib/DBIx/Class/Storage/DBI/Sybase/MSSQL.pm + lib/DBIx/Class/Serialize/Storable.pm + lib/DBIx/Class/ResultSetManager.pm + lib/DBIx/Class/InflateColumn/File.pm + lib/DBIx/Class/DB.pm + lib/DBIx/Class/CDBICompat/ + lib/DBIx/Class/CDBICompat.pm + ), + # skip the ::Storage:: family for now + qw( + lib/DBIx/Class/Storage/ + lib/DBIx/Class/Storage.pm + ), + 'lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm', # this one just errors out with: The 'add_attribute' method cannot be called on an immutable instance + 'lib/DBIx/Class/Relationship.pm', # it already documents its own inheritors + 'lib/DBIx/Class/Core.pm', # we actually don't want this populated in favor of redirecting users to the ResultClass docs + 'lib/DBIx/Class/Optional/Dependencies.pm' # the POD is already auto-generated + ], + # these appear everywhere, and are typically lower-level methods not used by the general user + skip_inherits => [ qw/ + DBIx::Class + DBIx::Class::Componentised + Class::C3::Componentised + DBIx::Class::AccessorGroup + Class::Accessor::Grouped + Moose::Object + Exporter + / ], + force_inherits => { + 'DBIx::Class::Manual::ResultClass' => 'DBIx::Class::Core', # this forces the contents of ::Core to be dumped into the POD doc for ::ResultClass + }, + dead_links => '', + method_format => 'L<%m|%c/%m>', + #debug => 1, +})->write_pod; + +# important - write_pod returns undef >.< +1; diff --git a/maint/gen_schema b/maint/gen_schema index e3faa85..9fe1030 100755 --- a/maint/gen_schema +++ b/maint/gen_schema @@ -13,5 +13,9 @@ print scalar ($schema->storage->deployment_statements( 'SQLite', undef, undef, - { producer_args => { no_transaction => 1 } } + { + producer_args => { no_transaction => 1 }, + quote_identifiers => 1, + no_comments => 1, + }, )); diff --git a/maint/travis-ci_scripts/10_before_install.bash b/maint/travis-ci_scripts/10_before_install.bash new file mode 100755 index 0000000..277ac9e --- /dev/null +++ b/maint/travis-ci_scripts/10_before_install.bash @@ -0,0 +1,114 @@ +#!/bin/bash + +source maint/travis-ci_scripts/common.bash +if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi + +if [[ -n "$BREWVER" ]] ; then + # .travis.yml already restricts branches to master, topic/* and smoke/* + # do some extra short-circuiting here + + # when smoking master do not attempt bleadperl (not release-critical) + if [[ "$TRAVIS_PULL_REQUEST" != "false" ]]; then + echo_err "$(tstamp) pull-request smoking with custom perl compilation requested - bailing out" + export SHORT_CIRCUIT_SMOKE=1 + elif [[ "$TRAVIS_BRANCH" = "master" ]] && [[ "$BREWVER" = "blead" ]]; then + echo_err "$(tstamp) master branch is not smoked with bleadperl - bailing out" + export SHORT_CIRCUIT_SMOKE=1 + # on topic/ branches test only with travis perls + elif [[ "$TRAVIS_BRANCH" =~ "topic/" ]]; then + echo_err "$(tstamp) non-smoke branch and custom perl compilation requested - bailing out" + export SHORT_CIRCUIT_SMOKE=1 + fi + + if [[ -n "$SHORT_CIRCUIT_SMOKE" ]]; then + sleep 20 # give the console time to attach, otherwise it hangs + return # this is like an `exit 0` in sourcing + fi +fi + +# different boxes we run on may have different amount of hw threads +# hence why we need to query +# result is 1.5 times the physical threads +export NUMTHREADS=$(( ( $(cut -f 2 -d '-' /sys/devices/system/cpu/online) + 1 ) * 15 / 10 )) + +if [[ "$CLEANTEST" != "true" ]]; then +### apt-get invocation - faster to grab everything at once + # + # FIXME these debconf lines should automate the firebird config but do not :((( + sudo bash -c 'echo -e "firebird2.5-super\tshared/firebird/enabled\tboolean\ttrue" | debconf-set-selections' + sudo bash -c 'echo -e "firebird2.5-super\tshared/firebird/sysdba_password/new_password\tpassword\t123" | debconf-set-selections' + + APT_PACKAGES="memcached firebird2.5-super firebird2.5-dev expect" + run_or_err "Installing packages ($APT_PACKAGES)" "sudo apt-get install --allow-unauthenticated -y $APT_PACKAGES" + +### config memcached + export DBICTEST_MEMCACHED=127.0.0.1:11211 + +### config mysql + run_or_err "Creating MySQL TestDB" "mysql -e 'create database dbic_test;'" + export DBICTEST_MYSQL_DSN='dbi:mysql:database=dbic_test;host=127.0.0.1' + export DBICTEST_MYSQL_USER=root + +### config pg + run_or_err "Creating PostgreSQL TestDB" "psql -c 'create database dbic_test;' -U postgres" + export DBICTEST_PG_DSN='dbi:Pg:database=dbic_test;host=127.0.0.1' + export DBICTEST_PG_USER=postgres + +### conig firebird + # poor man's deb config + EXPECT_FB_SCRIPT=' + spawn dpkg-reconfigure --frontend=text firebird2.5-super + expect "Enable Firebird server?" + send "\177\177\177\177yes\r" + expect "Password for SYSDBA" + send "123\r" + sleep 1 + wait + sleep 1 + ' + # creating testdb + # FIXME - this step still fails from time to time >:((( + # has to do with the FB reconfiguration I suppose + # for now if it fails twice - simply skip FB testing + for i in 1 2 ; do + + run_or_err "Re-configuring Firebird" " + sync + DEBIAN_FRONTEND=text sudo expect -c '$EXPECT_FB_SCRIPT' + sleep 1 + sync + # restart the server for good measure + sudo /etc/init.d/firebird2.5-super stop || true + sleep 1 + sync + sudo /etc/init.d/firebird2.5-super start + sleep 1 + sync + " + + if run_or_err "Creating Firebird TestDB" \ + "echo \"CREATE DATABASE '/var/lib/firebird/2.5/data/dbic_test.fdb';\" | sudo isql-fb -u sysdba -p 123" + then + export DBICTEST_FIREBIRD_DSN=dbi:Firebird:dbname=/var/lib/firebird/2.5/data/dbic_test.fdb + export DBICTEST_FIREBIRD_USER=SYSDBA + export DBICTEST_FIREBIRD_PASS=123 + + export DBICTEST_FIREBIRD_INTERBASE_DSN=dbi:InterBase:dbname=/var/lib/firebird/2.5/data/dbic_test.fdb + export DBICTEST_FIREBIRD_INTERBASE_USER=SYSDBA + export DBICTEST_FIREBIRD_INTERBASE_PASS=123 + + break + fi + + done + +### oracle + # FIXME: todo + #DBICTEST_ORA_DSN=dbi:Oracle:host=localhost;sid=XE + #DBICTEST_ORA_USER=dbic_test + #DBICTEST_ORA_PASS=123 + #DBICTEST_ORA_EXTRAUSER_DSN=dbi:Oracle:host=localhost;sid=XE + #DBICTEST_ORA_EXTRAUSER_USER=dbic_test_extra + #DBICTEST_ORA_EXTRAUSER_PASS=123 + #ORACLE_HOME=/usr/lib/oracle/xe/app/oracle/product/10.2.0/client +fi diff --git a/maint/travis-ci_scripts/20_install.bash b/maint/travis-ci_scripts/20_install.bash new file mode 100755 index 0000000..ace9bc2 --- /dev/null +++ b/maint/travis-ci_scripts/20_install.bash @@ -0,0 +1,38 @@ +#!/bin/bash + +source maint/travis-ci_scripts/common.bash +if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi + +TRAVIS_CPAN_MIRROR=$(echo "$PERL_CPANM_OPT" | grep -oP -- '--mirror\s+\S+' | head -n 1 | cut -d ' ' -f 2) +if ! [[ "$TRAVIS_CPAN_MIRROR" =~ "http://" ]] ; then + echo_err "Unable to extract primary cpan mirror from PERL_CPANM_OPT - something is wrong" + echo_err "PERL_CPANM_OPT: $PERL_CPANM_OPT" + exit 1 +fi + +export PERL_MM_USE_DEFAULT=1 PERL_MM_NONINTERACTIVE=1 PERL_AUTOINSTALL_PREFER_CPAN=1 PERLBREW_CPAN_MIRROR="$TRAVIS_CPAN_MIRROR" + +# Fixup CPANM_OPT to behave more like a traditional cpan client +export PERL_CPANM_OPT="$( echo $PERL_CPANM_OPT | sed 's/--skip-satisfied//' ) --verbose --no-interactive" + +if [[ -n "$BREWVER" ]] ; then + run_or_err "Compiling/installing Perl $BREWVER (without testing, may take up to 5 minutes)" \ + "perlbrew install --as $BREWVER --notest --verbose $BREWOPTS -j $NUMTHREADS $BREWVER" + + # can not do 'perlbrew uss' in the run_or_err subshell above + perlbrew use $BREWVER || \ + ( echo_err -e "Unable to switch to $BREWVER - compillation failed?\n$LASTOUT"; exit 1 ) +fi + +# configure CPAN.pm - older versions go into an endless loop +# when trying to autoconf themselves +CPAN_CFG_SCRIPT=" + require CPAN; + require CPAN::FirstTime; + *CPAN::FirstTime::conf_sites = sub {}; + CPAN::Config->load; + \$CPAN::Config->{urllist} = [qw{ $TRAVIS_CPAN_MIRROR }]; + \$CPAN::Config->{halt_on_failure} = 1; + CPAN::Config->commit; +" +run_or_err "Configuring CPAN.pm" "perl -e '$CPAN_CFG_SCRIPT'" diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash new file mode 100755 index 0000000..24e405a --- /dev/null +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -0,0 +1,173 @@ +#!/bin/bash + +source maint/travis-ci_scripts/common.bash +if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi + +# try Schwern's latest offering on a stock perl and a threaded blead +# can't do this with CLEANTEST=true yet because a lot of our deps fail +# tests left and right under T::B 1.5 +if [[ "$CLEANTEST" != "true" ]] && ( [[ -z "$BREWVER" ]] || [[ "$BREWVER" = "blead" ]] ) ; then + # FIXME - there got to be a way to ask metacpan for this dynamically + TEST_BUILDER_BETA_CPAN_TARBALL="M/MS/MSCHWERN/Test-Simple-1.005000_005.tar.gz" +fi + + +if [[ "$CLEANTEST" = "true" ]]; then + # get the last inc/ off cpan - we will get rid of MI + # soon enough, but till then this will do + # the point is to have a *really* clean perl (the ones + # we build are guaranteed to be clean, without side + # effects from travis preinstalls) + + # trick cpanm into executing true as shell - we just need the find+unpack + run_or_err "Downloading DBIC inc/ from CPAN" \ + "SHELL=/bin/true cpanm --look DBIx::Class" + + mv ~/.cpanm/latest-build/DBIx-Class-*/inc . + + # this should be installable anywhere, regardles of prereqs + if [[ -n "$TEST_BUILDER_BETA_CPAN_TARBALL" ]] ; then + run_or_err "Pre-installing dev-beta of Test::Builder ($TEST_BUILDER_BETA_CPAN_TARBALL)" \ + "cpan $TEST_BUILDER_BETA_CPAN_TARBALL" + fi + + # older perls do not have a CPAN which understands configure_requires + # properly and what is worse a `cpan Foo` run exits with 0 even if some + # modules failed to install + # The first CPAN which is somewhat sane is around 1.94_56 (perl 5.12) + # The problem is that the first sane version also brings a *lot* of + # deps with it, notably things like YAML and HTTP::Tiny + # The goal of CLEANTEST is to have as little extra stuff installed as + # possible, mainly to catch "but X is perl core" mistakes + # So instead we still use our stock (possibly old) CPAN, and add some + # handholding + CPAN_is_sane || \ + run_or_err "Pre-installing ExtUtils::MakeMaker and Module::Build" \ + "cpan ExtUtils::MakeMaker Module::Build" + + if ! perl -MModule::Build -e 1 &> /dev/null ; then + echo_err -e "Module::Build installation failed\n$LASTOUT" + exit 1 + fi + + # DBI has by far the longest test runtime - run less tests + # FIXME horrible horrible hack, need to implement in DBI itself + run_or_err "Downloading latest DBI distdir from CPAN" \ + "SHELL=/bin/true cpanm --look DBI" + cd ~/.cpanm/latest-build/DBI-*/ + perl -p -i -e 's/(create_.+?_tests) => 1/$1 => 0/' Makefile.PL + run_or_err "Pre-installing DBI, but running less tests" "perl Makefile.PL && make && make test && make install" + cd - &>/dev/null + +else + # we will be running all dbic tests - preinstall lots of stuff, run basic tests + # using SQLT and set up whatever databases necessary + export DBICTEST_SQLT_DEPLOY=1 + + # do the preinstall in several passes to minimize amount of cross-deps installing + # multiple times, and to avoid module re-architecture breaking another install + # (e.g. once Carp is upgraded there's no more Carp::Heavy) + # + parallel_installdeps_notest ExtUtils::MakeMaker + parallel_installdeps_notest Carp + parallel_installdeps_notest Module::Build + parallel_installdeps_notest Module::Runtime ExtUtils::Depends File::Spec Data::Dumper + parallel_installdeps_notest Test::Exception LWP + parallel_installdeps_notest Test::Fatal Test::Warn bareword::filehandles + parallel_installdeps_notest namespace::clean Class::XSAccessor MRO::Compat + parallel_installdeps_notest DBD::SQLite Moo Class::Accessor::Grouped + parallel_installdeps_notest Module::Install DateTime::Format::Strptime + parallel_installdeps_notest JSON::DWIW JSON JSON::XS Test::Pod::Coverage Test::EOL + parallel_installdeps_notest MooseX::Types JSON::Any Class::DBI + + if [[ -n "DBICTEST_FIREBIRD_DSN" ]] ; then + # the official version is full of 5.10-isms, but works perfectly fine on 5.8 + # pull in our patched copy + run_or_err "Fetching patched DBD::Firebird" \ + "git clone https://github.com/dbsrgits/perl-dbd-firebird-5.8.git ~/dbd-firebird" + + # the official version is very much outdated and does not compile on 5.14+ + # use this rather updated source tree (needs to go to PAUSE): + # https://github.com/pilcrow/perl-dbd-interbase + run_or_err "Fetching patched DBD::InterBase" \ + "git clone https://github.com/dbsrgits/perl-dbd-interbase ~/dbd-interbase" + + parallel_installdeps_notest ~/dbd-interbase/ ~/dbd-firebird/ + fi + +fi + +# generate the makefile which will have different deps depending on +# the runmode and envvars set above +run_or_err "Configure on current branch" "perl Makefile.PL" + +# install (remaining) dependencies, sometimes with a gentle push +if [[ "$CLEANTEST" = "true" ]]; then + # we may need to prepend some stuff to that list + HARD_DEPS="$(echo $(make listdeps))" + + # this is a fucked CPAN - won't understand configure_requires of + # various pieces we may run into + CPAN_is_sane || HARD_DEPS="ExtUtils::Depends B::Hooks::OP::Check $HARD_DEPS" + +##### TEMPORARY WORKAROUNDS + + # The unicode-in-yaml bug on older cpan clients + # FIXME there got to be a saner way to fix this... + perl -M5.008008 -e 1 &> /dev/null || \ + run_or_err "Installing multidimensional and bareword::filehandles via cpanm" \ + "cpanm multidimensional bareword::filehandles" + + # work around Params::Validate not having a Makefile.PL so really old + # toolchains can not figure out what the prereqs are ;( + # Need to do more research before filing a bug requesting Makefile inclusion + perl -M5.008008 -e 1 &> /dev/null || \ + HARD_DEPS="$(extract_prereqs Params::Validate) $HARD_DEPS" + +##### END TEMPORARY WORKAROUNDS + + run_or_err "Installing/testing dependencies (may take up to 3 minutes): $HARD_DEPS" "cpan $HARD_DEPS" + + # this is a fucked CPAN - save the log as we may need it + CPAN_is_sane || INSTALLDEPS_OUT="$LASTOUT" + +else + # listalldeps is deliberate - will upgrade everything it can find + parallel_installdeps_notest $(make listalldeps) + + if [[ -n "$TEST_BUILDER_BETA_CPAN_TARBALL" ]] ; then + parallel_installdeps_notest $TEST_BUILDER_BETA_CPAN_TARBALL + fi +fi + +echo_err "$(tstamp) Dependency configuration finished" +# this will display list of available versions +perl Makefile.PL + +# make sure we got everything we need +if [[ -n "$(make listdeps)" ]] ; then + echo_err "$(tstamp) Not all deps installed - something went wrong :(" + sleep 1 # without this the echo below confuses the console listener >.< + CPAN_is_sane || echo_err -e "Outdated CPAN.pm used - full logs follows\n$INSTALLDEPS_OUT\n\nSearch for 'NOT OK' in the text above\n\nDeps still missing:" + sleep 3 # without this the above echo confuses the console listener >.< + make listdeps + exit 1 +fi + +# announce what are we running +echo_err " +===================== DEPENDENCY CONFIGURATION COMPLETE ===================== +$(tstamp) Configuration phase seems to have taken $(date -ud "@$SECONDS" '+%H:%M:%S') (@$SECONDS) + += CPUinfo +$(perl -0777 -p -e 's/.+\n\n(?!\z)//s' < /proc/cpuinfo) + += Meminfo +$(free -m -t) + += Environment +$(env | grep -P 'TEST|TRAVIS|PERL|DBIC' | LC_ALL=C sort | cat -v) + += Perl in use +$(perl -V) +=============================================================================" diff --git a/maint/travis-ci_scripts/40_script.bash b/maint/travis-ci_scripts/40_script.bash new file mode 100755 index 0000000..c044507 --- /dev/null +++ b/maint/travis-ci_scripts/40_script.bash @@ -0,0 +1,19 @@ +#!/bin/bash + +source maint/travis-ci_scripts/common.bash +if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi + +export HARNESS_TIMER=1 HARNESS_OPTIONS=c:j$NUMTHREADS + +START_TIME=$SECONDS +if [[ "$CLEANTEST" = "true" ]] ; then + echo_err "$(tstamp) Running tests with plain \`make test\`" + run_or_err "Prepare blib" "make pure_all" + make test +else + PROVECMD="prove -lrswj$NUMTHREADS t xt" + echo_err "$(tstamp) running tests with \`$PROVECMD\`" + $PROVECMD +fi + +echo "$(tstamp) Testing took a total of $(( $SECONDS - $START_TIME ))s" diff --git a/maint/travis-ci_scripts/50_after_failure.bash b/maint/travis-ci_scripts/50_after_failure.bash new file mode 100755 index 0000000..4935763 --- /dev/null +++ b/maint/travis-ci_scripts/50_after_failure.bash @@ -0,0 +1,11 @@ +#!/bin/bash + +# !!! Nothing here will be executed !!! +# The source-line calling this script is commented out in .travis.yml + +source maint/travis-ci_scripts/common.bash +if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi + +echo_err "Nothing to do" + +return 0 diff --git a/maint/travis-ci_scripts/50_after_success.bash b/maint/travis-ci_scripts/50_after_success.bash new file mode 100755 index 0000000..e25d702 --- /dev/null +++ b/maint/travis-ci_scripts/50_after_success.bash @@ -0,0 +1,6 @@ +#!/bin/bash + +source maint/travis-ci_scripts/common.bash +if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi + +[[ "$CLEANTEST" = "true" ]] || run_or_err "Attempt to build a dist with all prereqs present" "make dist" diff --git a/maint/travis-ci_scripts/60_after_script.bash b/maint/travis-ci_scripts/60_after_script.bash new file mode 100755 index 0000000..4935763 --- /dev/null +++ b/maint/travis-ci_scripts/60_after_script.bash @@ -0,0 +1,11 @@ +#!/bin/bash + +# !!! Nothing here will be executed !!! +# The source-line calling this script is commented out in .travis.yml + +source maint/travis-ci_scripts/common.bash +if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi + +echo_err "Nothing to do" + +return 0 diff --git a/maint/travis-ci_scripts/common.bash b/maint/travis-ci_scripts/common.bash new file mode 100755 index 0000000..ab5c294 --- /dev/null +++ b/maint/travis-ci_scripts/common.bash @@ -0,0 +1,70 @@ +#!/bin/bash + +set -e + +echo_err() { echo "$@" 1>&2 ; } + +if [[ "$TRAVIS" != "true" ]] ; then + echo_err "Running this script makes no sense outside of travis-ci" + exit 1 +fi + +tstamp() { echo -n "[$(date '+%H:%M:%S')]" ; } + +run_or_err() { + echo_err -n "$(tstamp) $1 ... " + + LASTEXIT=0 + START_TIME=$SECONDS + LASTOUT=$( bash -c "$2" 2>&1 ) || LASTEXIT=$? + DELTA_TIME=$(( $SECONDS - $START_TIME )) + + if [[ "$LASTEXIT" != "0" ]] ; then + echo_err -e "FAILED !!! (after ${DELTA_TIME}s)\nCommand executed:\n$2\nSTDOUT+STDERR:\n$LASTOUT" + return $LASTEXIT + else + echo_err "done (took ${DELTA_TIME}s)" + fi +} + +extract_prereqs() { + # once --verbose is set, --no-verbose can't disable it + # do this by hand + ORIG_CPANM_OPT="$PERL_CPANM_OPT" + PERL_CPANM_OPT="$( echo $PERL_CPANM_OPT | sed 's/--verbose//' )" + + # hack-hack-hack + LASTEXIT=0 + COMBINED_OUT="$( { stdout="$(cpanm --quiet --scandeps --format tree "$@")" ; } 2>&1; echo "!!!STDERRSTDOUTSEPARATOR!!!$stdout")" \ + || LASTEXIT=$? + + PERL_CPANM_OPT="$ORIG_CPANM_OPT" + + OUT=${COMBINED_OUT#*!!!STDERRSTDOUTSEPARATOR!!!} + ERR=$(grep -v " is up to date." <<< "${COMBINED_OUT%!!!STDERRSTDOUTSEPARATOR!!!*}") + + if [[ "$LASTEXIT" != "0" ]] || [[ -n "$ERR" ]] ; then + echo_err "$(echo -e "Error occured (exit code $LASTEXIT) retrieving dependencies of $@:\n$ERR\n$OUT")" + exit 1 + fi + + # throw away non-children (what was in $@), throw away ascii art, convert to modnames + perl -p -e 's/^[a-z].+//i; s/^[^a-z]+//i; s/\-[^\-]+$/ /; s/\-/::/g' <<< "$OUT" +} + +parallel_installdeps_notest() { + if [[ -z "$@" ]] ; then return; fi + + # flatten list into one string + MODLIST=$(echo "$@") + + # The reason we do things so "non-interactively" is that xargs -P will have the + # latest cpanm instance overwrite the buildlog. There seems to be no way to + # specify a custom buildlog, hence we just collect the verbose output + # and display it in case of failure + run_or_err "Installing (without testing) $MODLIST" \ + "echo $MODLIST | xargs -n 1 -P $NUMTHREADS cpanm --notest --no-man-pages" +} + + +CPAN_is_sane() { perl -MCPAN\ 1.94_56 -e 1 &>/dev/null ; } diff --git a/script/dbicadmin b/script/dbicadmin index 58ef4c8..13c724d 100755 --- a/script/dbicadmin +++ b/script/dbicadmin @@ -34,7 +34,7 @@ my ($opts, $usage) = describe_options( ['Actions'], ["action" => hidden => { one_of => [ ['create' => 'Create version diffs needs preversion'], - ['upgrade' => 'Upgrade the database to the current schema '], + ['upgrade' => 'Upgrade the database to the current schema'], ['install' => 'Install the schema version tables to an existing database'], ['deploy' => 'Deploy the schema to the database'], ['select' => 'Select data from the schema'], @@ -43,7 +43,7 @@ my ($opts, $usage) = describe_options( ['delete' => 'Delete data from the schema'], ['op:s' => 'compatiblity option all of the above can be suppied as --op='], ['help' => 'display this help', { implies => { schema_class => '__dummy__' } } ], - ['selfinject-pod' => 'hidden', { implies => { schema_class => '__dummy__' } } ], + ['documentation-as-pod:s' => 'hidden', { implies => { schema_class => '__dummy__' } } ], ], required => 1 }], ['Arguments'], ["configuration" => hidden => { one_of => [ @@ -68,23 +68,26 @@ my ($opts, $usage) = describe_options( ) ); -if($opts->{selfinject_pod}) { - - die "This is an internal method, do not call!!!\n" - unless $ENV{MAKELEVEL}; - - $usage->synopsis($synopsis_text); - $usage->short_description($short_description); - exec ( - $^X, - qw/-p -0777 -i -e/, - ( - 's/^# auto_pod_begin.*^# auto_pod_end/' - . quotemeta($usage->pod) - . '/ms' - ), - __FILE__ - ); +if(defined (my $fn = $opts->{documentation_as_pod}) ) { + $usage->synopsis($synopsis_text); + $usage->short_description($short_description); + + if ($fn) { + require File::Spec; + require File::Path; + my $dir = File::Spec->catpath( (File::Spec->splitpath($fn))[0,1] ); + File::Path::mkpath([$dir]); + } + + local *STDOUT if $fn; + open (STDOUT, '>', $fn) or die "Unable to open $fn: $!\n" if $fn; + + print STDOUT "\n"; + print STDOUT $usage->pod; + print STDOUT "\n"; + + close STDOUT if $fn; + exit 0; } # FIXME - lowercasing will eventually go away when Getopt::Long::Descriptive is fixed @@ -129,13 +132,6 @@ if ($action eq 'select') { } } +1; __END__ - -# auto_pod_begin -# -# This will be replaced by the actual pod when selfinject-pod is invoked -# -# auto_pod_end - -# vim: et ft=perl diff --git a/t/105view_deps.t b/t/105view_deps.t index 284fb4a..21aa92b 100644 --- a/t/105view_deps.t +++ b/t/105view_deps.t @@ -37,7 +37,7 @@ can_ok( $view, $_ ) for qw/new from deploy_depends_on/; #################### DEPLOY - $schema->deploy( { add_drop_table => 1 } ); + $schema->deploy; #################### DOES ORDERING WORK? @@ -75,7 +75,7 @@ can_ok( $view, $_ ) for qw/new from deploy_depends_on/; #################### DEPLOY2 - warnings_exist { $schema2->deploy( { add_drop_table => 1 } ) } + warnings_exist { $schema2->deploy } [qr/no such table: main.aba_name_artists/], "Deploying the bad schema produces a warning: aba_name_artists was not created."; diff --git a/t/107obj_result_class.t b/t/107obj_result_class.t new file mode 100644 index 0000000..f616bcb --- /dev/null +++ b/t/107obj_result_class.t @@ -0,0 +1,35 @@ +package ResultClassInflator; + +sub new { bless {}, __PACKAGE__ } + +1; + +package main; + +use strict; +use warnings; + +use Test::More tests => 6; +use Test::Exception; +use lib qw(t/lib); +use DBICTest; + +my $schema = DBICTest->init_schema(); + +my $source = $schema->source('CD'); + +lives_ok { + $source->result_class('ResultClassInflator'); + is($source->result_class => 'ResultClassInflator', "result_class gives us back class"); + is($source->get_component_class('result_class') => 'ResultClassInflator', + "and so does get_component_class"); + + } 'Result class still works with class'; +lives_ok { + my $obj = ResultClassInflator->new(); + $source->result_class($obj); + is($source->result_class => $obj, "result_class gives us back obj"); + is($source->get_component_class('result_class') => $obj, "and so does get_component_class"); + } 'Result class works with object'; + +done_testing; diff --git a/t/26dumper.t b/t/26dumper.t index a238085..ade5031 100644 --- a/t/26dumper.t +++ b/t/26dumper.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use Data::Dumper; diff --git a/t/51threadnodb.t b/t/51threadnodb.t index 52cdcd8..9b69fa1 100644 --- a/t/51threadnodb.t +++ b/t/51threadnodb.t @@ -11,11 +11,14 @@ use strict; use warnings; use Test::More; +use lib qw(t/lib); +use DBICTest; + plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' if $] < '5.008005'; -use lib qw(t/lib); -use DBICTest; +plan skip_all => 'Potential problems on Win32 Perl < 5.14 and Variable::Magic - investigation pending' + if $^O eq 'MSWin32' && $] < 5.014 && DBICTest::RunMode->is_plain; # README: If you set the env var to a number greater than 10, # we will use that many children diff --git a/t/52leaks.t b/t/52leaks.t index a5ad085..9a9a570 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -47,7 +47,8 @@ if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) { use lib qw(t/lib); use DBICTest::RunMode; -use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry/; +use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; +use Scalar::Util 'refaddr'; use DBIx::Class; use B 'svref_2object'; BEGIN { @@ -111,6 +112,7 @@ unless (DBICTest::RunMode->is_plain) { require DBI; require DBD::SQLite; require FileHandle; + require Moo; %$weak_registry = (); } @@ -256,9 +258,14 @@ my @compose_ns_classes; leaky_resultset => $rs_bind_circref, leaky_resultset_cond => $cond_rowobj, - leaky_resultset_member => $rs_bind_circref->next, }; + # this needs to fire, even if it can't find anything + # see FIXME below + # we run this only on smokers - trying to establish a pattern + $rs_bind_circref->next + if ( ($ENV{TRAVIS}||'') ne 'true' and DBICTest::RunMode->is_smoker); + require Storable; %$base_collection = ( %$base_collection, @@ -353,9 +360,11 @@ for my $slot (keys %$weak_registry) { # Moo keeps globals around, this is normal delete $weak_registry->{$slot}; } - elsif ($slot =~ /^SQL::Translator/) { - # SQLT is a piece of shit, leaks all over - delete $weak_registry->{$slot}; + elsif ($slot =~ /^SQL::Translator::Generator::DDL::SQLite/) { + # SQLT::Producer::SQLite keeps global generators around for quoted + # and non-quoted DDL, allow one for each quoting style + delete $weak_registry->{$slot} + unless $cleared->{sqlt_ddl_sqlite}->{@{$weak_registry->{$slot}{weakref}->quote_chars}}++; } elsif ($slot =~ /^Hash::Merge/) { # only clear one object of a specific behavior - more would indicate trouble @@ -372,9 +381,6 @@ for my $slot (keys %$weak_registry) { delete $weak_registry->{$slot} unless $cleared->{mk_row_parser_dd_singleton}++; } - elsif (DBIx::Class::_ENV_::INVISIBLE_DOLLAR_AT and $slot =~ /^__TxnScopeGuard__FIXUP__/) { - delete $weak_registry->{$slot} - } elsif ($slot =~ /^DateTime::TimeZone/) { # DT is going through a refactor it seems - let it leak zones for now delete $weak_registry->{$slot}; @@ -414,15 +420,16 @@ for my $moniker ( keys %{DBICTest::Schema->source_registrations || {}} ) { # half of it is in XS no leaktracer sees it, and Devel::FindRef is equally # stumped when trying to trace the origin. The problem is: # -# $cond_object --> result_source --> schema --> storage --> $dbh --> {cached_kids} +# $cond_object --> result_source --> schema --> storage --> $dbh --> {CachedKids} # ^ / # \-------- bound value on prepared/cached STH <-----------/ # -TODO: { - local $TODO = 'Not sure how to fix this yet, an entanglment could be an option'; - my $r = $weak_registry->{'basic leaky_resultset_cond'}{weakref}; - ok(! defined $r, 'We no longer leak!') - or $r->result_source(undef); +{ + local $TODO = 'This fails intermittently - see RT#82942'; + if ( my $r = $weak_registry->{'basic leaky_resultset_cond'}{weakref} ) { + ok(! defined $r, 'Self-referential RS conditions no longer leak!') + or $r->result_source(undef); + } } assert_empty_weakregistry ($weak_registry); diff --git a/t/53lean_startup.t b/t/53lean_startup.t index 30f1d90..248925a 100644 --- a/t/53lean_startup.t +++ b/t/53lean_startup.t @@ -32,14 +32,16 @@ BEGIN { strict warnings + constant + Config + base mro overload Exporter B - locale - + Devel::GlobalDestruction namespace::clean Try::Tiny Context::Preserve diff --git a/t/55namespaces_cleaned.t b/t/55namespaces_cleaned.t index 2205ded..e87cab7 100644 --- a/t/55namespaces_cleaned.t +++ b/t/55namespaces_cleaned.t @@ -79,12 +79,6 @@ my $skip_idx = { map { $_ => 1 } ( # this subclass is expected to inherit whatever crap comes # from the parent 'DBIx::Class::ResultSet::Pager', - - # this is not part of the inheritance tree (plus is a temporary fix anyway) - 'DBIx::Class::GlobalDestruction', - - # Moo does not name its generated methods, fix pending - 'DBIx::Class::Storage::BlockRunner', ) }; my $has_cmop = eval { require Class::MOP }; @@ -115,7 +109,7 @@ for my $mod (@modules) { for my $name (keys %all_method_like) { - next if ( DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN() and $name =~ /^carp(?:_unique|_once)?$/ ); + next if ( DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN and $name =~ /^carp(?:_unique|_once)?$/ ); # overload is a funky thing - it is not cleaned, and its imports are named funny next if $name =~ /^\(/; @@ -123,17 +117,10 @@ for my $mod (@modules) { my $gv = svref_2object($all_method_like{$name})->GV; my $origin = $gv->STASH->NAME; - TODO: { - local $TODO; - if ($name =~ /^__CAG_/) { - $TODO = 'CAG does not clean its BEGIN constants'; - } - - is ($gv->NAME, $name, "Properly named $name method at $origin" . ($origin eq $mod - ? '' - : " (inherited by $mod)" - )); - } + is ($gv->NAME, $name, "Properly named $name method at $origin" . ($origin eq $mod + ? '' + : " (inherited by $mod)" + )); next if $seen->{"${origin}:${name}"}++; @@ -160,7 +147,7 @@ for my $mod (@modules) { } } - next if DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN(); + next if DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN; # some common import names (these should never ever be methods) for my $f (qw/carp carp_once carp_unique croak confess cluck try catch finally/) { diff --git a/t/60core.t b/t/60core.t index edf5758..f21355c 100644 --- a/t/60core.t +++ b/t/60core.t @@ -553,12 +553,21 @@ lives_ok (sub { my $newlink = $newbook->link}, "stringify to false value doesn't ); } +# test to make sure that calling ->new() on a resultset object gives +# us a row object +{ + my $new_artist = $schema->resultset('Artist')->new({}); + isa_ok( $new_artist, 'DBIx::Class::Row', '$rs->new gives a row object' ); +} + + # make sure we got rid of the compat shims SKIP: { - skip "Remove in 0.082", 3 if $DBIx::Class::VERSION < 0.082; + my $remove_version = 0.083; + skip "Remove in $remove_version", 3 if $DBIx::Class::VERSION < $remove_version; for (qw/compare_relationship_keys pk_depends_on resolve_condition/) { - ok (! DBIx::Class::ResultSource->can ($_), "$_ no longer provided by DBIx::Class::ResultSource"); + ok (! DBIx::Class::ResultSource->can ($_), "$_ no longer provided by DBIx::Class::ResultSource, removed before $remove_version"); } } diff --git a/t/71mysql.t b/t/71mysql.t index c656a7f..de1e2fd 100644 --- a/t/71mysql.t +++ b/t/71mysql.t @@ -17,12 +17,10 @@ plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missin my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}; -#warn "$dsn $user $pass"; - plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test' unless ($dsn && $user); -my $schema = DBICTest::Schema->connect($dsn, $user, $pass); +my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { quote_names => 1 }); my $dbh = $schema->storage->dbh; @@ -206,10 +204,10 @@ lives_ok { $cd->set_producers ([ $producer ]) } 'set_relationship doesnt die'; is_same_sql_bind ( $rs->as_query, '( - SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, - artist.artistid, artist.name, artist.rank, artist.charfield - FROM cd me - INNER JOIN artist artist ON artist.artistid = me.artist + SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year`, `me`.`genreid`, `me`.`single_track`, + `artist`.`artistid`, `artist`.`name`, `artist`.`rank`, `artist`.`charfield` + FROM cd `me` + INNER JOIN `artist` `artist` ON `artist`.`artistid` = `me`.`artist` )', [], 'overriden default join type works', @@ -229,10 +227,10 @@ lives_ok { $cd->set_producers ([ $producer ]) } 'set_relationship doesnt die'; is_same_sql_bind ( $cdsrc->resultset->search({}, { prefetch => 'straight_artist' })->as_query, '( - SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, - straight_artist.artistid, straight_artist.name, straight_artist.rank, straight_artist.charfield - FROM cd me - STRAIGHT_JOIN artist straight_artist ON straight_artist.artistid = me.artist + SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year`, `me`.`genreid`, `me`.`single_track`, + `straight_artist`.`artistid`, `straight_artist`.`name`, `straight_artist`.`rank`, `straight_artist`.`charfield` + FROM cd `me` + STRAIGHT_JOIN `artist` `straight_artist` ON `straight_artist`.`artistid` = `me`.`artist` )', [], 'straight joins correctly supported for mysql' @@ -296,6 +294,47 @@ NULLINSEARCH: { }, 'count on grouped columns with the same name does not throw'); } +# a more contrived^Wcomplicated self-referential double-subquery test +{ + my $rs = $schema->resultset('Artist')->search({ name => { -like => 'baby_%' } }); + + $rs->populate([map { [$_] } ('name', map { "baby_$_" } (1..10) ) ]); + + my ($count_sql, @count_bind) = @${$rs->count_rs->as_query}; + + my $complex_rs = $schema->resultset('Artist')->search( + { artistid => { + -in => $rs->get_column('artistid') + ->as_query + } }, + ); + + $complex_rs->update({ name => \[ "CONCAT( `name`, '_bell_out_of_', $count_sql )", @count_bind ] }); + + for (1..10) { + is ( + $schema->resultset('Artist')->search({ name => "baby_${_}_bell_out_of_10" })->count, + 1, + "Correctly updated babybell $_", + ); + } + + my $ac = $schema->resultset('Artist')->count_rs; + my $old_count = $ac->next; + $ac->reset; + + my $orig_debug = $schema->storage->debug; + $schema->storage->debug(1); + my $query_count = 0; + $schema->storage->debugcb(sub { $query_count++ }); + $complex_rs->delete; + $schema->storage->debugcb(undef); + $schema->storage->debug($orig_debug); + + is ($query_count, 1, 'One delete query fired'); + is ($old_count - $ac->next, 10, '10 Artists correctly deleted'); +} + ZEROINSEARCH: { my $cds_per_year = { 2001 => 2, @@ -386,9 +425,9 @@ ZEROINSEARCH: { # kill our $dbh $schema_autorecon->storage->_dbh(undef); - TODO: { + { local $TODO = "Perl $] is known to leak like a sieve" - if DBIx::Class::_ENV_::PEEPEENESS(); + if DBIx::Class::_ENV_::PEEPEENESS; ok (! defined $orig_dbh, 'Parent $dbh handle is gone'); } @@ -410,9 +449,9 @@ ZEROINSEARCH: { # try to do something dbic-esque $rs->create({ name => "Hardcore Forker $$" }); - TODO: { + { local $TODO = "Perl $] is known to leak like a sieve" - if DBIx::Class::_ENV_::PEEPEENESS(); + if DBIx::Class::_ENV_::PEEPEENESS; ok (! defined $orig_dbh, 'DBIC operation triggered reconnect - old $dbh is gone'); } diff --git a/t/72pg.t b/t/72pg.t index 5e4ec84..44b723c 100644 --- a/t/72pg.t +++ b/t/72pg.t @@ -287,7 +287,7 @@ for my $use_insert_returning ($test_server_supports_insert_returning } 'find by arrayref (equal)'; # test inferred condition for creation - TODO: for my $cond ( + for my $cond ( { -value => [3,4] }, \[ '= ?' => [arrayfield => [3, 4]] ], ) { diff --git a/t/73oracle.t b/t/73oracle.t index 01331b1..fc324c5 100644 --- a/t/73oracle.t +++ b/t/73oracle.t @@ -91,6 +91,13 @@ is ( 'insert returning capability guessed correctly' ); +isa_ok (DBICTest::Schema->connect($dsn, $user, $pass)->storage->sql_maker, 'DBIx::Class::SQLMaker::Oracle'); + +# see if determining a driver with bad credentials throws propely +throws_ok { + DBICTest::Schema->connect($dsn, "BORKED BORKED USER $user", $pass)->storage->sql_maker; +} qr/DBI Connection failed/; + ########## # the recyclebin (new for 10g) sometimes comes in the way my $on_connect_sql = $v >= 10 ? ["ALTER SESSION SET recyclebin = OFF"] : []; @@ -423,13 +430,12 @@ sub _run_tests { ); # test complex join (exercise orajoins) - lives_ok { - my @hri = $schema->resultset('CD')->search( + lives_ok { is_deeply ( + $schema->resultset('CD')->search( { 'artist.name' => 'pop_art_1', 'me.cdid' => { '!=', 999} }, { join => 'artist', prefetch => 'tracks', rows => 4, order_by => 'tracks.trackid' } - )->hri_dump->all; - - my $expect = [{ + )->all_hri, + [{ artist => 1, cdid => 1, genreid => undef, @@ -454,15 +460,9 @@ sub _run_tests { }, ], year => 2003 - }]; - - is_deeply ( - \@hri, - $expect, - 'Correct set of data prefetched', - ); - - } 'complex prefetch ok'; + }], + 'Correct set of data prefetched', + ) } 'complex prefetch ok'; # test sequence detection from a different schema SKIP: { @@ -479,7 +479,7 @@ sub _run_tests { # http://download.oracle.com/docs/cd/A87860_01/doc/server.817/a76961/ch294.htm#993 # Oracle Database Reference 10g Release 2 (10.2) # http://download.oracle.com/docs/cd/B19306_01/server.102/b14237/statviews_2107.htm#sthref1297 - local $TODO = "On Oracle8i all_triggers view is empty, i don't yet know why..." + todo_skip "On Oracle8i all_triggers view is empty, i don't yet know why...", 1 if $schema->storage->_server_info->{normalized_dbms_version} < 9; my $schema2 = $schema->connect($dsn2, $user2, $pass2, $opt); diff --git a/t/73oracle_blob.t b/t/73oracle_blob.t index 3965ea3..ae5a359 100644 --- a/t/73oracle_blob.t +++ b/t/73oracle_blob.t @@ -56,7 +56,6 @@ for my $opt (@tryopt) { sub _run_blob_tests { SKIP: { -TODO: { my ($schema, $opt) = @_; my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) ); $binstr{'large'} = $binstr{'small'} x 1024; @@ -107,7 +106,7 @@ TODO: { ok (try { $objs[0]->blob }||'' eq "blob:$str", 'blob inserted/retrieved correctly'); ok (try { $objs[0]->clob }||'' eq "clob:$str", 'clob inserted/retrieved correctly'); - TODO: { + { local $TODO = '-like comparison on blobs not tested before ora 10 (fails on 8i)' if $schema->storage->_server_info->{normalized_dbms_version} < 10; @@ -157,7 +156,7 @@ TODO: { } $schema->storage->debug ($orig_debug); -}} +} do_clean ($dbh); } diff --git a/t/745db2.t b/t/745db2.t index 12e7045..9123330 100644 --- a/t/745db2.t +++ b/t/745db2.t @@ -90,7 +90,7 @@ is( $lim->count, 2, 'ROWS+OFFSET count ok' ); is( $lim->all, 2, 'Number of ->all objects matches count' ); # Limit with select-lock -TODO: { +{ local $TODO = "Seems we can't SELECT ... FOR ... on subqueries"; lives_ok { $schema->txn_do (sub { diff --git a/t/746mssql.t b/t/746mssql.t index c494be8..b822138 100644 --- a/t/746mssql.t +++ b/t/746mssql.t @@ -251,7 +251,7 @@ SQL my $test_type = "Dialect:$dialect Quoted:$quoted"; # basic limit support - TODO: { + { my $art_rs = $schema->resultset ('Artist'); $art_rs->delete; $art_rs->create({ name => 'Artist ' . $_ }) for (1..6); @@ -398,7 +398,7 @@ SQL is ($owners->page(1)->count, 3, "$test_type: has-many prefetch returns correct count"); is ($owners->page(3)->count, 2, "$test_type: has-many prefetch returns correct count"); - TODO: { + { local $TODO = "Top-limit does not work when your limit ends up past the resultset" if $dialect eq 'Top'; is ($owners->page(3)->all, 2, "$test_type: has_many prefetch returns correct number of rows"); @@ -452,7 +452,7 @@ SQL is ($books->page(1)->count, 2, "$test_type: Prefetched grouped search returns correct count"); is ($books->page(2)->count, 1, "$test_type: Prefetched grouped search returns correct count"); - TODO: { + { local $TODO = "Top-limit does not work when your limit ends up past the resultset" if $dialect eq 'Top'; is ($books->page(2)->all, 1, "$test_type: Prefetched grouped search returns correct number of rows"); @@ -522,7 +522,7 @@ CREATE TABLE money_test ( SQL }); - TODO: { + { my $freetds_and_dynamic_cursors = 1 if $opts_name eq 'use_dynamic_cursors' && $schema->storage->_using_freetds; diff --git a/t/746sybase.t b/t/746sybase.t index abf6551..cb6849a 100644 --- a/t/746sybase.t +++ b/t/746sybase.t @@ -533,7 +533,7 @@ SQL } # test insert in an outer transaction when there's an active cursor - TODO: { + { local $TODO = 'this should work once we have eager cursors'; # clear state, or we get a deadlock on $row->delete diff --git a/t/74mssql.t b/t/74mssql.t index 2ec7fa5..243ae0e 100644 --- a/t/74mssql.t +++ b/t/74mssql.t @@ -201,13 +201,14 @@ SQL $rs->delete; } - # test transaction handling on a disconnected handle my $wrappers = { no_transaction => sub { shift->() }, txn_do => sub { my $code = shift; $schema->txn_do(sub { $code->() } ) }, txn_begin => sub { $schema->txn_begin; shift->(); $schema->txn_commit }, txn_guard => sub { my $g = $schema->txn_scope_guard; shift->(); $g->commit }, }; + + # test transaction handling on a disconnected handle for my $wrapper (keys %$wrappers) { $rs->delete; @@ -223,45 +224,40 @@ SQL } "transaction on disconnected handle with $wrapper wrapper"; } - TODO: { + # test transaction handling on a disconnected handle with multiple active + # statements + for my $wrapper (keys %$wrappers) { + $schema->storage->disconnect; + $rs->delete; + $rs->reset; + $rs->create({ amount => 1000 + $_ }) for (1..3); + + my $artist_rs = $schema->resultset('Artist')->search({ + name => { -like => 'Artist %' } + });; + + $rs->next; + + my $map = [ ['Artist 1', '1002.00'], ['Artist 2', '1003.00'] ]; + + weaken(my $a_rs_cp = $artist_rs); + local $TODO = 'Transaction handling with multiple active statements will ' - .'need eager cursor support.'; - - # test transaction handling on a disconnected handle with multiple active - # statements - my $wrappers = { - no_transaction => sub { shift->() }, - txn_do => sub { my $code = shift; $schema->txn_do(sub { $code->() } ) }, - txn_begin => sub { $schema->txn_begin; shift->(); $schema->txn_commit }, - txn_guard => sub { my $g = $schema->txn_scope_guard; shift->(); $g->commit }, - }; - for my $wrapper (keys %$wrappers) { - $rs->reset; - $rs->delete; - $rs->create({ amount => 1000 + $_ }) for (1..3); - - my $artist_rs = $schema->resultset('Artist')->search({ - name => { -like => 'Artist %' } - });; - - $rs->next; - - my $map = [ ['Artist 1', '1002.00'], ['Artist 2', '1003.00'] ]; - - weaken(my $a_rs_cp = $artist_rs); - - lives_and { - my @results; - $wrappers->{$wrapper}->( sub { - while (my $money = $rs_cp->next) { - my $artist = $a_rs_cp->next; - push @results, [ $artist->name, $money->amount ]; - }; - }); - - is_deeply \@results, $map; - } "transactions with multiple active statement with $wrapper wrapper"; - } + .'need eager cursor support.' + unless $wrapper eq 'no_transaction'; + + lives_and { + my @results; + + $wrappers->{$wrapper}->( sub { + while (my $money = $rs_cp->next) { + my $artist = $a_rs_cp->next; + push @results, [ $artist->name, $money->amount ]; + }; + }); + + is_deeply \@results, $map; + } "transactions with multiple active statement with $wrapper wrapper"; } # test RNO detection when version detection fails diff --git a/t/750firebird.t b/t/750firebird.t index 32eb154..aef3fcf 100644 --- a/t/750firebird.t +++ b/t/750firebird.t @@ -42,6 +42,8 @@ for my $prefix (keys %$env2optdep) { SKIP: { next unless $dsn; + note "Testing with ${prefix}_DSN"; + skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1) unless DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix}); @@ -125,6 +127,7 @@ EOF # test savepoints throws_ok { $schema->txn_do(sub { + my ($schema, $ars) = @_; eval { $schema->txn_do(sub { $ars->create({ name => 'in_savepoint' }); @@ -135,7 +138,7 @@ EOF 'savepoint rolled back'); $ars->create({ name => 'in_outer_txn' }); die "rolling back outer txn"; - }); + }, $schema, $ars); } qr/rolling back outer txn/, 'correct exception for rollback'; diff --git a/t/752sqlite.t b/t/752sqlite.t index 1446128..1895a9f 100644 --- a/t/752sqlite.t +++ b/t/752sqlite.t @@ -4,6 +4,7 @@ use warnings; use Test::More; use Test::Exception; use Test::Warn; +use Time::HiRes 'time'; use Config; use lib qw(t/lib); @@ -43,6 +44,78 @@ use DBICTest; 'rollback from inner transaction'; } +# check that we work somewhat OK with braindead SQLite transaction handling +# +# As per https://metacpan.org/source/ADAMK/DBD-SQLite-1.37/lib/DBD/SQLite.pm#L921 +# SQLite does *not* try to synchronize + +for my $prefix_comment (qw/Begin_only Commit_only Begin_and_Commit/) { + note "Testing with comment prefixes on $prefix_comment"; + + # FIXME warning won't help us for the time being + # perhaps when (if ever) DBD::SQLite gets fixed, + # we can do something extra here + local $SIG{__WARN__} = sub { warn @_ if $_[0] !~ /Internal transaction state .+? does not seem to match/ } + unless $ENV{TEST_VERBOSE}; + + my ($c_begin, $c_commit) = map { $prefix_comment =~ $_ ? 1 : 0 } (qr/Begin/, qr/Commit/); + + my $schema = DBICTest->init_schema( no_deploy => 1 ); + my $ars = $schema->resultset('Artist'); + + ok (! $schema->storage->connected, 'No connection yet'); + + $schema->storage->dbh->do(<<'DDL'); +CREATE TABLE artist ( + artistid INTEGER PRIMARY KEY NOT NULL, + name varchar(100), + rank integer DEFAULT 13, + charfield char(10) NULL +); +DDL + + my $artist = $ars->create({ name => 'Artist_' . time() }); + is ($ars->count, 1, 'Inserted artist ' . $artist->name); + + ok ($schema->storage->connected, 'Connected'); + ok ($schema->storage->_dbh->{AutoCommit}, 'DBD not in txn yet'); + + $schema->storage->dbh->do(join "\n", + $c_begin ? '-- comment' : (), + 'BEGIN TRANSACTION' + ); + ok ($schema->storage->connected, 'Still connected'); + { + local $TODO = 'SQLite is retarded wrt detecting BEGIN' if $c_begin; + ok (! $schema->storage->_dbh->{AutoCommit}, "DBD aware of txn begin with comments on $prefix_comment"); + } + + $schema->storage->dbh->do(join "\n", + $c_commit ? '-- comment' : (), + 'COMMIT' + ); + ok ($schema->storage->connected, 'Still connected'); + { + local $TODO = 'SQLite is retarded wrt detecting COMMIT' if $c_commit and ! $c_begin; + ok ($schema->storage->_dbh->{AutoCommit}, "DBD aware txn ended with comments on $prefix_comment"); + } + + is ($ars->count, 1, 'Inserted artists still there'); + + { + # this never worked in the 1st place + local $TODO = 'SQLite is retarded wrt detecting COMMIT' if ! $c_begin and $c_commit; + + # odd argument passing, because such nested crefs leak on 5.8 + lives_ok { + $schema->storage->txn_do (sub { + ok ($_[0]->find({ name => $_[1] }), "Artist still where we left it after cycle with comments on $prefix_comment"); + }, $ars, $artist->name ); + } "Succesfull transaction with comments on $prefix_comment"; + } +} + + my $schema = DBICTest->init_schema(); # make sure the side-effects of RT#67581 do not result in data loss @@ -68,28 +141,28 @@ $schema->storage->dbh_do(sub { # test upper/lower boundaries for sqlite and some values inbetween # range is -(2**63) .. 2**63 - 1 -for my $bi (qw/ - -9223372036854775808 - -9223372036854775807 - -8694837494948124658 - -6848440844435891639 - -5664812265578554454 - -5380388020020483213 - -2564279463598428141 - 2442753333597784273 - 4790993557925631491 - 6773854980030157393 - 7627910776496326154 - 8297530189347439311 - 9223372036854775806 - 9223372036854775807 -/) { - $row = $schema->resultset('BigIntArtist')->create({ bigint => $bi }); - is ($row->bigint, $bi, "value in object correct ($bi)"); - - TODO: { - local $TODO = 'This perl does not seem to have 64bit int support - DBI roundtrip of large int will fail' - unless $Config{ivsize} >= 8; +SKIP: { + skip 'This perl does not seem to have 64bit int support - DBI roundtrip of large int will fail with DBD::SQLite < 1.37', 1 + if ($Config{ivsize} < 8 and ! eval { DBD::SQLite->VERSION(1.37); 1 }); + + for my $bi (qw/ + -9223372036854775808 + -9223372036854775807 + -8694837494948124658 + -6848440844435891639 + -5664812265578554454 + -5380388020020483213 + -2564279463598428141 + 2442753333597784273 + 4790993557925631491 + 6773854980030157393 + 7627910776496326154 + 8297530189347439311 + 9223372036854775806 + 9223372036854775807 + /) { + $row = $schema->resultset('BigIntArtist')->create({ bigint => $bi }); + is ($row->bigint, $bi, "value in object correct ($bi)"); $row->discard_changes; is ($row->bigint, $bi, "value in database correct ($bi)"); diff --git a/t/85utf8.t b/t/85utf8.t index af6dedf..ea630a2 100644 --- a/t/85utf8.t +++ b/t/85utf8.t @@ -110,7 +110,7 @@ $storage->debug ($orig_debug); # bind values are always alphabetically ordered by column, thus [1] # the single quotes are an artefact of the debug-system -TODO: { +{ local $TODO = "This has been broken since rev 1191, Mar 2006"; is ($bind[1], "'$bytestream_title'", 'INSERT: raw bytes sent to the database'); } @@ -174,7 +174,7 @@ $cd->update ({ title => $utf8_title }); $cd->title('something_else'); ok( $cd->is_column_changed('title'), 'column is dirty after setting to something completely different'); -TODO: { +{ local $TODO = 'There is currently no way to propagate aliases to inflate_result()'; $cd = $schema->resultset('CD')->find ({ title => $utf8_title }, { select => 'title', as => 'name' }); ok (utf8::is_utf8( $cd->get_column ('name') ), 'utf8 flag propagates via as'); diff --git a/t/admin/10script.t b/t/admin/10script.t index 575e3a6..9f4ab90 100644 --- a/t/admin/10script.t +++ b/t/admin/10script.t @@ -4,15 +4,22 @@ use warnings; use Test::More; use Config; +use File::Spec; use lib qw(t/lib); use DBICTest; BEGIN { - require DBIx::Class; - plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin_script') - unless DBIx::Class::Optional::Dependencies->req_ok_for('admin_script'); + require DBIx::Class; + plan skip_all => 'Test needs ' . + DBIx::Class::Optional::Dependencies->req_missing_for('test_admin_script') + unless DBIx::Class::Optional::Dependencies->req_ok_for('test_admin_script'); + + # just in case the user env has stuff in it + delete $ENV{JSON_ANY_ORDER}; } +use JSON::Any; + $ENV{PATH} = ''; $ENV{PERL5LIB} = join ($Config{path_sep}, @INC); @@ -39,7 +46,7 @@ for my $js (@json_backends) { SKIP: { skip ("JSON backend $js is not available, skip testing", 1) if $@; - $ENV{JSON_ANY_ORDER} = $js; + local $ENV{JSON_ANY_ORDER} = $js; eval { test_dbicadmin () }; diag $@ if $@; } @@ -65,11 +72,11 @@ sub test_dbicadmin { test_exec( default_args(), qw|--op=insert --set={"name":"Aran"}| ); SKIP: { - skip ("MSWin32 doesn't support -| either", 1) if $^O eq 'MSWin32'; + skip ("MSWin32 doesn't support -|", 1) if $^O eq 'MSWin32'; my ($perl) = $^X =~ /(.*)/; - open(my $fh, "-|", ( $perl, 'script/dbicadmin', default_args(), qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!; + open(my $fh, "-|", ( $perl, '-MDBICTest::RunMode', 'script/dbicadmin', default_args(), qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!; my $data = do { local $/; <$fh> }; close($fh); if (!ok( ($data=~/Aran.*Trout/s), "$ENV{JSON_ANY_ORDER}: select with attrs" )) { @@ -82,31 +89,29 @@ sub test_dbicadmin { } sub default_args { - my $dbname = DBICTest->_sqlite_dbfilename; + my $dsn = JSON::Any->encode([ + 'dbi:SQLite:dbname=' . DBICTest->_sqlite_dbfilename, + '', + '', + { AutoCommit => 1 }, + ]); + return ( qw|--quiet --schema=DBICTest::Schema --class=Employee|, - qq|--connect=["dbi:SQLite:dbname=$dbname","","",{"AutoCommit":1}]|, + qq|--connect=$dsn|, qw|--force -I testincludenoniterference|, ); } -# Why do we need this crap? Apparently MSWin32 can not pass through quotes properly -# (sometimes it will and sometimes not, depending on what compiler was used to build -# perl). So we go the extra mile to escape all the quotes. We can't also use ' instead -# of ", because JSON::XS (proudly) does not support "malformed JSON" as the author -# calls it. Bleh. -# sub test_exec { my ($perl) = $^X =~ /(.*)/; - my @args = ('script/dbicadmin', @_); + my @args = ($perl, '-MDBICTest::RunMode', File::Spec->catfile(qw(script dbicadmin)), @_); - if ( $^O eq 'MSWin32' ) { - $perl = qq|"$perl"|; # execution will fail if $^X contains paths - for (@args) { - $_ =~ s/"/\\"/g; - } + if ($^O eq 'MSWin32') { + require Win32::ShellQuote; # included in test optdeps + @args = Win32::ShellQuote::quote_system_list(@args); } - system ($perl, @args); + system @args; } diff --git a/t/cdbi/01-columns.t b/t/cdbi/01-columns.t index 88b8189..275ed4a 100644 --- a/t/cdbi/01-columns.t +++ b/t/cdbi/01-columns.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/02-Film.t b/t/cdbi/02-Film.t index 0885f69..fe4a691 100644 --- a/t/cdbi/02-Film.t +++ b/t/cdbi/02-Film.t @@ -1,4 +1,6 @@ use strict; +use warnings; + use Test::More; use Scalar::Util 'refaddr'; use namespace::clean; diff --git a/t/cdbi/03-subclassing.t b/t/cdbi/03-subclassing.t index 9bc77e8..767b341 100644 --- a/t/cdbi/03-subclassing.t +++ b/t/cdbi/03-subclassing.t @@ -1,4 +1,6 @@ use strict; +use warnings; + use Test::More; #---------------------------------------------------------------------- diff --git a/t/cdbi/06-hasa.t b/t/cdbi/06-hasa.t index ef49c14..255383b 100644 --- a/t/cdbi/06-hasa.t +++ b/t/cdbi/06-hasa.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; @YA::Film::ISA = 'Film'; diff --git a/t/cdbi/08-inheritcols.t b/t/cdbi/08-inheritcols.t index 93b1bd8..5550e59 100644 --- a/t/cdbi/08-inheritcols.t +++ b/t/cdbi/08-inheritcols.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/09-has_many.t b/t/cdbi/09-has_many.t index 7b2a336..89a59a5 100644 --- a/t/cdbi/09-has_many.t +++ b/t/cdbi/09-has_many.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; @@ -45,7 +46,7 @@ eval { my $pj = Film->add_to_actors(\%pj_data) }; like $@, qr/class/, "add_to_actors must be object method"; eval { my $pj = $btaste->add_to_actors(%pj_data) }; -like $@, qr/needs/, "add_to_actors takes hash"; +like $@, qr/expects a hashref/, "add_to_actors takes hash"; ok( my $pj = $btaste->add_to_actors( diff --git a/t/cdbi/11-triggers.t b/t/cdbi/11-triggers.t index 40ba0bd..c944248 100644 --- a/t/cdbi/11-triggers.t +++ b/t/cdbi/11-triggers.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/12-filter.t b/t/cdbi/12-filter.t index 928bc70..9a715ed 100644 --- a/t/cdbi/12-filter.t +++ b/t/cdbi/12-filter.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/13-constraint.t b/t/cdbi/13-constraint.t index 3254196..4191fe5 100644 --- a/t/cdbi/13-constraint.t +++ b/t/cdbi/13-constraint.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/14-might_have.t b/t/cdbi/14-might_have.t index d79a746..73318ac 100644 --- a/t/cdbi/14-might_have.t +++ b/t/cdbi/14-might_have.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/15-accessor.t b/t/cdbi/15-accessor.t index 574292d..267916d 100644 --- a/t/cdbi/15-accessor.t +++ b/t/cdbi/15-accessor.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; INIT { @@ -89,13 +90,14 @@ eval { }; is $@, '', "No errors"; -TODO: { local $TODO = 'TODOifying failing tests, waiting for Schwern'; ok (1, 'remove me'); eval { my $data = { %$data }; $data->{NumExplodingSheep} = 3; ok my $bt = Film->find_or_create($data), "find_or_create Modified accessor - create with column name"; isa_ok $bt, "Film"; + + local $TODO = 'TODOifying failing tests, waiting for Schwern'; is $bt->sheep, 3, 'sheep bursting violently'; }; is $@, '', "No errors"; @@ -106,6 +108,8 @@ eval { ok my $bt = Film->find_or_create($data), "find_or_create Modified accessor - create with accessor"; isa_ok $bt, "Film"; + + local $TODO = 'TODOifying failing tests, waiting for Schwern'; is $bt->sheep, 4, 'sheep bursting violently'; }; is $@, '', "No errors"; @@ -114,8 +118,9 @@ eval { my @film = Film->search({ sheep => 1 }); is @film, 2, "Can search with modified accessor"; }; -is $@, '', "No errors"; - +{ + local $TODO = 'TODOifying failing tests, waiting for Schwern'; + is $@, '', "No errors"; } { diff --git a/t/cdbi/16-reserved.t b/t/cdbi/16-reserved.t index 380c819..e54d0ae 100644 --- a/t/cdbi/16-reserved.t +++ b/t/cdbi/16-reserved.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/18-has_a.t b/t/cdbi/18-has_a.t index 5a8ee2a..1dacd6c 100644 --- a/t/cdbi/18-has_a.t +++ b/t/cdbi/18-has_a.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/19-set_sql.t b/t/cdbi/19-set_sql.t index 85242ed..41040af 100644 --- a/t/cdbi/19-set_sql.t +++ b/t/cdbi/19-set_sql.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/21-iterator.t b/t/cdbi/21-iterator.t index d4f397e..f49bf68 100644 --- a/t/cdbi/21-iterator.t +++ b/t/cdbi/21-iterator.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/22-deflate_order.t b/t/cdbi/22-deflate_order.t index a318850..d4e9935 100644 --- a/t/cdbi/22-deflate_order.t +++ b/t/cdbi/22-deflate_order.t @@ -1,4 +1,5 @@ $| = 1; +use warnings; use strict; use Test::More; diff --git a/t/cdbi/22-self_referential.t b/t/cdbi/22-self_referential.t index 6a99acd..1538ef4 100644 --- a/t/cdbi/22-self_referential.t +++ b/t/cdbi/22-self_referential.t @@ -1,6 +1,6 @@ -use Test::More; - use strict; +use warnings; +use Test::More; use lib 't/cdbi/testlib'; use Actor; diff --git a/t/cdbi/23-cascade.t b/t/cdbi/23-cascade.t index fdee3f7..eb9c3f5 100644 --- a/t/cdbi/23-cascade.t +++ b/t/cdbi/23-cascade.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use Data::Dumper; diff --git a/t/cdbi/24-meta_info.t b/t/cdbi/24-meta_info.t index 0a44fb5..f2fc57f 100644 --- a/t/cdbi/24-meta_info.t +++ b/t/cdbi/24-meta_info.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use Test::Warn; diff --git a/t/cdbi/26-mutator.t b/t/cdbi/26-mutator.t index ad4d645..a203059 100644 --- a/t/cdbi/26-mutator.t +++ b/t/cdbi/26-mutator.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/30-pager.t b/t/cdbi/30-pager.t index cb1cee9..9ee838a 100644 --- a/t/cdbi/30-pager.t +++ b/t/cdbi/30-pager.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/98-failure.t b/t/cdbi/98-failure.t index 73db8ad..1a42e03 100644 --- a/t/cdbi/98-failure.t +++ b/t/cdbi/98-failure.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; #---------------------------------------------------------------------- diff --git a/t/cdbi/DeepAbstractSearch/01_search.t b/t/cdbi/DeepAbstractSearch/01_search.t index 10f5f99..95ad021 100644 --- a/t/cdbi/DeepAbstractSearch/01_search.t +++ b/t/cdbi/DeepAbstractSearch/01_search.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/columns_as_hashes.t b/t/cdbi/columns_as_hashes.t index fcb6b17..f10f522 100644 --- a/t/cdbi/columns_as_hashes.t +++ b/t/cdbi/columns_as_hashes.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use Test::Warn; diff --git a/t/cdbi/columns_dont_override_custom_accessors.t b/t/cdbi/columns_dont_override_custom_accessors.t index fdff082..27a96fd 100644 --- a/t/cdbi/columns_dont_override_custom_accessors.t +++ b/t/cdbi/columns_dont_override_custom_accessors.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/construct.t b/t/cdbi/construct.t index 1e15a34..1ce8160 100644 --- a/t/cdbi/construct.t +++ b/t/cdbi/construct.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; INIT { diff --git a/t/cdbi/copy.t b/t/cdbi/copy.t index bde83ec..6c079cc 100644 --- a/t/cdbi/copy.t +++ b/t/cdbi/copy.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; INIT { diff --git a/t/cdbi/early_column_heisenbug.t b/t/cdbi/early_column_heisenbug.t index 0dd87b9..859d43d 100644 --- a/t/cdbi/early_column_heisenbug.t +++ b/t/cdbi/early_column_heisenbug.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; diff --git a/t/cdbi/has_many_loads_foreign_class.t b/t/cdbi/has_many_loads_foreign_class.t index 4275f65..bba66e8 100644 --- a/t/cdbi/has_many_loads_foreign_class.t +++ b/t/cdbi/has_many_loads_foreign_class.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use Class::Inspector (); diff --git a/t/cdbi/hasa_without_loading.t b/t/cdbi/hasa_without_loading.t index 8173fdb..5f92df2 100644 --- a/t/cdbi/hasa_without_loading.t +++ b/t/cdbi/hasa_without_loading.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/max_min_value_of.t b/t/cdbi/max_min_value_of.t index e9e627e..5dc2f1a 100644 --- a/t/cdbi/max_min_value_of.t +++ b/t/cdbi/max_min_value_of.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; #---------------------------------------------------------------------- diff --git a/t/cdbi/mk_group_accessors.t b/t/cdbi/mk_group_accessors.t index fa82c01..08adeef 100644 --- a/t/cdbi/mk_group_accessors.t +++ b/t/cdbi/mk_group_accessors.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; INIT { diff --git a/t/cdbi/multi_column_set.t b/t/cdbi/multi_column_set.t index bae1d4c..8ca3bcf 100644 --- a/t/cdbi/multi_column_set.t +++ b/t/cdbi/multi_column_set.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/object_cache.t b/t/cdbi/object_cache.t index a0fdd20..c349940 100644 --- a/t/cdbi/object_cache.t +++ b/t/cdbi/object_cache.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; $| = 1; diff --git a/t/cdbi/retrieve_from_sql_with_limit.t b/t/cdbi/retrieve_from_sql_with_limit.t index 64dfe03..a73358c 100644 --- a/t/cdbi/retrieve_from_sql_with_limit.t +++ b/t/cdbi/retrieve_from_sql_with_limit.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; INIT { diff --git a/t/cdbi/set_to_undef.t b/t/cdbi/set_to_undef.t index 20fe77b..03fe0ca 100644 --- a/t/cdbi/set_to_undef.t +++ b/t/cdbi/set_to_undef.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use lib 't/cdbi/testlib'; diff --git a/t/cdbi/set_vs_DateTime.t b/t/cdbi/set_vs_DateTime.t index 72d69af..08fe4c9 100644 --- a/t/cdbi/set_vs_DateTime.t +++ b/t/cdbi/set_vs_DateTime.t @@ -1,4 +1,5 @@ use strict; +use warnings; use Test::More; use Test::Exception; diff --git a/t/cdbi/testlib/Blurb.pm b/t/cdbi/testlib/Blurb.pm index 22eb2eb..ba48059 100644 --- a/t/cdbi/testlib/Blurb.pm +++ b/t/cdbi/testlib/Blurb.pm @@ -1,7 +1,9 @@ package # hide from PAUSE Blurb; +use warnings; use strict; + use base 'DBIC::Test::SQLite'; __PACKAGE__->set_table('Blurbs'); diff --git a/t/cdbi/testlib/CDBase.pm b/t/cdbi/testlib/CDBase.pm index 282b74d..75447a2 100644 --- a/t/cdbi/testlib/CDBase.pm +++ b/t/cdbi/testlib/CDBase.pm @@ -1,7 +1,9 @@ package # hide from PAUSE CDBase; +use warnings; use strict; + use base qw(DBIC::Test::SQLite); 1; diff --git a/t/cdbi/testlib/Director.pm b/t/cdbi/testlib/Director.pm index 511c0e7..5bed696 100644 --- a/t/cdbi/testlib/Director.pm +++ b/t/cdbi/testlib/Director.pm @@ -1,7 +1,9 @@ package # hide from PAUSE Director; +use warnings; use strict; + use base 'DBIC::Test::SQLite'; __PACKAGE__->set_table('Directors'); diff --git a/t/cdbi/testlib/Film.pm b/t/cdbi/testlib/Film.pm index 9ea829d..3bbd755 100644 --- a/t/cdbi/testlib/Film.pm +++ b/t/cdbi/testlib/Film.pm @@ -1,9 +1,11 @@ package # hide from PAUSE Film; -use base 'DBIC::Test::SQLite'; +use warnings; use strict; +use base 'DBIC::Test::SQLite'; + __PACKAGE__->set_table('Movies'); __PACKAGE__->columns('Primary', 'Title'); __PACKAGE__->columns('Essential', qw( Title )); diff --git a/t/cdbi/testlib/Lazy.pm b/t/cdbi/testlib/Lazy.pm index d05e817..e7770b8 100644 --- a/t/cdbi/testlib/Lazy.pm +++ b/t/cdbi/testlib/Lazy.pm @@ -1,9 +1,11 @@ package # hide from PAUSE Lazy; -use base 'DBIC::Test::SQLite'; +use warnings; use strict; +use base 'DBIC::Test::SQLite'; + __PACKAGE__->set_table("Lazy"); __PACKAGE__->columns('Primary', qw(this)); __PACKAGE__->columns('Essential', qw(opop)); diff --git a/t/cdbi/testlib/Log.pm b/t/cdbi/testlib/Log.pm index 914c60d..4f90ed1 100644 --- a/t/cdbi/testlib/Log.pm +++ b/t/cdbi/testlib/Log.pm @@ -1,9 +1,11 @@ package # hide from PAUSE Log; +use warnings; +use strict; + use base 'MyBase'; -use strict; use Time::Piece::MySQL; use POSIX; diff --git a/t/cdbi/testlib/MyBase.pm b/t/cdbi/testlib/MyBase.pm index c06f179..bf55635 100644 --- a/t/cdbi/testlib/MyBase.pm +++ b/t/cdbi/testlib/MyBase.pm @@ -1,7 +1,9 @@ package # hide from PAUSE MyBase; +use warnings; use strict; + use DBI; use lib 't/lib'; diff --git a/t/cdbi/testlib/MyFilm.pm b/t/cdbi/testlib/MyFilm.pm index 9e9a656..40ecf7e 100644 --- a/t/cdbi/testlib/MyFilm.pm +++ b/t/cdbi/testlib/MyFilm.pm @@ -1,11 +1,12 @@ package # hide from PAUSE MyFilm; +use warnings; +use strict; + use base 'MyBase'; use MyStarLink; -use strict; - __PACKAGE__->set_table(); __PACKAGE__->columns(All => qw/filmid title/); __PACKAGE__->has_many(_stars => 'MyStarLink'); diff --git a/t/cdbi/testlib/MyFoo.pm b/t/cdbi/testlib/MyFoo.pm index 28c3433..11a4feb 100644 --- a/t/cdbi/testlib/MyFoo.pm +++ b/t/cdbi/testlib/MyFoo.pm @@ -1,12 +1,13 @@ package # hide from PAUSE MyFoo; +use warnings; +use strict; + use base 'MyBase'; use Date::Simple 3.03; -use strict; - __PACKAGE__->set_table(); __PACKAGE__->columns(All => qw/myid name val tdate/); __PACKAGE__->has_a( diff --git a/t/cdbi/testlib/MyStar.pm b/t/cdbi/testlib/MyStar.pm index dffae9e..100fbf4 100644 --- a/t/cdbi/testlib/MyStar.pm +++ b/t/cdbi/testlib/MyStar.pm @@ -1,10 +1,11 @@ package # hide from PAUSE MyStar; -use base 'MyBase'; - +use warnings; use strict; +use base 'MyBase'; + __PACKAGE__->set_table(); __PACKAGE__->columns(All => qw/starid name/); __PACKAGE__->has_many(films => [ MyStarLink => 'film' ]); diff --git a/t/cdbi/testlib/MyStarLink.pm b/t/cdbi/testlib/MyStarLink.pm index 1da8733..27254d8 100644 --- a/t/cdbi/testlib/MyStarLink.pm +++ b/t/cdbi/testlib/MyStarLink.pm @@ -1,10 +1,11 @@ package # hide from PAUSE MyStarLink; -use base 'MyBase'; - +use warnings; use strict; +use base 'MyBase'; + __PACKAGE__->set_table(); __PACKAGE__->columns(All => qw/linkid film star/); __PACKAGE__->has_a(film => 'MyFilm'); diff --git a/t/cdbi/testlib/MyStarLinkMCPK.pm b/t/cdbi/testlib/MyStarLinkMCPK.pm index 0b7f55a..1173163 100644 --- a/t/cdbi/testlib/MyStarLinkMCPK.pm +++ b/t/cdbi/testlib/MyStarLinkMCPK.pm @@ -1,13 +1,14 @@ package # hide from PAUSE MyStarLinkMCPK; +use warnings; +use strict; + use base 'MyBase'; use MyStar; use MyFilm; -use strict; - # This is a many-to-many mapping table that uses the two foreign keys # as its own primary key - there's no extra 'auto-inc' column here diff --git a/t/cdbi/testlib/Order.pm b/t/cdbi/testlib/Order.pm index d5281a7..62a16a6 100644 --- a/t/cdbi/testlib/Order.pm +++ b/t/cdbi/testlib/Order.pm @@ -1,7 +1,9 @@ package # hide from PAUSE Order; +use warnings; use strict; + use base 'DBIC::Test::SQLite'; __PACKAGE__->set_table('orders'); diff --git a/t/cdbi/testlib/OtherFilm.pm b/t/cdbi/testlib/OtherFilm.pm index 888e521..a0afdd8 100644 --- a/t/cdbi/testlib/OtherFilm.pm +++ b/t/cdbi/testlib/OtherFilm.pm @@ -1,7 +1,9 @@ package # hide from PAUSE OtherFilm; +use warnings; use strict; + use base 'Film'; __PACKAGE__->set_table('Different_Film'); diff --git a/t/cdbi/testlib/OtherThing.pm b/t/cdbi/testlib/OtherThing.pm index 59fb818..698b342 100644 --- a/t/cdbi/testlib/OtherThing.pm +++ b/t/cdbi/testlib/OtherThing.pm @@ -1,4 +1,8 @@ package OtherThing; + +use warnings; +use strict; + use base 'DBIC::Test::SQLite'; OtherThing->set_table("other_thing"); diff --git a/t/cdbi/testlib/Thing.pm b/t/cdbi/testlib/Thing.pm index 4080b66..7af7aac 100644 --- a/t/cdbi/testlib/Thing.pm +++ b/t/cdbi/testlib/Thing.pm @@ -1,4 +1,8 @@ package Thing; + +use warnings; +use strict; + use base 'DBIC::Test::SQLite'; Thing->set_table("thing"); diff --git a/t/count/count_rs.t b/t/count/count_rs.t index 88961c8..83b6257 100644 --- a/t/count/count_rs.t +++ b/t/count/count_rs.t @@ -168,4 +168,42 @@ my $schema = DBICTest->init_schema(); is ($crs->next, 2, 'Correct artist count (each with one 2001 cd)'); } +# count with two having clauses +{ + my $rs = $schema->resultset("Artist")->search( + {}, + { + join => 'cds', + group_by => 'me.artistid', + '+select' => [ { max => 'cds.year', -as => 'newest_cd_year' } ], + '+as' => ['newest_cd_year'], + having => { 'newest_cd_year' => [ '1998', '2001' ] } + } + ); + + my $crs = $rs->count_rs; + + is_same_sql_bind ( + $crs->as_query, + '(SELECT COUNT( * ) + FROM ( + SELECT me.artistid, MAX( cds.year ) AS newest_cd_year + FROM artist me + LEFT JOIN cd cds ON cds.artist = me.artistid + GROUP BY me.artistid + HAVING newest_cd_year = ? OR newest_cd_year = ? + ) me + )', + [ + [ { dbic_colname => 'newest_cd_year' } + => '1998' ], + [ { dbic_colname => 'newest_cd_year' } + => '2001' ], + ], + 'count with having clause keeps sql as alias', + ); + + is ($crs->next, 3, 'Correct artist count (each with one 1998 or 2001 cd)'); +} + done_testing; diff --git a/t/count/distinct.t b/t/count/distinct.t index 1ef8ccf..1b44b9a 100644 --- a/t/count/distinct.t +++ b/t/count/distinct.t @@ -80,7 +80,7 @@ for my $get_count ( throws_ok( sub { my $row = $schema->resultset('Tag')->search({}, { select => { distinct => [qw/tag cd/] } })->first }, - qr/select => { distinct => \.\.\. } syntax is not supported for multiple columns/, + qr/\Qselect => { distinct => ... } syntax is not supported for multiple columns/, 'throw on unsupported syntax' ); @@ -111,6 +111,64 @@ throws_ok( is ($rs->next->get_column ('num_cds'), 3, 'Function aliased correctly'); } +# and check distinct has_many join count +{ + my $rs = $schema->resultset('Artist')->search( + { 'cds.title' => { '!=', 'fooooo' } }, + { + join => 'cds', + distinct => 1, + '+select' => [ { count => 'cds.cdid', -as => 'amount_of_cds' } ], + '+as' => [qw/num_cds/], + order_by => { -desc => 'amount_of_cds' }, + } + ); + + is_same_sql_bind ( + $rs->as_query, + '( + SELECT me.artistid, me.name, me.rank, me.charfield, COUNT( cds.cdid ) AS amount_of_cds + FROM artist me + LEFT JOIN cd cds + ON cds.artist = me.artistid + WHERE cds.title != ? + GROUP BY me.artistid, me.name, me.rank, me.charfield + ORDER BY amount_of_cds DESC + )', + [ + [{ + sqlt_datatype => 'varchar', + dbic_colname => 'cds.title', + sqlt_size => 100, + } => 'fooooo' ], + ], + ); + + is_same_sql_bind ( + $rs->count_rs->as_query, + '( + SELECT COUNT( * ) + FROM ( + SELECT me.artistid, me.name, me.rank, me.charfield + FROM artist me + LEFT JOIN cd cds + ON cds.artist = me.artistid + WHERE cds.title != ? + GROUP BY me.artistid, me.name, me.rank, me.charfield + ) me + )', + [ + [{ + sqlt_datatype => 'varchar', + dbic_colname => 'cds.title', + sqlt_size => 100, + } => 'fooooo' ], + ], + ); + + is ($rs->next->get_column ('num_cds'), 3, 'Function aliased correctly'); +} + # These two rely on the database to throw an exception. This might not be the case one day. Please revise. dies_ok(sub { my $count = $schema->resultset('Tag')->search({}, { '+select' => \'tagid AS tag_id', distinct => 1 })->count }, 'expecting to die'); diff --git a/t/delete/related.t b/t/delete/related.t index f8e1d97..d4dc26b 100644 --- a/t/delete/related.t +++ b/t/delete/related.t @@ -52,7 +52,7 @@ is ($cdrs->count, $total_cds -= 2, 'related + condition delete ok'); $a2_cds->search ({}, { rows => 1})->delete; is ($cdrs->count, $total_cds -= 1, 'related + limit delete ok'); -TODO: { +{ local $TODO = 'delete_related is based on search_related which is based on search which does not understand object arguments'; local $SIG{__WARN__} = sub {}; # trap the non-numeric warning, remove when the TODO is removed diff --git a/t/inflate/datetime.t b/t/inflate/datetime.t index 14a2ce0..33be522 100644 --- a/t/inflate/datetime.t +++ b/t/inflate/datetime.t @@ -42,7 +42,7 @@ warnings_exist { } [$dt_warn_re], 'using a DateTime object in ->search generates a warning'; -TODO: { +{ local $TODO = "We can't do this yet before 0.09" if DBIx::Class->VERSION < 0.09; is(eval { $row->id }, 1, 'DT in search'); diff --git a/t/inflate/datetime_firebird.t b/t/inflate/datetime_firebird.t index dc5357d..c958d6b 100644 --- a/t/inflate/datetime_firebird.t +++ b/t/inflate/datetime_firebird.t @@ -7,48 +7,36 @@ use lib qw(t/lib); use DBICTest; use Scope::Guard (); -my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_FIREBIRD_${_}" } qw/DSN USER PASS/}; -my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_FIREBIRD_INTERBASE_${_}" } qw/DSN USER PASS/}; -my ($dsn3, $user3, $pass3) = @ENV{map { "DBICTEST_FIREBIRD_ODBC_${_}" } qw/DSN USER PASS/}; - -plan skip_all => 'Test needs ' . - (join ' and ', map { $_ ? $_ : () } - DBIx::Class::Optional::Dependencies->req_missing_for('test_dt'), - (join ' or ', map { $_ ? $_ : () } - DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_firebird'), - DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_firebird_interbase'), - DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_firebird_odbc'))) - unless - DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt') && ( - $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_firebird') - or - $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_firebird_interbase') - or - $dsn3 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_firebird_odbc')) - or (not $dsn || $dsn2 || $dsn3); - -if (not ($dsn || $dsn2)) { - plan skip_all => <<'EOF'; -Set $ENV{DBICTEST_FIREBIRD_DSN} and/or $ENV{DBICTEST_FIREBIRD_INTERBASE_DSN} -and/or $ENV{DBICTEST_FIREBIRD_ODBC_DSN} -_USER and _PASS to run this test'. -Warning: This test drops and creates a table called 'event'"; -EOF -} +my $env2optdep = { + DBICTEST_FIREBIRD => 'test_rdbms_firebird', + DBICTEST_FIREBIRD_INTERBASE => 'test_rdbms_firebird_interbase', + DBICTEST_FIREBIRD_ODBC => 'test_rdbms_firebird_odbc', +}; + +plan skip_all => join (' ', + 'Set $ENV{DBICTEST_FIREBIRD_DSN} and/or $ENV{DBICTEST_FIREBIRD_INTERBASE_DSN}', + 'and/or $ENV{DBICTEST_FIREBIRD_ODBC_DSN},', + '_USER and _PASS to run these tests.', -my @info = ( - [ $dsn, $user, $pass ], - [ $dsn2, $user2, $pass2 ], - [ $dsn3, $user3, $pass3 ], -); + "WARNING: This test drops and creates a table called 'event'", +) unless grep { $ENV{"${_}_DSN"} } keys %$env2optdep; + +plan skip_all => ( 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('test_dt') ) + unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt'); my $schema; -foreach my $conn_idx (0..$#info) { - my ($dsn, $user, $pass) = @{ $info[$conn_idx] || [] }; +for my $prefix (keys %$env2optdep) { SKIP: { + + my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; next unless $dsn; + note "Testing with ${prefix}_DSN"; + + skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1) + unless DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix}); + $schema = DBICTest::Schema->connect($dsn, $user, $pass, { quote_char => '"', name_sep => '.', @@ -89,7 +77,7 @@ SQL 'fractional part of a second survived'; is $row->starts_at, $date_only, 'DATE as DateTime roundtrip'; -} +} } done_testing; diff --git a/t/inflate/datetime_oracle.t b/t/inflate/datetime_oracle.t index 2a9b0c3..26a5357 100644 --- a/t/inflate/datetime_oracle.t +++ b/t/inflate/datetime_oracle.t @@ -48,9 +48,10 @@ eval { }; $dbh->do("CREATE TABLE track (trackid NUMBER(12), cd NUMBER(12), position NUMBER(12), title VARCHAR(255), last_updated_on DATE, last_updated_at $timestamp_datatype)"); -TODO: { +# TODO is in effect for the rest of the tests local $TODO = 'FIXME - something odd is going on with Oracle < 9 datetime support' if ($schema->storage->_server_info->{normalized_dbms_version}||0) < 9; + lives_ok { # insert a row to play with @@ -103,7 +104,7 @@ is( $track->last_updated_at, $timestamp, 'DateTime round-trip as TIMESTAMP' ); is( int $track->last_updated_at->nanosecond, int 500_000_000, 'TIMESTAMP nanoseconds survived' ); -} 'dateteime operations executed correctly' } # end of lives_ok/TODO block +} 'dateteime operations executed correctly'; done_testing; diff --git a/t/inflate/file_column.t b/t/inflate/file_column.t index e200619..1b69e51 100644 --- a/t/inflate/file_column.t +++ b/t/inflate/file_column.t @@ -88,7 +88,7 @@ $fh = $new_source_file->open('r') or die "failed to open $new_source_file: $!\n" $fc->file({ handle => $fh, filename => $new_fname }); $fc->update; -TODO: { +{ local $TODO = 'design change required'; ok ( ! -e $storage, 'old storage does not exist' ); }; @@ -120,8 +120,8 @@ $storage = file( $fc->file->{filename}, ); -TODO: { +{ local $TODO = 'need resultset delete override to delete_all'; $rs->delete; ok ( ! -e $storage, 'storage does not exist after $rs->delete' ); -}; +} diff --git a/t/lib/DBICNSTest/Bogus/A.pm b/t/lib/DBICNSTest/Bogus/A.pm index 3d2c9ae..471b39c 100644 --- a/t/lib/DBICNSTest/Bogus/A.pm +++ b/t/lib/DBICNSTest/Bogus/A.pm @@ -1,4 +1,8 @@ package DBICNSTest::Bogus::A; + +use warnings; +use strict; + use base qw/DBIx::Class::Core/; __PACKAGE__->table('a'); __PACKAGE__->add_columns('a'); diff --git a/t/lib/DBICNSTest/Bogus/B.pm b/t/lib/DBICNSTest/Bogus/B.pm index 6cdaaa6..2115a2e 100644 --- a/t/lib/DBICNSTest/Bogus/B.pm +++ b/t/lib/DBICNSTest/Bogus/B.pm @@ -1,4 +1,8 @@ package DBICNSTest::Result::B; + +use warnings; +use strict; + use base qw/DBIx::Class::Core/; __PACKAGE__->table('b'); __PACKAGE__->add_columns('b'); diff --git a/t/lib/DBICNSTest/Bogus/Bigos.pm b/t/lib/DBICNSTest/Bogus/Bigos.pm index 0f49683..37d0e69 100644 --- a/t/lib/DBICNSTest/Bogus/Bigos.pm +++ b/t/lib/DBICNSTest/Bogus/Bigos.pm @@ -1,3 +1,7 @@ package DBICNSTest::Bogus::Bigos; +use warnings; +use strict; + + 1; diff --git a/t/lib/DBICNSTest/OtherRslt/D.pm b/t/lib/DBICNSTest/OtherRslt/D.pm index d74ff11..58058be 100644 --- a/t/lib/DBICNSTest/OtherRslt/D.pm +++ b/t/lib/DBICNSTest/OtherRslt/D.pm @@ -1,4 +1,8 @@ package DBICNSTest::OtherRslt::D; + +use warnings; +use strict; + use base qw/DBIx::Class::Core/; __PACKAGE__->table('d'); __PACKAGE__->add_columns('d'); diff --git a/t/lib/DBICNSTest/RSBase.pm b/t/lib/DBICNSTest/RSBase.pm index 9786d5f..fdac307 100644 --- a/t/lib/DBICNSTest/RSBase.pm +++ b/t/lib/DBICNSTest/RSBase.pm @@ -1,3 +1,7 @@ package DBICNSTest::RSBase; + +use warnings; +use strict; + use base qw/DBIx::Class::ResultSet/; 1; diff --git a/t/lib/DBICNSTest/RSet/A.pm b/t/lib/DBICNSTest/RSet/A.pm index 4cb415f..2c01e02 100644 --- a/t/lib/DBICNSTest/RSet/A.pm +++ b/t/lib/DBICNSTest/RSet/A.pm @@ -1,3 +1,7 @@ package DBICNSTest::RSet::A; + +use warnings; +use strict; + use base qw/DBIx::Class::ResultSet/; 1; diff --git a/t/lib/DBICNSTest/RSet/C.pm b/t/lib/DBICNSTest/RSet/C.pm index c43a3fe..a2590ac 100644 --- a/t/lib/DBICNSTest/RSet/C.pm +++ b/t/lib/DBICNSTest/RSet/C.pm @@ -1,3 +1,7 @@ package DBICNSTest::RSet::C; + +use warnings; +use strict; + use base qw/DBIx::Class::ResultSet/; 1; diff --git a/t/lib/DBICNSTest/Result/A.pm b/t/lib/DBICNSTest/Result/A.pm index 7861989..97f4c77 100644 --- a/t/lib/DBICNSTest/Result/A.pm +++ b/t/lib/DBICNSTest/Result/A.pm @@ -1,4 +1,8 @@ package DBICNSTest::Result::A; + +use warnings; +use strict; + use base qw/DBIx::Class::Core/; __PACKAGE__->table('a'); __PACKAGE__->add_columns('a'); diff --git a/t/lib/DBICNSTest/Result/B.pm b/t/lib/DBICNSTest/Result/B.pm index 6cdaaa6..2115a2e 100644 --- a/t/lib/DBICNSTest/Result/B.pm +++ b/t/lib/DBICNSTest/Result/B.pm @@ -1,4 +1,8 @@ package DBICNSTest::Result::B; + +use warnings; +use strict; + use base qw/DBIx::Class::Core/; __PACKAGE__->table('b'); __PACKAGE__->add_columns('b'); diff --git a/t/lib/DBICNSTest/Result/D.pm b/t/lib/DBICNSTest/Result/D.pm index d7b603f..fd6afbe 100644 --- a/t/lib/DBICNSTest/Result/D.pm +++ b/t/lib/DBICNSTest/Result/D.pm @@ -1,4 +1,8 @@ package DBICNSTest::Result::D; + +use warnings; +use strict; + use base qw/DBIx::Class::Core/; __PACKAGE__->table('d'); __PACKAGE__->add_columns('d'); diff --git a/t/lib/DBICNSTest/ResultSet/A.pm b/t/lib/DBICNSTest/ResultSet/A.pm index c7a86aa..4892ec1 100644 --- a/t/lib/DBICNSTest/ResultSet/A.pm +++ b/t/lib/DBICNSTest/ResultSet/A.pm @@ -1,3 +1,7 @@ package DBICNSTest::ResultSet::A; + +use warnings; +use strict; + use base qw/DBIx::Class::ResultSet/; 1; diff --git a/t/lib/DBICNSTest/ResultSet/C.pm b/t/lib/DBICNSTest/ResultSet/C.pm index 55ecf1d..a7cb951 100644 --- a/t/lib/DBICNSTest/ResultSet/C.pm +++ b/t/lib/DBICNSTest/ResultSet/C.pm @@ -1,3 +1,7 @@ package DBICNSTest::ResultSet::C; + +use warnings; +use strict; + use base qw/DBIx::Class::ResultSet/; 1; diff --git a/t/lib/DBICNSTest/ResultSet/D.pm b/t/lib/DBICNSTest/ResultSet/D.pm index 88894d3..8745100 100644 --- a/t/lib/DBICNSTest/ResultSet/D.pm +++ b/t/lib/DBICNSTest/ResultSet/D.pm @@ -1,2 +1,6 @@ package DBICNSTest::ResultSet::D; + +use warnings; +use strict; + 1; diff --git a/t/lib/DBICNSTest/Rslt/A.pm b/t/lib/DBICNSTest/Rslt/A.pm index d02038f..8d9a6e1 100644 --- a/t/lib/DBICNSTest/Rslt/A.pm +++ b/t/lib/DBICNSTest/Rslt/A.pm @@ -1,4 +1,8 @@ package DBICNSTest::Rslt::A; + +use warnings; +use strict; + use base qw/DBIx::Class::Core/; __PACKAGE__->table('a'); __PACKAGE__->add_columns('a'); diff --git a/t/lib/DBICNSTest/Rslt/B.pm b/t/lib/DBICNSTest/Rslt/B.pm index f7660b9..59b8c75 100644 --- a/t/lib/DBICNSTest/Rslt/B.pm +++ b/t/lib/DBICNSTest/Rslt/B.pm @@ -1,4 +1,8 @@ package DBICNSTest::Rslt::B; + +use warnings; +use strict; + use base qw/DBIx::Class::Core/; __PACKAGE__->table('b'); __PACKAGE__->add_columns('b'); diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index 58f5cca..0c1d3b2 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -5,11 +5,12 @@ use strict; use warnings; use DBICTest::RunMode; use DBICTest::Schema; -use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry local_umask/; +use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; +use DBICTest::Util 'local_umask'; use Carp; use Path::Class::File (); use File::Spec; -use Fcntl qw/:flock/; +use Fcntl qw/:DEFAULT :flock/; =head1 NAME @@ -60,11 +61,11 @@ our ($global_lock_fh, $global_exclusive_lock); sub import { my $self = shift; - my $lockpath = File::Spec->tmpdir . '/.dbictest_global.lock'; + my $lockpath = DBICTest::RunMode->tmpdir->file('.dbictest_global.lock'); { my $u = local_umask(0); # so that the file opens as 666, and any user can lock - open ($global_lock_fh, '>', $lockpath) + sysopen ($global_lock_fh, $lockpath, O_RDWR|O_CREAT) or die "Unable to open $lockpath: $!"; } @@ -189,7 +190,7 @@ sub _database { } sub __mk_disconnect_guard { - return if DBIx::Class::_ENV_::PEEPEENESS(); # leaks handles, delaying DESTROY, can't work right + return if DBIx::Class::_ENV_::PEEPEENESS; # leaks handles, delaying DESTROY, can't work right my $db_file = shift; return unless -f $db_file; diff --git a/t/lib/DBICTest/BaseResult.pm b/t/lib/DBICTest/BaseResult.pm index ea232e2..c732181 100644 --- a/t/lib/DBICTest/BaseResult.pm +++ b/t/lib/DBICTest/BaseResult.pm @@ -4,9 +4,12 @@ package #hide from pause use strict; use warnings; +# must load before any DBIx::Class* namespaces +use DBICTest::RunMode; + +use base 'DBIx::Class::Core'; + #use base qw/DBIx::Class::Relationship::Cascade::Rekey DBIx::Class::Core/; -use base qw/DBIx::Class::Core/; -use DBICTest::BaseResultSet; __PACKAGE__->table ('bogus'); __PACKAGE__->resultset_class ('DBICTest::BaseResultSet'); diff --git a/t/lib/DBICTest/BaseResultSet.pm b/t/lib/DBICTest/BaseResultSet.pm index 6d9df85..946219d 100644 --- a/t/lib/DBICTest/BaseResultSet.pm +++ b/t/lib/DBICTest/BaseResultSet.pm @@ -4,10 +4,13 @@ package #hide from pause use strict; use warnings; -use base qw/DBIx::Class::ResultSet/; +# must load before any DBIx::Class* namespaces +use DBICTest::RunMode; -sub hri_dump { - return shift->search ({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator' }); +use base 'DBIx::Class::ResultSet'; + +sub all_hri { + return [ shift->search ({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator' })->all ]; } 1; diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm new file mode 100644 index 0000000..010e3e9 --- /dev/null +++ b/t/lib/DBICTest/BaseSchema.pm @@ -0,0 +1,12 @@ +package #hide from pause + DBICTest::BaseSchema; + +use strict; +use warnings; + +# must load before any DBIx::Class* namespaces +use DBICTest::RunMode; + +use base 'DBIx::Class::Schema'; + +1; diff --git a/t/lib/DBICTest/ResultSetManager.pm b/t/lib/DBICTest/ResultSetManager.pm index 1fafbf0..7815a8d 100644 --- a/t/lib/DBICTest/ResultSetManager.pm +++ b/t/lib/DBICTest/ResultSetManager.pm @@ -1,6 +1,10 @@ package # hide from PAUSE DBICTest::ResultSetManager; -use base 'DBIx::Class::Schema'; + +use warnings; +use strict; + +use base 'DBICTest::BaseSchema'; __PACKAGE__->load_classes("Foo"); diff --git a/t/lib/DBICTest/ResultSetManager/Foo.pm b/t/lib/DBICTest/ResultSetManager/Foo.pm index fec8345..d776491 100644 --- a/t/lib/DBICTest/ResultSetManager/Foo.pm +++ b/t/lib/DBICTest/ResultSetManager/Foo.pm @@ -1,5 +1,9 @@ package # hide from PAUSE DBICTest::ResultSetManager::Foo; + +use warnings; +use strict; + use base 'DBIx::Class::Core'; __PACKAGE__->load_components(qw/ ResultSetManager /); diff --git a/t/lib/DBICTest/RunMode.pm b/t/lib/DBICTest/RunMode.pm index b773c5d..53eb073 100644 --- a/t/lib/DBICTest/RunMode.pm +++ b/t/lib/DBICTest/RunMode.pm @@ -16,9 +16,35 @@ BEGIN { } use Path::Class qw/file dir/; +use File::Spec; _check_author_makefile() unless $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}; +# PathTools has a bug where on MSWin32 it will often return / as a tmpdir. +# This is *really* stupid and the result of having our lockfiles all over +# the place is also rather obnoxious. So we use our own heuristics instead +# https://rt.cpan.org/Ticket/Display.html?id=76663 +my $tmpdir; +sub tmpdir { + dir ($tmpdir ||= do { + + my $dir = dir(File::Spec->tmpdir); + + my @parts = File::Spec->splitdir($dir); + if (@parts == 2 and $parts[1] eq '') { + # This means we were give the root dir (C:\ or something equally unacceptable) + # Replace with our local project tmpdir. This will make multiple runs + # from different runs conflict with each other, but is much better than + # polluting the root dir with random crap + $dir = _find_co_root()->subdir('t')->subdir('var'); + $dir->mkpath; + } + + $dir->stringify; + }); +} + + # Die if the author did not update his makefile # # This is pretty heavy handed, so the check is pretty solid: @@ -124,7 +150,11 @@ sub is_author { } sub is_smoker { - return ( $ENV{AUTOMATED_TESTING} && ! $ENV{PERL5_CPANM_IS_RUNNING} && ! $ENV{RELEASE_TESTING} ) + return + ( ($ENV{TRAVIS}||'') eq 'true' ) + || + ( $ENV{AUTOMATED_TESTING} && ! $ENV{PERL5_CPANM_IS_RUNNING} && ! $ENV{RELEASE_TESTING} ) + ; } sub is_plain { diff --git a/t/lib/DBICTest/Schema.pm b/t/lib/DBICTest/Schema.pm index d24acbd..8abb593 100644 --- a/t/lib/DBICTest/Schema.pm +++ b/t/lib/DBICTest/Schema.pm @@ -5,13 +5,13 @@ use strict; use warnings; no warnings 'qw'; -use base 'DBIx::Class::Schema'; +use base 'DBICTest::BaseSchema'; use Fcntl qw/:DEFAULT :seek :flock/; use Time::HiRes 'sleep'; -use Path::Class::File; -use File::Spec; -use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry local_umask/; +use DBICTest::RunMode; +use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; +use DBICTest::Util 'local_umask'; use namespace::clean; __PACKAGE__->mk_group_accessors(simple => 'custom_attr'); @@ -150,9 +150,13 @@ sub connection { # Also if there is no connection - there is no lock to be had if ($locktype and (!$locker or $locker->{type} ne $locktype)) { - warn "$$ $0 $locktype" if $locktype eq 'generic' or $locktype eq 'SQLite'; + warn "$$ $0 $locktype" if ( + ($locktype eq 'generic' or $locktype eq 'SQLite') + and + DBICTest::RunMode->is_author + ); - my $lockpath = File::Spec->tmpdir . "/.dbictest_$locktype.lock"; + my $lockpath = DBICTest::RunMode->tmpdir->file(".dbictest_$locktype.lock"); my $lock_fh; { diff --git a/t/lib/DBICTest/Schema/Artist.pm b/t/lib/DBICTest/Schema/Artist.pm index 2e9ff35..20affe0 100644 --- a/t/lib/DBICTest/Schema/Artist.pm +++ b/t/lib/DBICTest/Schema/Artist.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::Artist; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; use Carp qw/confess/; diff --git a/t/lib/DBICTest/Schema/ArtistGUID.pm b/t/lib/DBICTest/Schema/ArtistGUID.pm index a06a465..243c84b 100644 --- a/t/lib/DBICTest/Schema/ArtistGUID.pm +++ b/t/lib/DBICTest/Schema/ArtistGUID.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::ArtistGUID; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; # test MSSQL uniqueidentifier type diff --git a/t/lib/DBICTest/Schema/ArtistSourceName.pm b/t/lib/DBICTest/Schema/ArtistSourceName.pm index c59bbe5..3e6a7e6 100644 --- a/t/lib/DBICTest/Schema/ArtistSourceName.pm +++ b/t/lib/DBICTest/Schema/ArtistSourceName.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::ArtistSourceName; +use warnings; +use strict; + use base 'DBICTest::Schema::Artist'; __PACKAGE__->table(__PACKAGE__->table); __PACKAGE__->source_name('SourceNameArtists'); diff --git a/t/lib/DBICTest/Schema/ArtistSubclass.pm b/t/lib/DBICTest/Schema/ArtistSubclass.pm index 8dd3f6f..e1b97fa 100644 --- a/t/lib/DBICTest/Schema/ArtistSubclass.pm +++ b/t/lib/DBICTest/Schema/ArtistSubclass.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::ArtistSubclass; +use warnings; +use strict; + use base 'DBICTest::Schema::Artist'; __PACKAGE__->table(__PACKAGE__->table); diff --git a/t/lib/DBICTest/Schema/ArtistUndirectedMap.pm b/t/lib/DBICTest/Schema/ArtistUndirectedMap.pm index e79faaa..facc1a2 100644 --- a/t/lib/DBICTest/Schema/ArtistUndirectedMap.pm +++ b/t/lib/DBICTest/Schema/ArtistUndirectedMap.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::ArtistUndirectedMap; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('artist_undirected_map'); diff --git a/t/lib/DBICTest/Schema/Artwork.pm b/t/lib/DBICTest/Schema/Artwork.pm index 351d9dd..01ce450 100644 --- a/t/lib/DBICTest/Schema/Artwork.pm +++ b/t/lib/DBICTest/Schema/Artwork.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::Artwork; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; use Carp qw/confess/; diff --git a/t/lib/DBICTest/Schema/Artwork_to_Artist.pm b/t/lib/DBICTest/Schema/Artwork_to_Artist.pm index dc0d50d..57326e2 100644 --- a/t/lib/DBICTest/Schema/Artwork_to_Artist.pm +++ b/t/lib/DBICTest/Schema/Artwork_to_Artist.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::Artwork_to_Artist; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; use Carp qw/confess/; diff --git a/t/lib/DBICTest/Schema/BindType.pm b/t/lib/DBICTest/Schema/BindType.pm index e25ad92..97edc8b 100644 --- a/t/lib/DBICTest/Schema/BindType.pm +++ b/t/lib/DBICTest/Schema/BindType.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::BindType; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('bindtype_test'); diff --git a/t/lib/DBICTest/Schema/Bookmark.pm b/t/lib/DBICTest/Schema/Bookmark.pm index 50c18d1..40cfa3f 100644 --- a/t/lib/DBICTest/Schema/Bookmark.pm +++ b/t/lib/DBICTest/Schema/Bookmark.pm @@ -1,11 +1,11 @@ package # hide from PAUSE DBICTest::Schema::Bookmark; -use base qw/DBICTest::BaseResult/; - use strict; use warnings; +use base qw/DBICTest::BaseResult/; + __PACKAGE__->table('bookmark'); __PACKAGE__->add_columns( 'id' => { diff --git a/t/lib/DBICTest/Schema/BooksInLibrary.pm b/t/lib/DBICTest/Schema/BooksInLibrary.pm index 325a460..cd6f375 100644 --- a/t/lib/DBICTest/Schema/BooksInLibrary.pm +++ b/t/lib/DBICTest/Schema/BooksInLibrary.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::BooksInLibrary; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('books'); diff --git a/t/lib/DBICTest/Schema/CD.pm b/t/lib/DBICTest/Schema/CD.pm index cb4cc3f..77a1f19 100644 --- a/t/lib/DBICTest/Schema/CD.pm +++ b/t/lib/DBICTest/Schema/CD.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::CD; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; # this tests table name as scalar ref diff --git a/t/lib/DBICTest/Schema/CD_to_Producer.pm b/t/lib/DBICTest/Schema/CD_to_Producer.pm index 278396e..b416797 100644 --- a/t/lib/DBICTest/Schema/CD_to_Producer.pm +++ b/t/lib/DBICTest/Schema/CD_to_Producer.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::CD_to_Producer; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('cd_to_producer'); diff --git a/t/lib/DBICTest/Schema/Collection.pm b/t/lib/DBICTest/Schema/Collection.pm index 5943c91..a5f9d86 100644 --- a/t/lib/DBICTest/Schema/Collection.pm +++ b/t/lib/DBICTest/Schema/Collection.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::Collection; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('collection'); diff --git a/t/lib/DBICTest/Schema/CollectionObject.pm b/t/lib/DBICTest/Schema/CollectionObject.pm index a0c8a30..1a013e0 100644 --- a/t/lib/DBICTest/Schema/CollectionObject.pm +++ b/t/lib/DBICTest/Schema/CollectionObject.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::CollectionObject; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('collection_object'); diff --git a/t/lib/DBICTest/Schema/ComputedColumn.pm b/t/lib/DBICTest/Schema/ComputedColumn.pm index d47129c..961b5fc 100644 --- a/t/lib/DBICTest/Schema/ComputedColumn.pm +++ b/t/lib/DBICTest/Schema/ComputedColumn.pm @@ -3,6 +3,9 @@ package # hide from PAUSE # for sybase and mssql computed column tests +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('computed_column_test'); diff --git a/t/lib/DBICTest/Schema/CustomSql.pm b/t/lib/DBICTest/Schema/CustomSql.pm index c87e89d..d22b3fe 100644 --- a/t/lib/DBICTest/Schema/CustomSql.pm +++ b/t/lib/DBICTest/Schema/CustomSql.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::CustomSql; +use warnings; +use strict; + use base qw/DBICTest::Schema::Artist/; __PACKAGE__->table('dummy'); diff --git a/t/lib/DBICTest/Schema/Dummy.pm b/t/lib/DBICTest/Schema/Dummy.pm index b4ab736..949a098 100644 --- a/t/lib/DBICTest/Schema/Dummy.pm +++ b/t/lib/DBICTest/Schema/Dummy.pm @@ -1,11 +1,11 @@ package # hide from PAUSE DBICTest::Schema::Dummy; -use base qw/DBICTest::BaseResult/; - use strict; use warnings; +use base qw/DBICTest::BaseResult/; + __PACKAGE__->table('dummy'); __PACKAGE__->add_columns( 'id' => { diff --git a/t/lib/DBICTest/Schema/Employee.pm b/t/lib/DBICTest/Schema/Employee.pm index 59a9467..dde6fd3 100644 --- a/t/lib/DBICTest/Schema/Employee.pm +++ b/t/lib/DBICTest/Schema/Employee.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::Employee; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->load_components(qw( Ordered )); diff --git a/t/lib/DBICTest/Schema/Encoded.pm b/t/lib/DBICTest/Schema/Encoded.pm index 234846d..aab5d9f 100644 --- a/t/lib/DBICTest/Schema/Encoded.pm +++ b/t/lib/DBICTest/Schema/Encoded.pm @@ -1,11 +1,11 @@ package # hide from PAUSE DBICTest::Schema::Encoded; -use base qw/DBICTest::BaseResult/; - use strict; use warnings; +use base qw/DBICTest::BaseResult/; + __PACKAGE__->table('encoded'); __PACKAGE__->add_columns( 'id' => { diff --git a/t/lib/DBICTest/Schema/Event.pm b/t/lib/DBICTest/Schema/Event.pm index 29bf11d..624cc7c 100644 --- a/t/lib/DBICTest/Schema/Event.pm +++ b/t/lib/DBICTest/Schema/Event.pm @@ -2,6 +2,7 @@ package DBICTest::Schema::Event; use strict; use warnings; + use base qw/DBICTest::BaseResult/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); diff --git a/t/lib/DBICTest/Schema/EventSmallDT.pm b/t/lib/DBICTest/Schema/EventSmallDT.pm index 560581d..7da8ea1 100644 --- a/t/lib/DBICTest/Schema/EventSmallDT.pm +++ b/t/lib/DBICTest/Schema/EventSmallDT.pm @@ -2,6 +2,7 @@ package DBICTest::Schema::EventSmallDT; use strict; use warnings; + use base qw/DBICTest::BaseResult/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); diff --git a/t/lib/DBICTest/Schema/EventTZ.pm b/t/lib/DBICTest/Schema/EventTZ.pm index 2d8df28..4c6c48a 100644 --- a/t/lib/DBICTest/Schema/EventTZ.pm +++ b/t/lib/DBICTest/Schema/EventTZ.pm @@ -2,6 +2,7 @@ package DBICTest::Schema::EventTZ; use strict; use warnings; + use base qw/DBICTest::BaseResult/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); diff --git a/t/lib/DBICTest/Schema/EventTZDeprecated.pm b/t/lib/DBICTest/Schema/EventTZDeprecated.pm index a667976..c66cd07 100644 --- a/t/lib/DBICTest/Schema/EventTZDeprecated.pm +++ b/t/lib/DBICTest/Schema/EventTZDeprecated.pm @@ -2,6 +2,7 @@ package DBICTest::Schema::EventTZDeprecated; use strict; use warnings; + use base qw/DBICTest::BaseResult/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); diff --git a/t/lib/DBICTest/Schema/EventTZPg.pm b/t/lib/DBICTest/Schema/EventTZPg.pm index 521a9c4..1f191af 100644 --- a/t/lib/DBICTest/Schema/EventTZPg.pm +++ b/t/lib/DBICTest/Schema/EventTZPg.pm @@ -2,6 +2,7 @@ package DBICTest::Schema::EventTZPg; use strict; use warnings; + use base qw/DBICTest::BaseResult/; __PACKAGE__->load_components(qw/InflateColumn::DateTime/); diff --git a/t/lib/DBICTest/Schema/ForceForeign.pm b/t/lib/DBICTest/Schema/ForceForeign.pm index c340d8b..a870f3e 100644 --- a/t/lib/DBICTest/Schema/ForceForeign.pm +++ b/t/lib/DBICTest/Schema/ForceForeign.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::ForceForeign; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('forceforeign'); diff --git a/t/lib/DBICTest/Schema/FourKeys.pm b/t/lib/DBICTest/Schema/FourKeys.pm index 442a3e0..dc48b2b 100644 --- a/t/lib/DBICTest/Schema/FourKeys.pm +++ b/t/lib/DBICTest/Schema/FourKeys.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::FourKeys; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('fourkeys'); diff --git a/t/lib/DBICTest/Schema/FourKeys_to_TwoKeys.pm b/t/lib/DBICTest/Schema/FourKeys_to_TwoKeys.pm index f4e9aa4..a208135 100644 --- a/t/lib/DBICTest/Schema/FourKeys_to_TwoKeys.pm +++ b/t/lib/DBICTest/Schema/FourKeys_to_TwoKeys.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::FourKeys_to_TwoKeys; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('fourkeys_to_twokeys'); diff --git a/t/lib/DBICTest/Schema/Genre.pm b/t/lib/DBICTest/Schema/Genre.pm index dceabc9..461526e 100644 --- a/t/lib/DBICTest/Schema/Genre.pm +++ b/t/lib/DBICTest/Schema/Genre.pm @@ -1,5 +1,6 @@ package DBICTest::Schema::Genre; +use warnings; use strict; use base qw/DBICTest::BaseResult/; diff --git a/t/lib/DBICTest/Schema/Image.pm b/t/lib/DBICTest/Schema/Image.pm index d9e295e..bfaf7eb 100644 --- a/t/lib/DBICTest/Schema/Image.pm +++ b/t/lib/DBICTest/Schema/Image.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::Image; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('images'); diff --git a/t/lib/DBICTest/Schema/LinerNotes.pm b/t/lib/DBICTest/Schema/LinerNotes.pm index b7e3da2..6c75f25 100644 --- a/t/lib/DBICTest/Schema/LinerNotes.pm +++ b/t/lib/DBICTest/Schema/LinerNotes.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::LinerNotes; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('liner_notes'); diff --git a/t/lib/DBICTest/Schema/Link.pm b/t/lib/DBICTest/Schema/Link.pm index 19b7aa0..50ddf3f 100644 --- a/t/lib/DBICTest/Schema/Link.pm +++ b/t/lib/DBICTest/Schema/Link.pm @@ -1,11 +1,11 @@ package # hide from PAUSE DBICTest::Schema::Link; -use base qw/DBICTest::BaseResult/; - use strict; use warnings; +use base qw/DBICTest::BaseResult/; + __PACKAGE__->table('link'); __PACKAGE__->add_columns( 'id' => { diff --git a/t/lib/DBICTest/Schema/LyricVersion.pm b/t/lib/DBICTest/Schema/LyricVersion.pm index d497659..93538a8 100644 --- a/t/lib/DBICTest/Schema/LyricVersion.pm +++ b/t/lib/DBICTest/Schema/LyricVersion.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::LyricVersion; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('lyric_versions'); diff --git a/t/lib/DBICTest/Schema/Lyrics.pm b/t/lib/DBICTest/Schema/Lyrics.pm index 02ea191..bb0a56b 100644 --- a/t/lib/DBICTest/Schema/Lyrics.pm +++ b/t/lib/DBICTest/Schema/Lyrics.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::Lyrics; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('lyrics'); diff --git a/t/lib/DBICTest/Schema/Money.pm b/t/lib/DBICTest/Schema/Money.pm index 91d0629..77e1844 100644 --- a/t/lib/DBICTest/Schema/Money.pm +++ b/t/lib/DBICTest/Schema/Money.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::Money; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('money_test'); diff --git a/t/lib/DBICTest/Schema/NoPrimaryKey.pm b/t/lib/DBICTest/Schema/NoPrimaryKey.pm index 20841f1..ea4da6b 100644 --- a/t/lib/DBICTest/Schema/NoPrimaryKey.pm +++ b/t/lib/DBICTest/Schema/NoPrimaryKey.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::NoPrimaryKey; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('noprimarykey'); diff --git a/t/lib/DBICTest/Schema/NoSuchClass.pm b/t/lib/DBICTest/Schema/NoSuchClass.pm index 2730b3a..2bb98ec 100644 --- a/t/lib/DBICTest/Schema/NoSuchClass.pm +++ b/t/lib/DBICTest/Schema/NoSuchClass.pm @@ -1,5 +1,8 @@ package DBICTest::Schema::NoSuchClass; +use warnings; +use strict; + ## This is purposefully not a real DBIC class ## Used in t/102load_classes.t diff --git a/t/lib/DBICTest/Schema/OneKey.pm b/t/lib/DBICTest/Schema/OneKey.pm index 6e5aa2d..06b4e00 100644 --- a/t/lib/DBICTest/Schema/OneKey.pm +++ b/t/lib/DBICTest/Schema/OneKey.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::OneKey; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('onekey'); diff --git a/t/lib/DBICTest/Schema/Owners.pm b/t/lib/DBICTest/Schema/Owners.pm index 600980f..0df64a8 100644 --- a/t/lib/DBICTest/Schema/Owners.pm +++ b/t/lib/DBICTest/Schema/Owners.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::Owners; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('owners'); diff --git a/t/lib/DBICTest/Schema/Producer.pm b/t/lib/DBICTest/Schema/Producer.pm index 903e3c4..3e722e6 100644 --- a/t/lib/DBICTest/Schema/Producer.pm +++ b/t/lib/DBICTest/Schema/Producer.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::Producer; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('producer'); diff --git a/t/lib/DBICTest/Schema/PunctuatedColumnName.pm b/t/lib/DBICTest/Schema/PunctuatedColumnName.pm index e8a6454..828a58c 100644 --- a/t/lib/DBICTest/Schema/PunctuatedColumnName.pm +++ b/t/lib/DBICTest/Schema/PunctuatedColumnName.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::PunctuatedColumnName; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('punctuated_column_name'); diff --git a/t/lib/DBICTest/Schema/SelfRef.pm b/t/lib/DBICTest/Schema/SelfRef.pm index 2a6b07e..41ae6d9 100644 --- a/t/lib/DBICTest/Schema/SelfRef.pm +++ b/t/lib/DBICTest/Schema/SelfRef.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::SelfRef; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('self_ref'); diff --git a/t/lib/DBICTest/Schema/SelfRefAlias.pm b/t/lib/DBICTest/Schema/SelfRefAlias.pm index ac5d442..aaf453e 100644 --- a/t/lib/DBICTest/Schema/SelfRefAlias.pm +++ b/t/lib/DBICTest/Schema/SelfRefAlias.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::SelfRefAlias; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('self_ref_alias'); diff --git a/t/lib/DBICTest/Schema/SequenceTest.pm b/t/lib/DBICTest/Schema/SequenceTest.pm index 6bd3f8a..bd236f7 100644 --- a/t/lib/DBICTest/Schema/SequenceTest.pm +++ b/t/lib/DBICTest/Schema/SequenceTest.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::SequenceTest; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('sequence_test'); diff --git a/t/lib/DBICTest/Schema/Serialized.pm b/t/lib/DBICTest/Schema/Serialized.pm index 0642e8b..1de158e 100644 --- a/t/lib/DBICTest/Schema/Serialized.pm +++ b/t/lib/DBICTest/Schema/Serialized.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::Serialized; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('serialized'); diff --git a/t/lib/DBICTest/Schema/Tag.pm b/t/lib/DBICTest/Schema/Tag.pm index ad56361..40bd945 100644 --- a/t/lib/DBICTest/Schema/Tag.pm +++ b/t/lib/DBICTest/Schema/Tag.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::Tag; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('tags'); diff --git a/t/lib/DBICTest/Schema/TimestampPrimaryKey.pm b/t/lib/DBICTest/Schema/TimestampPrimaryKey.pm index 300a5dc..8ec4cf9 100644 --- a/t/lib/DBICTest/Schema/TimestampPrimaryKey.pm +++ b/t/lib/DBICTest/Schema/TimestampPrimaryKey.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::TimestampPrimaryKey; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('timestamp_primary_key_test'); diff --git a/t/lib/DBICTest/Schema/Track.pm b/t/lib/DBICTest/Schema/Track.pm index e1e56b4..b82545a 100644 --- a/t/lib/DBICTest/Schema/Track.pm +++ b/t/lib/DBICTest/Schema/Track.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::Track; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; use Carp qw/confess/; diff --git a/t/lib/DBICTest/Schema/TreeLike.pm b/t/lib/DBICTest/Schema/TreeLike.pm index 21b1ef3..853bfe6 100644 --- a/t/lib/DBICTest/Schema/TreeLike.pm +++ b/t/lib/DBICTest/Schema/TreeLike.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::TreeLike; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('treelike'); diff --git a/t/lib/DBICTest/Schema/TwoKeyTreeLike.pm b/t/lib/DBICTest/Schema/TwoKeyTreeLike.pm index 79c7405..b28fc48 100644 --- a/t/lib/DBICTest/Schema/TwoKeyTreeLike.pm +++ b/t/lib/DBICTest/Schema/TwoKeyTreeLike.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::TwoKeyTreeLike; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('twokeytreelike'); diff --git a/t/lib/DBICTest/Schema/TwoKeys.pm b/t/lib/DBICTest/Schema/TwoKeys.pm index bfb6c42..ff8f980 100644 --- a/t/lib/DBICTest/Schema/TwoKeys.pm +++ b/t/lib/DBICTest/Schema/TwoKeys.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::TwoKeys; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('twokeys'); diff --git a/t/lib/DBICTest/Schema/TypedObject.pm b/t/lib/DBICTest/Schema/TypedObject.pm index 7679c5e..c56fe3a 100644 --- a/t/lib/DBICTest/Schema/TypedObject.pm +++ b/t/lib/DBICTest/Schema/TypedObject.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::TypedObject; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table('typed_object'); diff --git a/t/lib/DBICTest/Schema/VaryingMAX.pm b/t/lib/DBICTest/Schema/VaryingMAX.pm index beca65f..9549483 100644 --- a/t/lib/DBICTest/Schema/VaryingMAX.pm +++ b/t/lib/DBICTest/Schema/VaryingMAX.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::VaryingMAX; +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; # Test VARCHAR(MAX) type for MSSQL (used in ADO tests) diff --git a/t/lib/DBICTest/Schema/Year1999CDs.pm b/t/lib/DBICTest/Schema/Year1999CDs.pm index db3bc3f..e13f044 100644 --- a/t/lib/DBICTest/Schema/Year1999CDs.pm +++ b/t/lib/DBICTest/Schema/Year1999CDs.pm @@ -2,6 +2,9 @@ package # hide from PAUSE DBICTest::Schema::Year1999CDs; ## Used in 104view.t +use warnings; +use strict; + use base qw/DBICTest::BaseResult/; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); diff --git a/t/lib/DBICTest/Schema/Year2000CDs.pm b/t/lib/DBICTest/Schema/Year2000CDs.pm index 2fc30aa..f0890a3 100644 --- a/t/lib/DBICTest/Schema/Year2000CDs.pm +++ b/t/lib/DBICTest/Schema/Year2000CDs.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema::Year2000CDs; +use warnings; +use strict; + use base qw/DBICTest::Schema::CD/; __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); diff --git a/t/lib/DBICTest/SyntaxErrorComponent3.pm b/t/lib/DBICTest/SyntaxErrorComponent3.pm index 34f3c3f..b68f691 100644 --- a/t/lib/DBICTest/SyntaxErrorComponent3.pm +++ b/t/lib/DBICTest/SyntaxErrorComponent3.pm @@ -1,5 +1,6 @@ package DBICErrorTest::SyntaxError; use strict; +use warnings; I'm a syntax error! diff --git a/t/lib/DBICTest/Taint/Classes/Auto.pm b/t/lib/DBICTest/Taint/Classes/Auto.pm index e33903c..81e8105 100644 --- a/t/lib/DBICTest/Taint/Classes/Auto.pm +++ b/t/lib/DBICTest/Taint/Classes/Auto.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Taint::Classes::Auto; +use warnings; +use strict; + use base 'DBIx::Class::Core'; __PACKAGE__->table('test'); diff --git a/t/lib/DBICTest/Taint/Classes/Manual.pm b/t/lib/DBICTest/Taint/Classes/Manual.pm index 5dd73c1..a7ad2c8 100644 --- a/t/lib/DBICTest/Taint/Classes/Manual.pm +++ b/t/lib/DBICTest/Taint/Classes/Manual.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Taint::Classes::Manual; +use warnings; +use strict; + use base 'DBIx::Class::Core'; __PACKAGE__->table('test'); diff --git a/t/lib/DBICTest/Taint/Namespaces/Result/Test.pm b/t/lib/DBICTest/Taint/Namespaces/Result/Test.pm index 1bae3ed..b9b7034 100644 --- a/t/lib/DBICTest/Taint/Namespaces/Result/Test.pm +++ b/t/lib/DBICTest/Taint/Namespaces/Result/Test.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Taint::Namespaces::Result::Test; +use warnings; +use strict; + use base 'DBIx::Class::Core'; __PACKAGE__->table('test'); diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 3f489c2..557ee36 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -4,11 +4,10 @@ use warnings; use strict; use Carp; -use Scalar::Util qw/isweak weaken blessed reftype refaddr/; use Config; use base 'Exporter'; -our @EXPORT_OK = qw/local_umask stacktrace populate_weakregistry assert_empty_weakregistry/; +our @EXPORT_OK = qw/local_umask stacktrace/; sub local_umask { return unless defined $Config{d_umask}; @@ -47,89 +46,4 @@ sub stacktrace { return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack; } -my $refs_traced = 0; -sub populate_weakregistry { - my ($reg, $target, $slot) = @_; - - croak 'Target is not a reference' unless defined ref $target; - - $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification - (defined blessed $target) ? blessed($target) . '=' : '', - reftype $target, - refaddr $target, - ); - - if (defined $reg->{$slot}{weakref}) { - if ( refaddr($reg->{$slot}{weakref}) != (refaddr $target) ) { - print STDERR "Bail out! Weak Registry slot collision: $reg->{$slot}{weakref} / $target\n"; - exit 255; - } - } - else { - $refs_traced++; - weaken( $reg->{$slot}{weakref} = $target ); - $reg->{$slot}{stacktrace} = stacktrace(1); - } - - $target; -} - -my $leaks_found; -sub assert_empty_weakregistry { - my ($weak_registry, $quiet) = @_; - - croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; - - return unless keys %$weak_registry; - - my $tb = eval { Test::Builder->new } - or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense'; - - for my $slot (sort keys %$weak_registry) { - next if ! defined $weak_registry->{$slot}{weakref}; - $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!") - unless isweak( $weak_registry->{$slot}{weakref} ); - } - - - for my $slot (sort keys %$weak_registry) { - ! defined $weak_registry->{$slot}{weakref} and next if $quiet; - - $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do { - $leaks_found = 1; - - my $diag = ''; - - $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n" - if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); - - if (my $stack = $weak_registry->{$slot}{stacktrace}) { - $diag .= " Reference first seen$stack"; - } - - $tb->diag($diag) if $diag; - }; - } -} - -END { - if ($INC{'Test/Builder.pm'}) { - my $tb = Test::Builder->new; - - # we check for test passage - a leak may be a part of a TODO - if ($leaks_found and !$tb->is_passing) { - - $tb->diag(sprintf - "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set " - . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report' - . "\n\n%s\n%s\n\n", ('#' x 16) x 4 - ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} ); - - } - else { - $tb->note("Auto checked $refs_traced references for leaks - none detected"); - } - } -} - 1; diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm new file mode 100644 index 0000000..d0e63f2 --- /dev/null +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -0,0 +1,131 @@ +package DBICTest::Util::LeakTracer; + +use warnings; +use strict; + +use Carp; +use Scalar::Util qw/isweak weaken blessed reftype refaddr/; +use DBICTest::Util 'stacktrace'; + +use base 'Exporter'; +our @EXPORT_OK = qw/populate_weakregistry assert_empty_weakregistry/; + +my $refs_traced = 0; +my $leaks_found; +my %reg_of_regs; + +sub populate_weakregistry { + my ($weak_registry, $target, $slot) = @_; + + croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; + croak 'Target is not a reference' unless length ref $target; + + $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification + (defined blessed $target) ? blessed($target) . '=' : '', + reftype $target, + refaddr $target, + ); + + if (defined $weak_registry->{$slot}{weakref}) { + if ( refaddr($weak_registry->{$slot}{weakref}) != (refaddr $target) ) { + print STDERR "Bail out! Weak Registry slot collision: $weak_registry->{$slot}{weakref} / $target\n"; + exit 255; + } + } + else { + $refs_traced++; + weaken( $weak_registry->{$slot}{weakref} = $target ); + $weak_registry->{$slot}{stacktrace} = stacktrace(1); + $weak_registry->{$slot}{renumber} = 1 unless $_[2]; + } + + weaken( $reg_of_regs{ refaddr($weak_registry) } = $weak_registry ) + unless( $reg_of_regs{ refaddr($weak_registry) } ); + + $target; +} + +# Renumber everything we auto-named on a thread spawn +sub CLONE { + my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs; + %reg_of_regs = (); + + for my $reg (@individual_regs) { + my @live_slots = grep { defined $reg->{$_}{weakref} } keys %$reg + or next; + + my @live_instances = @{$reg}{@live_slots}; + + $reg = {}; # get a fresh hashref in the new thread ctx + weaken( $reg_of_regs{refaddr($reg)} = $reg ); + + while (@live_slots) { + my $slot = shift @live_slots; + my $inst = shift @live_instances; + + $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', refaddr($inst))/ieg + if $inst->{renumber}; + + $reg->{$slot} = $inst; + } + } +} + +sub assert_empty_weakregistry { + my ($weak_registry, $quiet) = @_; + + croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; + + return unless keys %$weak_registry; + + my $tb = eval { Test::Builder->new } + or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense'; + + for my $slot (sort keys %$weak_registry) { + next if ! defined $weak_registry->{$slot}{weakref}; + $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!") + unless isweak( $weak_registry->{$slot}{weakref} ); + } + + + for my $slot (sort keys %$weak_registry) { + ! defined $weak_registry->{$slot}{weakref} and next if $quiet; + + $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do { + $leaks_found = 1; + + my $diag = ''; + + $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n" + if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); + + if (my $stack = $weak_registry->{$slot}{stacktrace}) { + $diag .= " Reference first seen$stack"; + } + + $tb->diag($diag) if $diag; + }; + } +} + +END { + if ($INC{'Test/Builder.pm'}) { + my $tb = Test::Builder->new; + + # we check for test passage - a leak may be a part of a TODO + if ($leaks_found and !$tb->is_passing) { + + $tb->diag(sprintf + "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set " + . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report' + . "\n\n%s\n%s\n\n", ('#' x 16) x 4 + ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} ); + + } + else { + $tb->note("Auto checked $refs_traced references for leaks - none detected"); + } + } +} + +1; diff --git a/t/lib/DBICVersion_v1.pm b/t/lib/DBICVersion_v1.pm index d2e6325..a2cf9f7 100644 --- a/t/lib/DBICVersion_v1.pm +++ b/t/lib/DBICVersion_v1.pm @@ -28,7 +28,7 @@ __PACKAGE__->add_columns __PACKAGE__->set_primary_key('Version'); package DBICVersion::Schema; -use base 'DBIx::Class::Schema'; +use base 'DBICTest::BaseSchema'; use strict; use warnings; diff --git a/t/lib/DBICVersion_v2.pm b/t/lib/DBICVersion_v2.pm index 6f152f1..f103160 100644 --- a/t/lib/DBICVersion_v2.pm +++ b/t/lib/DBICVersion_v2.pm @@ -36,7 +36,7 @@ __PACKAGE__->add_columns __PACKAGE__->set_primary_key('Version'); package DBICVersion::Schema; -use base 'DBIx::Class::Schema'; +use base 'DBICTest::BaseSchema'; use strict; use warnings; diff --git a/t/lib/DBICVersion_v3.pm b/t/lib/DBICVersion_v3.pm index d66b897..8321143 100644 --- a/t/lib/DBICVersion_v3.pm +++ b/t/lib/DBICVersion_v3.pm @@ -44,7 +44,7 @@ __PACKAGE__->add_columns __PACKAGE__->set_primary_key('Version'); package DBICVersion::Schema; -use base 'DBIx::Class::Schema'; +use base 'DBICTest::BaseSchema'; use strict; use warnings; diff --git a/t/lib/PrefetchBug.pm b/t/lib/PrefetchBug.pm new file mode 100644 index 0000000..278bf5b --- /dev/null +++ b/t/lib/PrefetchBug.pm @@ -0,0 +1,11 @@ +package + PrefetchBug; + +use strict; +use warnings; + +use base qw/DBIx::Class::Schema/; + +__PACKAGE__->load_classes(); + +1; diff --git a/t/lib/PrefetchBug/Left.pm b/t/lib/PrefetchBug/Left.pm new file mode 100644 index 0000000..34d362b --- /dev/null +++ b/t/lib/PrefetchBug/Left.pm @@ -0,0 +1,20 @@ +package PrefetchBug::Left; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->table('prefetchbug_left'); +__PACKAGE__->add_columns( + id => { data_type => 'integer', is_auto_increment => 1 }, +); + +__PACKAGE__->set_primary_key('id'); + +__PACKAGE__->has_many( + prefetch_leftright => 'PrefetchBug::LeftRight', + 'left_id' +); + +1; diff --git a/t/lib/PrefetchBug/LeftRight.pm b/t/lib/PrefetchBug/LeftRight.pm new file mode 100644 index 0000000..8ac1362 --- /dev/null +++ b/t/lib/PrefetchBug/LeftRight.pm @@ -0,0 +1,24 @@ +package + PrefetchBug::LeftRight; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->table('prefetchbug_left_right'); +__PACKAGE__->add_columns( + left_id => { data_type => 'integer' }, + right_id => { data_type => 'integer' }, + value => {}); + +__PACKAGE__->set_primary_key('left_id', 'right_id'); +__PACKAGE__->belongs_to(left => 'PrefetchBug::Left', 'left_id'); +__PACKAGE__->belongs_to( + right => 'PrefetchBug::Right', + 'right_id', +# {join_type => 'left'} +); + + +1; diff --git a/t/lib/PrefetchBug/Right.pm b/t/lib/PrefetchBug/Right.pm new file mode 100644 index 0000000..c99dea7 --- /dev/null +++ b/t/lib/PrefetchBug/Right.pm @@ -0,0 +1,14 @@ +package + PrefetchBug::Right; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->table('prefetchbug_right'); +__PACKAGE__->add_columns(qw/ id name category description propagates locked/); +__PACKAGE__->set_primary_key('id'); + +__PACKAGE__->has_many('prefetch_leftright', 'PrefetchBug::LeftRight', 'right_id'); +1; diff --git a/t/lib/ViewDeps.pm b/t/lib/ViewDeps.pm index 6c3a311..e7df0f9 100644 --- a/t/lib/ViewDeps.pm +++ b/t/lib/ViewDeps.pm @@ -4,7 +4,7 @@ package # hide from PAUSE use strict; use warnings; -use base 'DBIx::Class::Schema'; +use base 'DBICTest::BaseSchema'; __PACKAGE__->load_namespaces; diff --git a/t/lib/ViewDepsBad.pm b/t/lib/ViewDepsBad.pm index 9b5be12..97b8868 100644 --- a/t/lib/ViewDepsBad.pm +++ b/t/lib/ViewDepsBad.pm @@ -4,7 +4,7 @@ package # hide from PAUSE use strict; use warnings; -use base 'DBIx::Class::Schema'; +use base 'DBICTest::BaseSchema'; __PACKAGE__->load_namespaces; diff --git a/t/lib/sqlite.sql b/t/lib/sqlite.sql index 9d49210..64ddc33 100644 --- a/t/lib/sqlite.sql +++ b/t/lib/sqlite.sql @@ -1,466 +1,373 @@ --- --- Created by SQL::Translator::Producer::SQLite --- Created on Fri Mar 2 18:22:33 2012 --- - --- --- Table: artist --- -CREATE TABLE artist ( - artistid INTEGER PRIMARY KEY NOT NULL, - name varchar(100), - rank integer NOT NULL DEFAULT 13, - charfield char(10) -); - -CREATE INDEX artist_name_hookidx ON artist (name); - -CREATE UNIQUE INDEX artist_name ON artist (name); - -CREATE UNIQUE INDEX u_nullable ON artist (charfield, rank); - --- --- Table: bindtype_test --- -CREATE TABLE bindtype_test ( - id INTEGER PRIMARY KEY NOT NULL, - bytea blob, - blob blob, - clob clob, - a_memo memo -); - --- --- Table: collection --- -CREATE TABLE collection ( - collectionid INTEGER PRIMARY KEY NOT NULL, - name varchar(100) NOT NULL -); - --- --- Table: encoded --- -CREATE TABLE encoded ( - id INTEGER PRIMARY KEY NOT NULL, - encoded varchar(100) -); - --- --- Table: event --- -CREATE TABLE event ( - id INTEGER PRIMARY KEY NOT NULL, - starts_at date NOT NULL, - created_on timestamp NOT NULL, - varchar_date varchar(20), - varchar_datetime varchar(20), - skip_inflation datetime, - ts_without_tz datetime -); - --- --- Table: fourkeys --- -CREATE TABLE fourkeys ( - foo integer NOT NULL, - bar integer NOT NULL, - hello integer NOT NULL, - goodbye integer NOT NULL, - sensors character(10) NOT NULL, - read_count int, - PRIMARY KEY (foo, bar, hello, goodbye) -); - --- --- Table: genre --- -CREATE TABLE genre ( - genreid INTEGER PRIMARY KEY NOT NULL, - name varchar(100) NOT NULL -); - -CREATE UNIQUE INDEX genre_name ON genre (name); - --- --- Table: link --- -CREATE TABLE link ( - id INTEGER PRIMARY KEY NOT NULL, - url varchar(100), - title varchar(100) -); - --- --- Table: money_test --- -CREATE TABLE money_test ( - id INTEGER PRIMARY KEY NOT NULL, - amount money -); - --- --- Table: noprimarykey --- -CREATE TABLE noprimarykey ( - foo integer NOT NULL, - bar integer NOT NULL, - baz integer NOT NULL -); - -CREATE UNIQUE INDEX foo_bar ON noprimarykey (foo, bar); +CREATE TABLE "artist" ( + "artistid" INTEGER PRIMARY KEY NOT NULL, + "name" varchar(100), + "rank" integer NOT NULL DEFAULT 13, + "charfield" char(10) +); + +CREATE INDEX "artist_name_hookidx" ON "artist" ("name"); + +CREATE UNIQUE INDEX "artist_name" ON "artist" ("name"); + +CREATE UNIQUE INDEX "u_nullable" ON "artist" ("charfield", "rank"); + +CREATE TABLE "bindtype_test" ( + "id" INTEGER PRIMARY KEY NOT NULL, + "bytea" blob, + "blob" blob, + "clob" clob, + "a_memo" memo +); + +CREATE TABLE "collection" ( + "collectionid" INTEGER PRIMARY KEY NOT NULL, + "name" varchar(100) NOT NULL +); + +CREATE TABLE "encoded" ( + "id" INTEGER PRIMARY KEY NOT NULL, + "encoded" varchar(100) +); + +CREATE TABLE "event" ( + "id" INTEGER PRIMARY KEY NOT NULL, + "starts_at" date NOT NULL, + "created_on" timestamp NOT NULL, + "varchar_date" varchar(20), + "varchar_datetime" varchar(20), + "skip_inflation" datetime, + "ts_without_tz" datetime +); + +CREATE TABLE "fourkeys" ( + "foo" integer NOT NULL, + "bar" integer NOT NULL, + "hello" integer NOT NULL, + "goodbye" integer NOT NULL, + "sensors" character(10) NOT NULL, + "read_count" int, + PRIMARY KEY ("foo", "bar", "hello", "goodbye") +); + +CREATE TABLE "genre" ( + "genreid" INTEGER PRIMARY KEY NOT NULL, + "name" varchar(100) NOT NULL +); --- --- Table: onekey --- -CREATE TABLE onekey ( - id INTEGER PRIMARY KEY NOT NULL, - artist integer NOT NULL, - cd integer NOT NULL -); - --- --- Table: owners --- -CREATE TABLE owners ( - id INTEGER PRIMARY KEY NOT NULL, - name varchar(100) NOT NULL -); - -CREATE UNIQUE INDEX owners_name ON owners (name); - --- --- Table: producer --- -CREATE TABLE producer ( - producerid INTEGER PRIMARY KEY NOT NULL, - name varchar(100) NOT NULL +CREATE UNIQUE INDEX "genre_name" ON "genre" ("name"); + +CREATE TABLE "link" ( + "id" INTEGER PRIMARY KEY NOT NULL, + "url" varchar(100), + "title" varchar(100) +); + +CREATE TABLE "money_test" ( + "id" INTEGER PRIMARY KEY NOT NULL, + "amount" money +); + +CREATE TABLE "noprimarykey" ( + "foo" integer NOT NULL, + "bar" integer NOT NULL, + "baz" integer NOT NULL +); + +CREATE UNIQUE INDEX "foo_bar" ON "noprimarykey" ("foo", "bar"); + +CREATE TABLE "onekey" ( + "id" INTEGER PRIMARY KEY NOT NULL, + "artist" integer NOT NULL, + "cd" integer NOT NULL ); -CREATE UNIQUE INDEX prod_name ON producer (name); - --- --- Table: self_ref --- -CREATE TABLE self_ref ( - id INTEGER PRIMARY KEY NOT NULL, - name varchar(100) NOT NULL +CREATE TABLE "owners" ( + "id" INTEGER PRIMARY KEY NOT NULL, + "name" varchar(100) NOT NULL ); - --- --- Table: sequence_test --- -CREATE TABLE sequence_test ( - pkid1 integer NOT NULL, - pkid2 integer NOT NULL, - nonpkid integer NOT NULL, - name varchar(100), - PRIMARY KEY (pkid1, pkid2) + +CREATE UNIQUE INDEX "owners_name" ON "owners" ("name"); + +CREATE TABLE "producer" ( + "producerid" INTEGER PRIMARY KEY NOT NULL, + "name" varchar(100) NOT NULL +); + +CREATE UNIQUE INDEX "prod_name" ON "producer" ("name"); + +CREATE TABLE "self_ref" ( + "id" INTEGER PRIMARY KEY NOT NULL, + "name" varchar(100) NOT NULL +); + +CREATE TABLE "sequence_test" ( + "pkid1" integer NOT NULL, + "pkid2" integer NOT NULL, + "nonpkid" integer NOT NULL, + "name" varchar(100), + PRIMARY KEY ("pkid1", "pkid2") ); --- --- Table: serialized --- -CREATE TABLE serialized ( - id INTEGER PRIMARY KEY NOT NULL, - serialized text NOT NULL +CREATE TABLE "serialized" ( + "id" INTEGER PRIMARY KEY NOT NULL, + "serialized" text NOT NULL ); --- --- Table: timestamp_primary_key_test --- -CREATE TABLE timestamp_primary_key_test ( - id timestamp NOT NULL DEFAULT current_timestamp, - PRIMARY KEY (id) +CREATE TABLE "timestamp_primary_key_test" ( + "id" timestamp NOT NULL DEFAULT current_timestamp, + PRIMARY KEY ("id") ); --- --- Table: treelike --- -CREATE TABLE treelike ( - id INTEGER PRIMARY KEY NOT NULL, - parent integer, - name varchar(100) NOT NULL +CREATE TABLE "treelike" ( + "id" INTEGER PRIMARY KEY NOT NULL, + "parent" integer, + "name" varchar(100) NOT NULL, + FOREIGN KEY ("parent") REFERENCES "treelike"("id") ON DELETE CASCADE ON UPDATE CASCADE ); -CREATE INDEX treelike_idx_parent ON treelike (parent); +CREATE INDEX "treelike_idx_parent" ON "treelike" ("parent"); --- --- Table: twokeytreelike --- -CREATE TABLE twokeytreelike ( - id1 integer NOT NULL, - id2 integer NOT NULL, - parent1 integer NOT NULL, - parent2 integer NOT NULL, - name varchar(100) NOT NULL, - PRIMARY KEY (id1, id2) +CREATE TABLE "twokeytreelike" ( + "id1" integer NOT NULL, + "id2" integer NOT NULL, + "parent1" integer NOT NULL, + "parent2" integer NOT NULL, + "name" varchar(100) NOT NULL, + PRIMARY KEY ("id1", "id2"), + FOREIGN KEY ("parent1", "parent2") REFERENCES "twokeytreelike"("id1", "id2") ); -CREATE INDEX twokeytreelike_idx_parent1_parent2 ON twokeytreelike (parent1, parent2); +CREATE INDEX "twokeytreelike_idx_parent1_parent2" ON "twokeytreelike" ("parent1", "parent2"); -CREATE UNIQUE INDEX tktlnameunique ON twokeytreelike (name); +CREATE UNIQUE INDEX "tktlnameunique" ON "twokeytreelike" ("name"); --- --- Table: typed_object --- -CREATE TABLE typed_object ( - objectid INTEGER PRIMARY KEY NOT NULL, - type varchar(100) NOT NULL, - value varchar(100) NOT NULL +CREATE TABLE "typed_object" ( + "objectid" INTEGER PRIMARY KEY NOT NULL, + "type" varchar(100) NOT NULL, + "value" varchar(100) NOT NULL ); --- --- Table: artist_undirected_map --- -CREATE TABLE artist_undirected_map ( - id1 integer NOT NULL, - id2 integer NOT NULL, - PRIMARY KEY (id1, id2) +CREATE TABLE "artist_undirected_map" ( + "id1" integer NOT NULL, + "id2" integer NOT NULL, + PRIMARY KEY ("id1", "id2"), + FOREIGN KEY ("id1") REFERENCES "artist"("artistid") ON DELETE RESTRICT ON UPDATE CASCADE, + FOREIGN KEY ("id2") REFERENCES "artist"("artistid") ); -CREATE INDEX artist_undirected_map_idx_id1 ON artist_undirected_map (id1); +CREATE INDEX "artist_undirected_map_idx_id1" ON "artist_undirected_map" ("id1"); -CREATE INDEX artist_undirected_map_idx_id2 ON artist_undirected_map (id2); +CREATE INDEX "artist_undirected_map_idx_id2" ON "artist_undirected_map" ("id2"); --- --- Table: bookmark --- -CREATE TABLE bookmark ( - id INTEGER PRIMARY KEY NOT NULL, - link integer +CREATE TABLE "bookmark" ( + "id" INTEGER PRIMARY KEY NOT NULL, + "link" integer, + FOREIGN KEY ("link") REFERENCES "link"("id") ON DELETE SET NULL ON UPDATE CASCADE ); -CREATE INDEX bookmark_idx_link ON bookmark (link); +CREATE INDEX "bookmark_idx_link" ON "bookmark" ("link"); --- --- Table: books --- -CREATE TABLE books ( - id INTEGER PRIMARY KEY NOT NULL, - source varchar(100) NOT NULL, - owner integer NOT NULL, - title varchar(100) NOT NULL, - price integer +CREATE TABLE "books" ( + "id" INTEGER PRIMARY KEY NOT NULL, + "source" varchar(100) NOT NULL, + "owner" integer NOT NULL, + "title" varchar(100) NOT NULL, + "price" integer, + FOREIGN KEY ("owner") REFERENCES "owners"("id") ON DELETE CASCADE ON UPDATE CASCADE ); -CREATE INDEX books_idx_owner ON books (owner); +CREATE INDEX "books_idx_owner" ON "books" ("owner"); -CREATE UNIQUE INDEX books_title ON books (title); +CREATE UNIQUE INDEX "books_title" ON "books" ("title"); --- --- Table: employee --- -CREATE TABLE employee ( - employee_id INTEGER PRIMARY KEY NOT NULL, - position integer NOT NULL, - group_id integer, - group_id_2 integer, - group_id_3 integer, - name varchar(100), - encoded integer +CREATE TABLE "employee" ( + "employee_id" INTEGER PRIMARY KEY NOT NULL, + "position" integer NOT NULL, + "group_id" integer, + "group_id_2" integer, + "group_id_3" integer, + "name" varchar(100), + "encoded" integer, + FOREIGN KEY ("encoded") REFERENCES "encoded"("id") ON DELETE CASCADE ON UPDATE CASCADE ); -CREATE INDEX employee_idx_encoded ON employee (encoded); +CREATE INDEX "employee_idx_encoded" ON "employee" ("encoded"); --- --- Table: forceforeign --- -CREATE TABLE forceforeign ( - artist INTEGER PRIMARY KEY NOT NULL, - cd integer NOT NULL +CREATE TABLE "forceforeign" ( + "artist" INTEGER PRIMARY KEY NOT NULL, + "cd" integer NOT NULL, + FOREIGN KEY ("artist") REFERENCES "artist"("artistid") ); --- --- Table: self_ref_alias --- -CREATE TABLE self_ref_alias ( - self_ref integer NOT NULL, - alias integer NOT NULL, - PRIMARY KEY (self_ref, alias) +CREATE TABLE "self_ref_alias" ( + "self_ref" integer NOT NULL, + "alias" integer NOT NULL, + PRIMARY KEY ("self_ref", "alias"), + FOREIGN KEY ("alias") REFERENCES "self_ref"("id"), + FOREIGN KEY ("self_ref") REFERENCES "self_ref"("id") ON DELETE CASCADE ON UPDATE CASCADE ); -CREATE INDEX self_ref_alias_idx_alias ON self_ref_alias (alias); +CREATE INDEX "self_ref_alias_idx_alias" ON "self_ref_alias" ("alias"); -CREATE INDEX self_ref_alias_idx_self_ref ON self_ref_alias (self_ref); +CREATE INDEX "self_ref_alias_idx_self_ref" ON "self_ref_alias" ("self_ref"); --- --- Table: track --- -CREATE TABLE track ( - trackid INTEGER PRIMARY KEY NOT NULL, - cd integer NOT NULL, - position int NOT NULL, - title varchar(100) NOT NULL, - last_updated_on datetime, - last_updated_at datetime +CREATE TABLE "track" ( + "trackid" INTEGER PRIMARY KEY NOT NULL, + "cd" integer NOT NULL, + "position" int NOT NULL, + "title" varchar(100) NOT NULL, + "last_updated_on" datetime, + "last_updated_at" datetime, + FOREIGN KEY ("cd") REFERENCES "cd"("cdid") ON DELETE CASCADE ON UPDATE CASCADE ); -CREATE INDEX track_idx_cd ON track (cd); +CREATE INDEX "track_idx_cd" ON "track" ("cd"); -CREATE UNIQUE INDEX track_cd_position ON track (cd, position); +CREATE UNIQUE INDEX "track_cd_position" ON "track" ("cd", "position"); -CREATE UNIQUE INDEX track_cd_title ON track (cd, title); +CREATE UNIQUE INDEX "track_cd_title" ON "track" ("cd", "title"); --- --- Table: cd --- -CREATE TABLE cd ( - cdid INTEGER PRIMARY KEY NOT NULL, - artist integer NOT NULL, - title varchar(100) NOT NULL, - year varchar(100) NOT NULL, - genreid integer, - single_track integer +CREATE TABLE "cd" ( + "cdid" INTEGER PRIMARY KEY NOT NULL, + "artist" integer NOT NULL, + "title" varchar(100) NOT NULL, + "year" varchar(100) NOT NULL, + "genreid" integer, + "single_track" integer, + FOREIGN KEY ("artist") REFERENCES "artist"("artistid") ON DELETE CASCADE ON UPDATE CASCADE, + FOREIGN KEY ("single_track") REFERENCES "track"("trackid") ON DELETE CASCADE, + FOREIGN KEY ("genreid") REFERENCES "genre"("genreid") ON DELETE SET NULL ON UPDATE CASCADE ); -CREATE INDEX cd_idx_artist ON cd (artist); +CREATE INDEX "cd_idx_artist" ON "cd" ("artist"); -CREATE INDEX cd_idx_genreid ON cd (genreid); +CREATE INDEX "cd_idx_single_track" ON "cd" ("single_track"); -CREATE INDEX cd_idx_single_track ON cd (single_track); +CREATE INDEX "cd_idx_genreid" ON "cd" ("genreid"); -CREATE UNIQUE INDEX cd_artist_title ON cd (artist, title); +CREATE UNIQUE INDEX "cd_artist_title" ON "cd" ("artist", "title"); --- --- Table: collection_object --- -CREATE TABLE collection_object ( - collection integer NOT NULL, - object integer NOT NULL, - PRIMARY KEY (collection, object) +CREATE TABLE "collection_object" ( + "collection" integer NOT NULL, + "object" integer NOT NULL, + PRIMARY KEY ("collection", "object"), + FOREIGN KEY ("collection") REFERENCES "collection"("collectionid") ON DELETE CASCADE ON UPDATE CASCADE, + FOREIGN KEY ("object") REFERENCES "typed_object"("objectid") ON DELETE CASCADE ON UPDATE CASCADE ); -CREATE INDEX collection_object_idx_collection ON collection_object (collection); +CREATE INDEX "collection_object_idx_collection" ON "collection_object" ("collection"); -CREATE INDEX collection_object_idx_object ON collection_object (object); +CREATE INDEX "collection_object_idx_object" ON "collection_object" ("object"); --- --- Table: lyrics --- -CREATE TABLE lyrics ( - lyric_id INTEGER PRIMARY KEY NOT NULL, - track_id integer NOT NULL +CREATE TABLE "lyrics" ( + "lyric_id" INTEGER PRIMARY KEY NOT NULL, + "track_id" integer NOT NULL, + FOREIGN KEY ("track_id") REFERENCES "track"("trackid") ON DELETE CASCADE ); -CREATE INDEX lyrics_idx_track_id ON lyrics (track_id); +CREATE INDEX "lyrics_idx_track_id" ON "lyrics" ("track_id"); --- --- Table: cd_artwork --- -CREATE TABLE cd_artwork ( - cd_id INTEGER PRIMARY KEY NOT NULL +CREATE TABLE "cd_artwork" ( + "cd_id" INTEGER PRIMARY KEY NOT NULL, + FOREIGN KEY ("cd_id") REFERENCES "cd"("cdid") ON DELETE CASCADE ); --- --- Table: liner_notes --- -CREATE TABLE liner_notes ( - liner_id INTEGER PRIMARY KEY NOT NULL, - notes varchar(100) NOT NULL +CREATE TABLE "liner_notes" ( + "liner_id" INTEGER PRIMARY KEY NOT NULL, + "notes" varchar(100) NOT NULL, + FOREIGN KEY ("liner_id") REFERENCES "cd"("cdid") ON DELETE CASCADE ); --- --- Table: lyric_versions --- -CREATE TABLE lyric_versions ( - id INTEGER PRIMARY KEY NOT NULL, - lyric_id integer NOT NULL, - text varchar(100) NOT NULL +CREATE TABLE "lyric_versions" ( + "id" INTEGER PRIMARY KEY NOT NULL, + "lyric_id" integer NOT NULL, + "text" varchar(100) NOT NULL, + FOREIGN KEY ("lyric_id") REFERENCES "lyrics"("lyric_id") ON DELETE CASCADE ON UPDATE CASCADE ); -CREATE INDEX lyric_versions_idx_lyric_id ON lyric_versions (lyric_id); +CREATE INDEX "lyric_versions_idx_lyric_id" ON "lyric_versions" ("lyric_id"); + +CREATE UNIQUE INDEX "lyric_versions_lyric_id_text" ON "lyric_versions" ("lyric_id", "text"); --- --- Table: tags --- -CREATE TABLE tags ( - tagid INTEGER PRIMARY KEY NOT NULL, - cd integer NOT NULL, - tag varchar(100) NOT NULL +CREATE TABLE "tags" ( + "tagid" INTEGER PRIMARY KEY NOT NULL, + "cd" integer NOT NULL, + "tag" varchar(100) NOT NULL, + FOREIGN KEY ("cd") REFERENCES "cd"("cdid") ON DELETE CASCADE ON UPDATE CASCADE ); -CREATE INDEX tags_idx_cd ON tags (cd); +CREATE INDEX "tags_idx_cd" ON "tags" ("cd"); -CREATE UNIQUE INDEX tagid_cd ON tags (tagid, cd); +CREATE UNIQUE INDEX "tagid_cd" ON "tags" ("tagid", "cd"); -CREATE UNIQUE INDEX tagid_cd_tag ON tags (tagid, cd, tag); +CREATE UNIQUE INDEX "tagid_cd_tag" ON "tags" ("tagid", "cd", "tag"); -CREATE UNIQUE INDEX tags_tagid_tag ON tags (tagid, tag); +CREATE UNIQUE INDEX "tags_tagid_tag" ON "tags" ("tagid", "tag"); -CREATE UNIQUE INDEX tags_tagid_tag_cd ON tags (tagid, tag, cd); +CREATE UNIQUE INDEX "tags_tagid_tag_cd" ON "tags" ("tagid", "tag", "cd"); --- --- Table: cd_to_producer --- -CREATE TABLE cd_to_producer ( - cd integer NOT NULL, - producer integer NOT NULL, - attribute integer, - PRIMARY KEY (cd, producer) +CREATE TABLE "cd_to_producer" ( + "cd" integer NOT NULL, + "producer" integer NOT NULL, + "attribute" integer, + PRIMARY KEY ("cd", "producer"), + FOREIGN KEY ("cd") REFERENCES "cd"("cdid") ON DELETE CASCADE ON UPDATE CASCADE, + FOREIGN KEY ("producer") REFERENCES "producer"("producerid") ); -CREATE INDEX cd_to_producer_idx_cd ON cd_to_producer (cd); +CREATE INDEX "cd_to_producer_idx_cd" ON "cd_to_producer" ("cd"); -CREATE INDEX cd_to_producer_idx_producer ON cd_to_producer (producer); +CREATE INDEX "cd_to_producer_idx_producer" ON "cd_to_producer" ("producer"); --- --- Table: images --- -CREATE TABLE images ( - id INTEGER PRIMARY KEY NOT NULL, - artwork_id integer NOT NULL, - name varchar(100) NOT NULL, - data blob +CREATE TABLE "images" ( + "id" INTEGER PRIMARY KEY NOT NULL, + "artwork_id" integer NOT NULL, + "name" varchar(100) NOT NULL, + "data" blob, + FOREIGN KEY ("artwork_id") REFERENCES "cd_artwork"("cd_id") ON DELETE CASCADE ON UPDATE CASCADE ); -CREATE INDEX images_idx_artwork_id ON images (artwork_id); +CREATE INDEX "images_idx_artwork_id" ON "images" ("artwork_id"); --- --- Table: twokeys --- -CREATE TABLE twokeys ( - artist integer NOT NULL, - cd integer NOT NULL, - PRIMARY KEY (artist, cd) +CREATE TABLE "twokeys" ( + "artist" integer NOT NULL, + "cd" integer NOT NULL, + PRIMARY KEY ("artist", "cd"), + FOREIGN KEY ("artist") REFERENCES "artist"("artistid") ON DELETE CASCADE ON UPDATE CASCADE, + FOREIGN KEY ("cd") REFERENCES "cd"("cdid") ); -CREATE INDEX twokeys_idx_artist ON twokeys (artist); +CREATE INDEX "twokeys_idx_artist" ON "twokeys" ("artist"); --- --- Table: artwork_to_artist --- -CREATE TABLE artwork_to_artist ( - artwork_cd_id integer NOT NULL, - artist_id integer NOT NULL, - PRIMARY KEY (artwork_cd_id, artist_id) +CREATE TABLE "artwork_to_artist" ( + "artwork_cd_id" integer NOT NULL, + "artist_id" integer NOT NULL, + PRIMARY KEY ("artwork_cd_id", "artist_id"), + FOREIGN KEY ("artist_id") REFERENCES "artist"("artistid") ON DELETE CASCADE ON UPDATE CASCADE, + FOREIGN KEY ("artwork_cd_id") REFERENCES "cd_artwork"("cd_id") ON DELETE CASCADE ON UPDATE CASCADE ); -CREATE INDEX artwork_to_artist_idx_artist_id ON artwork_to_artist (artist_id); +CREATE INDEX "artwork_to_artist_idx_artist_id" ON "artwork_to_artist" ("artist_id"); -CREATE INDEX artwork_to_artist_idx_artwork_cd_id ON artwork_to_artist (artwork_cd_id); +CREATE INDEX "artwork_to_artist_idx_artwork_cd_id" ON "artwork_to_artist" ("artwork_cd_id"); --- --- Table: fourkeys_to_twokeys --- -CREATE TABLE fourkeys_to_twokeys ( - f_foo integer NOT NULL, - f_bar integer NOT NULL, - f_hello integer NOT NULL, - f_goodbye integer NOT NULL, - t_artist integer NOT NULL, - t_cd integer NOT NULL, - autopilot character NOT NULL, - pilot_sequence integer, - PRIMARY KEY (f_foo, f_bar, f_hello, f_goodbye, t_artist, t_cd) +CREATE TABLE "fourkeys_to_twokeys" ( + "f_foo" integer NOT NULL, + "f_bar" integer NOT NULL, + "f_hello" integer NOT NULL, + "f_goodbye" integer NOT NULL, + "t_artist" integer NOT NULL, + "t_cd" integer NOT NULL, + "autopilot" character NOT NULL, + "pilot_sequence" integer, + PRIMARY KEY ("f_foo", "f_bar", "f_hello", "f_goodbye", "t_artist", "t_cd"), + FOREIGN KEY ("f_foo", "f_bar", "f_hello", "f_goodbye") REFERENCES "fourkeys"("foo", "bar", "hello", "goodbye") ON DELETE CASCADE ON UPDATE CASCADE, + FOREIGN KEY ("t_artist", "t_cd") REFERENCES "twokeys"("artist", "cd") ON DELETE CASCADE ON UPDATE CASCADE ); -CREATE INDEX fourkeys_to_twokeys_idx_f_foo_f_bar_f_hello_f_goodbye ON fourkeys_to_twokeys (f_foo, f_bar, f_hello, f_goodbye); +CREATE INDEX "fourkeys_to_twokeys_idx_f_foo_f_bar_f_hello_f_goodbye" ON "fourkeys_to_twokeys" ("f_foo", "f_bar", "f_hello", "f_goodbye"); -CREATE INDEX fourkeys_to_twokeys_idx_t_artist_t_cd ON fourkeys_to_twokeys (t_artist, t_cd); +CREATE INDEX "fourkeys_to_twokeys_idx_t_artist_t_cd" ON "fourkeys_to_twokeys" ("t_artist", "t_cd"); --- --- View: year2000cds --- -CREATE VIEW year2000cds AS +CREATE VIEW "year2000cds" AS SELECT cdid, artist, title, year, genreid, single_track FROM cd WHERE year = "2000"; diff --git a/t/lib/testinclude/DBICTestAdminInc.pm b/t/lib/testinclude/DBICTestAdminInc.pm index cf7f6f9..212d33d 100644 --- a/t/lib/testinclude/DBICTestAdminInc.pm +++ b/t/lib/testinclude/DBICTestAdminInc.pm @@ -1,5 +1,9 @@ package DBICTestAdminInc; -use base 'DBIx::Class::Schema'; + +use warnings; +use strict; + +use base 'DBICTest::BaseSchema'; sub connect { exit 70 } # this is what the test will expect to see diff --git a/t/lib/testinclude/DBICTestConfig.pm b/t/lib/testinclude/DBICTestConfig.pm index 10f0b7f..e531dc4 100644 --- a/t/lib/testinclude/DBICTestConfig.pm +++ b/t/lib/testinclude/DBICTestConfig.pm @@ -1,5 +1,9 @@ package DBICTestConfig; -use base 'DBIx::Class::Schema'; + +use warnings; +use strict; + +use base 'DBICTest::BaseSchema'; sub connect { my($self, @opt) = @_; diff --git a/t/multi_create/existing_in_chain.t b/t/multi_create/existing_in_chain.t index aa22503..292dd6b 100644 --- a/t/multi_create/existing_in_chain.t +++ b/t/multi_create/existing_in_chain.t @@ -28,35 +28,37 @@ my $schema = DBICTest->init_schema(); # # ribasushi -TODO: { my $f = __FILE__; local $TODO = "See comment at top of $f for discussion of the TODO"; +my $TODO_msg = "See comment at top of @{[ __FILE__ ]} for discussion of the TODO"; { my $counts; $counts->{$_} = $schema->resultset($_)->count for qw/Track CD Genre/; - lives_ok (sub { - my $existing_nogen_cd = $schema->resultset('CD')->search ( - { 'genre.genreid' => undef }, - { join => 'genre' }, - )->first; - - $schema->resultset('Track')->create ({ - title => 'Sugar-coated', - cd => { - title => $existing_nogen_cd->title, - genre => { - name => 'sugar genre', - } + my $existing_nogen_cd = $schema->resultset('CD')->search ( + { 'genre.genreid' => undef }, + { join => 'genre' }, + )->first; + + $schema->resultset('Track')->create ({ + title => 'Sugar-coated', + cd => { + title => $existing_nogen_cd->title, + genre => { + name => 'sugar genre', } - }); + } + }); - is ($schema->resultset('Track')->count, $counts->{Track} + 1, '1 new track'); - is ($schema->resultset('CD')->count, $counts->{CD}, 'No new cds'); - is ($schema->resultset('Genre')->count, $counts->{Genre} + 1, '1 new genre'); + is ($schema->resultset('Track')->count, $counts->{Track} + 1, '1 new track'); + is ($schema->resultset('CD')->count, $counts->{CD}, 'No new cds'); + TODO: { + todo_skip $TODO_msg, 1; + is ($schema->resultset('Genre')->count, $counts->{Genre} + 1, '1 new genre'); is ($existing_nogen_cd->genre->title, 'sugar genre', 'Correct genre assigned to CD'); - }, 'create() did not throw'); + } } + { my $counts; $counts->{$_} = $schema->resultset($_)->count for qw/Artist CD Producer/; @@ -89,6 +91,8 @@ TODO: { my $f = __FILE__; local $TODO = "See comment at top of $f for discussion is ($schema->resultset('Artist')->count, $counts->{Artist}, 'No new artists'); is ($schema->resultset('Producer')->count, $counts->{Producer} + 1, '1 new producers'); + + local $TODO = $TODO_msg; is ($schema->resultset('CD')->count, $counts->{CD} + 2, '2 new cds'); is ($producer->cds->count, 2, 'CDs assigned to correct producer'); @@ -100,6 +104,4 @@ TODO: { my $f = __FILE__; local $TODO = "See comment at top of $f for discussion }, 'create() did not throw'); } -} - done_testing; diff --git a/t/multi_create/reentrance_count.t b/t/multi_create/reentrance_count.t index c4649ed..4184f06 100644 --- a/t/multi_create/reentrance_count.t +++ b/t/multi_create/reentrance_count.t @@ -2,6 +2,10 @@ use strict; use warnings; use Test::More; +BEGIN { + plan skip_all => 'Disable test entirely until multicreate is rewritten in terms of subqueries'; +} + use Test::Exception; use lib qw(t/lib); use DBICTest; @@ -12,9 +16,6 @@ my $query_stats; $schema->storage->debugcb (sub { push @{$query_stats->{$_[0]}}, $_[1] }); $schema->storage->debug (1); -TODO: { - local $TODO = 'This is an optimization task, will wait... a while'; - lives_ok (sub { undef $query_stats; $schema->resultset('Artist')->create ({ @@ -173,6 +174,4 @@ lives_ok (sub { || $ENV{DBIC_MULTICREATE_DEBUG} && diag join "\n", @{$query_stats->{SELECT} || []}; }); -} - done_testing; diff --git a/t/ordered/cascade_delete.t b/t/ordered/cascade_delete.t index 45379a6..b6633c7 100644 --- a/t/ordered/cascade_delete.t +++ b/t/ordered/cascade_delete.t @@ -6,12 +6,8 @@ use Test::Exception; use lib qw(t/lib); use DBICTest; -use POSIX qw(ceil); - my $schema = DBICTest->init_schema(); -plan tests => 1; - { my $artist = $schema->resultset ('Artist')->search ({}, { rows => 1})->single; # braindead sqlite my $cd = $schema->resultset ('CD')->create ({ @@ -28,4 +24,4 @@ plan tests => 1; lives_ok (sub { $cd->delete}, "Cascade delete on ordered has_many doesn't bomb"); } -1; +done_testing; diff --git a/t/ordered/unordered_movement.t b/t/ordered/unordered_movement.t new file mode 100644 index 0000000..9cbc3da --- /dev/null +++ b/t/ordered/unordered_movement.t @@ -0,0 +1,27 @@ +use strict; +use warnings; + +use Test::More; +use Test::Exception; +use lib qw(t/lib); +use DBICTest; + +my $schema = DBICTest->init_schema(); + +my $cd = $schema->resultset('CD')->next; + +lives_ok { + $cd->tracks->delete; + + my @tracks = map + { $cd->create_related('tracks', { title => "t_$_", position => $_ }) } + (4,2,5,1,3) + ; + + for (@tracks) { + $_->discard_changes; + $_->delete; + } +} 'Creation/deletion of out-of order tracks successful'; + +done_testing; diff --git a/t/prefetch/attrs_untouched.t b/t/prefetch/attrs_untouched.t index be336e4..b2f25c3 100644 --- a/t/prefetch/attrs_untouched.t +++ b/t/prefetch/attrs_untouched.t @@ -1,4 +1,5 @@ use warnings; +use strict; use Test::More; use lib qw(t/lib); diff --git a/t/prefetch/count.t b/t/prefetch/count.t index ef2f88b..4311e80 100644 --- a/t/prefetch/count.t +++ b/t/prefetch/count.t @@ -78,7 +78,7 @@ is_same_sql_bind ( ); -TODO: { +{ local $TODO = "Chaining with prefetch is fundamentally broken"; my $queries; diff --git a/t/prefetch/double_prefetch.t b/t/prefetch/double_prefetch.t index efc9d2d..954e335 100644 --- a/t/prefetch/double_prefetch.t +++ b/t/prefetch/double_prefetch.t @@ -1,4 +1,5 @@ use warnings; +use strict; use Test::More; use lib qw(t/lib); diff --git a/t/prefetch/false_colvalues.t b/t/prefetch/false_colvalues.t new file mode 100644 index 0000000..b3b2ef6 --- /dev/null +++ b/t/prefetch/false_colvalues.t @@ -0,0 +1,64 @@ +use warnings; +use strict; + +use Test::More; + +use lib qw(t/lib); +use DBICTest; + +my $schema = DBICTest->init_schema( + no_populate => 1, +); + +$schema->resultset('CD')->create({ + cdid => 0, + artist => { + artistid => 0, + name => '', + rank => 0, + charfield => 0, + }, + title => '', + year => 0, + genreid => 0, + single_track => 0, +}); + +my $orig_debug = $schema->storage->debug; + +my $queries = 0; +$schema->storage->debugcb(sub { $queries++; }); +$schema->storage->debug(1); + +my $cd = $schema->resultset('CD')->search( {}, { prefetch => 'artist' })->next; + +is_deeply + { $cd->get_columns }, + { + artist => 0, + cdid => 0, + genreid => 0, + single_track => 0, + title => '', + year => 0, + }, + 'Expected CD columns present', +; + +is_deeply + { $cd->artist->get_columns }, + { + artistid => 0, + charfield => 0, + name => "", + rank => 0, + }, + 'Expected Artist columns present', +; + +is $queries, 1, 'Only one query fired - prefetch worked'; + +$schema->storage->debugcb(undef); +$schema->storage->debug($orig_debug); + +done_testing; diff --git a/t/prefetch/grouped.t b/t/prefetch/grouped.t index c50b7ef..760e381 100644 --- a/t/prefetch/grouped.t +++ b/t/prefetch/grouped.t @@ -294,7 +294,6 @@ for ($cd_rs->all) { FROM cd me JOIN artist artist ON artist.artistid = me.artist GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track - ORDER BY me.cdid ) me JOIN artist artist ON artist.artistid = me.artist ORDER BY me.cdid @@ -323,7 +322,6 @@ for ($cd_rs->all) { JOIN artist artist ON artist.artistid = me.artist WHERE ( tracks.title != ? ) GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track - ORDER BY me.cdid ) me LEFT JOIN track tracks ON tracks.cd = me.cdid JOIN artist artist ON artist.artistid = me.artist diff --git a/t/prefetch/incomplete.t b/t/prefetch/incomplete.t index 781c1e1..4cfbdfc 100644 --- a/t/prefetch/incomplete.t +++ b/t/prefetch/incomplete.t @@ -109,4 +109,19 @@ throws_ok( 'Sensible error message on mis-specified "as"', ); +# check complex limiting prefetch without the join-able columns +{ + my $pref_rs = $schema->resultset('Owners')->search({}, { + rows => 3, + offset => 1, + columns => 'name', # only the owner name, still prefetch all the books + prefetch => 'books', + }); + + lives_ok { + is ($pref_rs->all, 1, 'Expected count of objects on limtied prefetch') + } "Complex limited prefetch works with non-selected join condition"; +} + + done_testing; diff --git a/t/prefetch/join_type.t b/t/prefetch/join_type.t index 10a8783..aad32ff 100644 --- a/t/prefetch/join_type.t +++ b/t/prefetch/join_type.t @@ -1,4 +1,5 @@ use warnings; +use strict; use Test::More; use lib qw(t/lib); diff --git a/t/prefetch/o2m_o2m_order_by_with_limit.t b/t/prefetch/o2m_o2m_order_by_with_limit.t index 1a91e42..f7f71e5 100644 --- a/t/prefetch/o2m_o2m_order_by_with_limit.t +++ b/t/prefetch/o2m_o2m_order_by_with_limit.t @@ -69,7 +69,7 @@ is_same_sql_bind( # cds belong to the second and third artist, respectively, and there's no sixth # row is_deeply ( - [ $filtered_cd_rs->hri_dump ], + $filtered_cd_rs->all_hri, [ { 'artist' => '2', diff --git a/t/prefetch/undef_prefetch_bug.t b/t/prefetch/undef_prefetch_bug.t new file mode 100644 index 0000000..2304309 --- /dev/null +++ b/t/prefetch/undef_prefetch_bug.t @@ -0,0 +1,51 @@ +use strict; +use warnings; + +use Test::More; +use lib qw(t/lib); +use DBICTest; +use PrefetchBug; + +my $schema = PrefetchBug->connect( DBICTest->_database (quote_char => '"') ); +ok( $schema, 'Connected to PrefetchBug schema OK' ); + +$schema->storage->dbh->do(<<"EOF"); +CREATE TABLE prefetchbug_left ( + id INTEGER PRIMARY KEY +) +EOF + +$schema->storage->dbh->do(<<"EOF"); +CREATE TABLE prefetchbug_right ( + id INTEGER PRIMARY KEY, + name TEXT, + category TEXT, + description TEXT, + propagates INT, + locked INT +) +EOF + +$schema->storage->dbh->do(<<"EOF"); +CREATE TABLE prefetchbug_left_right ( + left_id INTEGER REFERENCES prefetchbug_left(id), + right_id INTEGER REFERENCES prefetchbug_right(id), + value TEXT, + PRIMARY KEY (left_id, right_id) +) +EOF + +# Test simple has_many prefetch: + +my $leftc = $schema->resultset('Left')->create({}); + +my $rightc = $schema->resultset('Right')->create({ id => 60, name => 'Johnny', category => 'something', description=> 'blah', propagates => 0, locked => 1 }); +$rightc->create_related('prefetch_leftright', { left => $leftc, value => 'lr' }); + +# start with fresh whatsit +my $left = $schema->resultset('Left')->find({ id => $leftc->id }); + +my @left_rights = $left->search_related('prefetch_leftright', {}, { prefetch => 'right' }); +ok(defined $left_rights[0]->right, 'Prefetched Right side correctly'); + +done_testing; diff --git a/t/prefetch/via_search_related.t b/t/prefetch/via_search_related.t index 1942c14..79826ba 100644 --- a/t/prefetch/via_search_related.t +++ b/t/prefetch/via_search_related.t @@ -128,9 +128,6 @@ lives_ok (sub { is($rs->all, 1, 'distinct with prefetch (objects)'); is($rs->count, 1, 'distinct with prefetch (count)'); - TODO: { - local $TODO = "This makes another 2 trips to the database, it can't be right"; - $queries = 0; $schema->storage->debugcb ($debugcb); $schema->storage->debug (1); @@ -139,12 +136,13 @@ lives_ok (sub { is($rs->search_related('cds')->all, 2, 'prefetched distinct with prefetch (objects)'); is($rs->search_related('cds')->count, 2, 'prefetched distinct with prefetch (count)'); - is ($queries, 0, 'No extra queries fired (prefetch survives search_related)'); + { + local $TODO = "This makes another 2 trips to the database, it can't be right"; + is ($queries, 0, 'No extra queries fired (prefetch survives search_related)'); + } $schema->storage->debugcb (undef); $schema->storage->debug ($orig_debug); - } - }, 'distinct generally works with prefetch on deep search_related chains'); done_testing; diff --git a/t/prefetch/with_limit.t b/t/prefetch/with_limit.t index 522324c..1d2aa84 100644 --- a/t/prefetch/with_limit.t +++ b/t/prefetch/with_limit.t @@ -183,7 +183,6 @@ is_same_sql_bind ( FROM cd me JOIN artist artist ON artist.artistid = me.artist WHERE ( ( artist.name = ? AND me.year = ? ) ) - ORDER BY me.cdid LIMIT ? ) me LEFT JOIN track tracks diff --git a/t/relationship/core.t b/t/relationship/core.t index 4f9cff0..96c5066 100644 --- a/t/relationship/core.t +++ b/t/relationship/core.t @@ -40,7 +40,7 @@ if ($INC{'DBICTest/HelperRels.pm'}) { year => 2005, } ); - TODO: { + { local $TODO = "Can't fix right now" if $DBIx::Class::VERSION < 0.09; lives_ok { $big_flop->genre} "Don't throw exception when col is not loaded after insert"; }; @@ -153,7 +153,7 @@ lives_ok( ); -TODO: { +{ local $TODO = "relationship checking needs fixing"; # try to add a bogus relationship using the wrong cols throws_ok { diff --git a/t/resultset/as_subselect_rs.t b/t/resultset/as_subselect_rs.t index 8644079..c0f8110 100644 --- a/t/resultset/as_subselect_rs.t +++ b/t/resultset/as_subselect_rs.t @@ -40,4 +40,35 @@ is_same_sql_bind ( 'Resultset-class attributes do not seep outside of the subselect', ); +$schema->storage->debug(1); + +is_same_sql_bind( + $schema->resultset('CD')->search ({}, { + rows => 2, + join => [ 'genre', { artist => 'cds' } ], + distinct => 1, + columns => { + title => 'me.title', + artist__name => 'artist.name', + genre__name => 'genre.name', + cds_for_artist => \ '(SELECT COUNT(*) FROM cds WHERE cd.artist = artist.id)', + }, + order_by => { -desc => 'me.year' }, + })->count_rs->as_query, + '( + SELECT COUNT( * ) + FROM ( + SELECT artist.name AS artist__name, (SELECT COUNT(*) FROM cds WHERE cd.artist = artist.id), genre.name AS genre__name, me.title, me.year + FROM cd me + LEFT JOIN genre genre + ON genre.genreid = me.genreid + JOIN artist artist ON artist.artistid = me.artist + GROUP BY artist.name, (SELECT COUNT(*) FROM cds WHERE cd.artist = artist.id), genre.name, me.title, me.year + LIMIT ? + ) me + )', + [ [{ sqlt_datatype => 'integer' } => 2 ] ], +); + + done_testing; diff --git a/t/resultset/bind_attr.t b/t/resultset/bind_attr.t index af97020..3d8d1cd 100644 --- a/t/resultset/bind_attr.t +++ b/t/resultset/bind_attr.t @@ -16,7 +16,7 @@ my $where_bind = { my $rs; -TODO: { +{ local $TODO = 'bind args order needs fixing (semifor)'; # First, the simple cases... @@ -36,6 +36,14 @@ TODO: { ->search({}, $where_bind); is ( $rs->count, 1, 'where/bind last' ); + + # and the complex case + local $TODO = 'bind args order needs fixing (semifor)'; + $rs = $schema->resultset('CustomSql')->search({}, { bind => [ 1999 ] }) + ->search({ 'artistid' => 1 }, { + where => \'title like ?', + bind => [ 'Spoon%' ] }); + is ( $rs->count, 1, '...cookbook + chained search with extra bind' ); } { @@ -107,13 +115,4 @@ TODO: { ); } -TODO: { - local $TODO = 'bind args order needs fixing (semifor)'; - $rs = $schema->resultset('Complex')->search({}, { bind => [ 1999 ] }) - ->search({ 'artistid' => 1 }, { - where => \'title like ?', - bind => [ 'Spoon%' ] }); - is ( $rs->count, 1, '...cookbook + chained search with extra bind' ); -} - done_testing; diff --git a/t/resultset/plus_select.t b/t/resultset/plus_select.t index 0d3be3c..4f082f5 100644 --- a/t/resultset/plus_select.t +++ b/t/resultset/plus_select.t @@ -20,7 +20,7 @@ my %basecols = $cd_rs->first->get_columns; # ramifications of changing this. Thus the value override and the # TODO to go with it. Delete all of this if ever resolved. my %todo_rel_inflation_override = ( artist => $basecols{artist} ); -TODO: { +{ local $TODO = 'Treating relationships as inflatable data is wrong - see comment in ' . __FILE__; ok (! keys %todo_rel_inflation_override); } diff --git a/t/resultset/update_delete.t b/t/resultset/update_delete.t index 3de8bdb..a5217ae 100644 --- a/t/resultset/update_delete.t +++ b/t/resultset/update_delete.t @@ -4,6 +4,13 @@ use warnings; use lib qw(t/lib); use Test::More; use Test::Exception; + +use DBICTest::Schema::CD; +BEGIN { + # the default scalarref table name will not work well for this test + DBICTest::Schema::CD->table('cd'); +} + use DBICTest; use DBIC::DebugObj; use DBIC::SqlMakerTest; @@ -17,10 +24,11 @@ my $orig_debug = $schema->storage->debug; my $tkfks = $schema->resultset('FourKeys_to_TwoKeys'); -my ($fa, $fb) = $tkfks->related_resultset ('fourkeys')->populate ([ +my ($fa, $fb, $fc) = $tkfks->related_resultset ('fourkeys')->populate ([ [qw/foo bar hello goodbye sensors read_count/], [qw/1 1 1 1 a 10 /], [qw/2 2 2 2 b 20 /], + [qw/1 1 1 2 c 30 /], ]); # This is already provided by DBICTest @@ -48,8 +56,12 @@ is ($tkfks->count, $tkfk_cnt += 4, 'FourKeys_to_TwoKeys populated succesfully'); # # create a resultset matching $fa and $fb only -my $fks = $schema->resultset ('FourKeys') - ->search ({ map { $_ => [1, 2] } qw/foo bar hello goodbye/}, { join => 'fourkeys_to_twokeys' }); +my $fks = $schema->resultset ('FourKeys')->search ( + { + sensors => { '!=', 'c' }, + ( map { $_ => [1, 2] } qw/foo bar hello goodbye/ ), + }, { join => 'fourkeys_to_twokeys'} +); is ($fks->count, 4, 'Joined FourKey count correct (2x2)'); @@ -64,19 +76,45 @@ is_same_sql_bind ( \@bind, 'UPDATE fourkeys SET read_count = read_count + 1 + WHERE ( ( ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) AND sensors != ? ) ) + ', + [ ("'1'", "'2'") x 4, "'c'" ], + 'Correct update-SQL with multijoin with pruning', +); + +is ($fa->discard_changes->read_count, 11, 'Update ran only once on discard-join resultset'); +is ($fb->discard_changes->read_count, 21, 'Update ran only once on discard-join resultset'); +is ($fc->discard_changes->read_count, 30, 'Update did not touch outlier'); + +# make the multi-join stick +$fks = $fks->search({ 'fourkeys_to_twokeys.pilot_sequence' => { '!=' => 666 } }); + +$schema->storage->debugobj ($debugobj); +$schema->storage->debug (1); +$fks->update ({ read_count => \ 'read_count + 1' }); +$schema->storage->debugobj ($orig_debugobj); +$schema->storage->debug ($orig_debug); + +is_same_sql_bind ( + $sql, + \@bind, + 'UPDATE fourkeys + SET read_count = read_count + 1 WHERE ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? ) OR ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? )', [ map { "'$_'" } ( (1) x 4, (2) x 4 ) ], - 'Correct update-SQL without multicolumn in support', + 'Correct update-SQL with multijoin without pruning', ); -is ($fa->discard_changes->read_count, 11, 'Update ran only once on joined resultset'); -is ($fb->discard_changes->read_count, 21, 'Update ran only once on joined resultset'); +is ($fa->discard_changes->read_count, 12, 'Update ran only once on joined resultset'); +is ($fb->discard_changes->read_count, 22, 'Update ran only once on joined resultset'); +is ($fc->discard_changes->read_count, 30, 'Update did not touch outlier'); # try the same sql with forced multicolumn in $schema->storage->_use_multicolumn_in (1); $schema->storage->debugobj ($debugobj); $schema->storage->debug (1); -eval { $fks->update ({ read_count => \ 'read_count + 1' }) }; # this can't actually execute, we just need the "as_query" +throws_ok { $fks->update ({ read_count => \ 'read_count + 1' }) } # this can't actually execute, we just need the "as_query" + qr/\Q DBI Exception:/ or do { $sql = ''; @bind = () }; $schema->storage->_use_multicolumn_in (undef); $schema->storage->debugobj ($orig_debugobj); $schema->storage->debug ($orig_debug); @@ -90,11 +128,20 @@ is_same_sql_bind ( (foo, bar, hello, goodbye) IN ( SELECT me.foo, me.bar, me.hello, me.goodbye FROM fourkeys me - WHERE ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) + LEFT JOIN fourkeys_to_twokeys fourkeys_to_twokeys ON + fourkeys_to_twokeys.f_bar = me.bar + AND fourkeys_to_twokeys.f_foo = me.foo + AND fourkeys_to_twokeys.f_goodbye = me.goodbye + AND fourkeys_to_twokeys.f_hello = me.hello + WHERE fourkeys_to_twokeys.pilot_sequence != ? AND ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? ) AND sensors != ? ) ) ', - [ map { "'$_'" } ( (1, 2) x 4 ) ], + [ + "'666'", + ("'1'", "'2'") x 4, + "'c'", + ], 'Correct update-SQL with multicolumn in support', ); @@ -180,24 +227,98 @@ $tkfks->search ({}, { rows => 1 })->delete; is ($tkfks->count, $tkfk_cnt -= 1, 'Only one row deleted'); -# Make sure prefetch is properly stripped too -# check with sql-equality, as sqlite will accept bad sql just fine +# check with sql-equality, as sqlite will accept most bad sql just fine $schema->storage->debugobj ($debugobj); $schema->storage->debug (1); -$schema->resultset('CD')->search( - { year => { '!=' => 2010 } }, - { prefetch => 'liner_notes' }, -)->delete; + +{ + my $rs = $schema->resultset('CD')->search( + { 'me.year' => { '!=' => 2010 } }, + ); + + $rs->search({}, { join => 'liner_notes' })->delete; + is_same_sql_bind ( + $sql, + \@bind, + 'DELETE FROM cd WHERE ( year != ? )', + ["'2010'"], + 'Non-restricting multijoins properly thrown out' + ); + + $rs->search({}, { prefetch => 'liner_notes' })->delete; + is_same_sql_bind ( + $sql, + \@bind, + 'DELETE FROM cd WHERE ( year != ? )', + ["'2010'"], + 'Non-restricting multiprefetch thrown out' + ); + + $rs->search({}, { prefetch => 'artist' })->delete; + is_same_sql_bind ( + $sql, + \@bind, + 'DELETE FROM cd WHERE ( cdid IN ( SELECT me.cdid FROM cd me JOIN artist artist ON artist.artistid = me.artist WHERE ( me.year != ? ) ) )', + ["'2010'"], + 'Restricting prefetch left in, selector thrown out' + ); + + $rs->result_source->name('schema_qualified.cd'); + # this is expected to fail - we only want to collect the generated SQL + eval { $rs->delete }; + is_same_sql_bind ( + $sql, + \@bind, + 'DELETE FROM schema_qualified.cd WHERE ( year != ? )', + ["'2010'"], + 'delete with fully qualified table name and subquery correct' + ); + + # this is expected to fail - we only want to collect the generated SQL + eval { $rs->search({}, { prefetch => 'artist' })->delete }; + is_same_sql_bind ( + $sql, + \@bind, + 'DELETE FROM schema_qualified.cd WHERE ( cdid IN ( SELECT me.cdid FROM schema_qualified.cd me JOIN artist artist ON artist.artistid = me.artist WHERE ( me.year != ? ) ) )', + ["'2010'"], + 'delete with fully qualified table name and subquery correct' + ); + + $rs->result_source->name('cd'); + + # check that as_subselect_rs works ok + # inner query is untouched, then a selector + # and an IN condition + $schema->resultset('CD')->search({ + 'me.cdid' => 1, + 'artist.name' => 'partytimecity', + }, { + join => 'artist', + })->as_subselect_rs->delete; + + is_same_sql_bind ( + $sql, + \@bind, + ' + DELETE FROM cd + WHERE ( + cdid IN ( + SELECT me.cdid + FROM ( + SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track + FROM cd me + JOIN artist artist ON artist.artistid = me.artist + WHERE artist.name = ? AND me.cdid = ? + ) me + ) + ) + ', + ["'partytimecity'", "'1'"], + 'Delete from as_subselect_rs works correctly' + ); +} $schema->storage->debugobj ($orig_debugobj); $schema->storage->debug ($orig_debug); -is_same_sql_bind ( - $sql, - \@bind, - 'DELETE FROM cd WHERE ( cdid IN ( SELECT me.cdid FROM cd me WHERE ( year != ? ) ) )', - ["'2010'"], - 'Update on prefetching resultset strips prefetch correctly' -); - done_testing; diff --git a/t/row/inflate_result.t b/t/row/inflate_result.t index b020ab5..3327b70 100644 --- a/t/row/inflate_result.t +++ b/t/row/inflate_result.t @@ -86,13 +86,14 @@ ok( ) ); -TODO: { - local $TODO = 'New objects should also be inflated'; - my $user = $schema->resultset('User')->create($user_data); - my $admin = $schema->resultset('User')->create($admin_data); +{ + my $user = $schema->resultset('User')->create($user_data); + my $admin = $schema->resultset('User')->create($admin_data); - is( ref $user, 'My::Schema::Result::User' ); - is( ref $admin, 'My::Schema::Result::User::Admin' ); + is( ref $user, 'My::Schema::Result::User' ); + + local $TODO = 'New objects should also be inflated'; + is( ref $admin, 'My::Schema::Result::User::Admin' ); } my $user = $schema->resultset('User')->single($user_data); diff --git a/t/sqlmaker/core.t b/t/sqlmaker/core.t index 2cf88ba..7312c98 100644 --- a/t/sqlmaker/core.t +++ b/t/sqlmaker/core.t @@ -69,6 +69,36 @@ my $sql_maker = $schema->storage->sql_maker; ); } +# Tests base class for => \'FOO' actually generates proper query. for => +# 'READ'|'SHARE' is tested in db-specific subclasses +# we have to instantiate base because SQLMaker::SQLite disables _lock_select +{ + require DBIx::Class::SQLMaker; + my $sa = DBIx::Class::SQLMaker->new; + { + my ($sql, @bind) = $sa->select('foo', '*', {}, { for => 'update' } ); + is_same_sql_bind( + $sql, + \@bind, + 'SELECT * FROM foo FOR UPDATE', + [], + ); + } + + { + my ($sql, @bind) = $sa->select('bar', '*', {}, { for => \'baz' } ); + is_same_sql_bind( + $sql, + \@bind, + 'SELECT * FROM bar FOR baz', + [], + ); + } + +} + + + # Make sure the carp/croak override in SQLA works (via SQLMaker) my $file = quotemeta (__FILE__); throws_ok (sub { diff --git a/t/sqlmaker/limit_dialects/custom.t b/t/sqlmaker/limit_dialects/custom.t index 650cd99..1bf3e07 100644 --- a/t/sqlmaker/limit_dialects/custom.t +++ b/t/sqlmaker/limit_dialects/custom.t @@ -2,6 +2,7 @@ use strict; use warnings; use Test::More; +use Test::Warn; use lib qw(t/lib); use DBICTest; @@ -27,7 +28,8 @@ my $s = DBICTest::Schema->connect (DBICTest->_database); $s->storage->sql_maker_class ('DBICTest::SQLMaker::CustomDialect'); my $rs = $s->resultset ('CD'); -is_same_sql_bind ( + +warnings_exist { is_same_sql_bind ( $rs->search ({}, { rows => 1, offset => 3,columns => [ { id => 'foo.id' }, { 'bar.id' => 'bar.id' }, @@ -45,6 +47,9 @@ is_same_sql_bind ( )', [], 'Rownum subsel aliasing works correctly' -); + )} + qr/\Qthe legacy emulate_limit() mechanism inherited from SQL::Abstract::Limit has been deprecated/, + 'deprecation warning' +; done_testing; diff --git a/t/sqlmaker/limit_dialects/fetch_first.t b/t/sqlmaker/limit_dialects/fetch_first.t index 8c7fa47..302201c 100644 --- a/t/sqlmaker/limit_dialects/fetch_first.t +++ b/t/sqlmaker/limit_dialects/fetch_first.t @@ -49,58 +49,58 @@ for my $ord_set ( { order_by => \'title DESC', order_inner => 'title DESC', - order_outer => 'ORDER__BY__1 ASC', - order_req => 'ORDER__BY__1 DESC', - exselect_outer => 'ORDER__BY__1', - exselect_inner => 'title AS ORDER__BY__1', + order_outer => 'ORDER__BY__001 ASC', + order_req => 'ORDER__BY__001 DESC', + exselect_outer => 'ORDER__BY__001', + exselect_inner => 'title AS ORDER__BY__001', }, { order_by => { -asc => 'title' }, order_inner => 'title ASC', - order_outer => 'ORDER__BY__1 DESC', - order_req => 'ORDER__BY__1 ASC', - exselect_outer => 'ORDER__BY__1', - exselect_inner => 'title AS ORDER__BY__1', + order_outer => 'ORDER__BY__001 DESC', + order_req => 'ORDER__BY__001 ASC', + exselect_outer => 'ORDER__BY__001', + exselect_inner => 'title AS ORDER__BY__001', }, { order_by => { -desc => 'title' }, order_inner => 'title DESC', - order_outer => 'ORDER__BY__1 ASC', - order_req => 'ORDER__BY__1 DESC', - exselect_outer => 'ORDER__BY__1', - exselect_inner => 'title AS ORDER__BY__1', + order_outer => 'ORDER__BY__001 ASC', + order_req => 'ORDER__BY__001 DESC', + exselect_outer => 'ORDER__BY__001', + exselect_inner => 'title AS ORDER__BY__001', }, { order_by => 'title', order_inner => 'title', - order_outer => 'ORDER__BY__1 DESC', - order_req => 'ORDER__BY__1', - exselect_outer => 'ORDER__BY__1', - exselect_inner => 'title AS ORDER__BY__1', + order_outer => 'ORDER__BY__001 DESC', + order_req => 'ORDER__BY__001', + exselect_outer => 'ORDER__BY__001', + exselect_inner => 'title AS ORDER__BY__001', }, { order_by => [ qw{ title me.owner} ], order_inner => 'title, me.owner', - order_outer => 'ORDER__BY__1 DESC, me.owner DESC', - order_req => 'ORDER__BY__1, me.owner', - exselect_outer => 'ORDER__BY__1', - exselect_inner => 'title AS ORDER__BY__1', + order_outer => 'ORDER__BY__001 DESC, me.owner DESC', + order_req => 'ORDER__BY__001, me.owner', + exselect_outer => 'ORDER__BY__001', + exselect_inner => 'title AS ORDER__BY__001', }, { order_by => ['title', { -desc => 'bar' } ], order_inner => 'title, bar DESC', - order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 ASC', - order_req => 'ORDER__BY__1, ORDER__BY__2 DESC', - exselect_outer => 'ORDER__BY__1, ORDER__BY__2', - exselect_inner => 'title AS ORDER__BY__1, bar AS ORDER__BY__2', + order_outer => 'ORDER__BY__001 DESC, ORDER__BY__002 ASC', + order_req => 'ORDER__BY__001, ORDER__BY__002 DESC', + exselect_outer => 'ORDER__BY__001, ORDER__BY__002', + exselect_inner => 'title AS ORDER__BY__001, bar AS ORDER__BY__002', }, { order_by => { -asc => [qw{ title bar }] }, order_inner => 'title ASC, bar ASC', - order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 DESC', - order_req => 'ORDER__BY__1 ASC, ORDER__BY__2 ASC', - exselect_outer => 'ORDER__BY__1, ORDER__BY__2', - exselect_inner => 'title AS ORDER__BY__1, bar AS ORDER__BY__2', + order_outer => 'ORDER__BY__001 DESC, ORDER__BY__002 DESC', + order_req => 'ORDER__BY__001 ASC, ORDER__BY__002 ASC', + exselect_outer => 'ORDER__BY__001, ORDER__BY__002', + exselect_inner => 'title AS ORDER__BY__001, bar AS ORDER__BY__002', }, { order_by => [ @@ -109,10 +109,10 @@ for my $ord_set ( { -asc => [qw{me.owner sensors}]}, ], order_inner => 'title, bar DESC, me.owner ASC, sensors ASC', - order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 ASC, me.owner DESC, ORDER__BY__3 DESC', - order_req => 'ORDER__BY__1, ORDER__BY__2 DESC, me.owner ASC, ORDER__BY__3 ASC', - exselect_outer => 'ORDER__BY__1, ORDER__BY__2, ORDER__BY__3', - exselect_inner => 'title AS ORDER__BY__1, bar AS ORDER__BY__2, sensors AS ORDER__BY__3', + order_outer => 'ORDER__BY__001 DESC, ORDER__BY__002 ASC, me.owner DESC, ORDER__BY__003 DESC', + order_req => 'ORDER__BY__001, ORDER__BY__002 DESC, me.owner ASC, ORDER__BY__003 ASC', + exselect_outer => 'ORDER__BY__001, ORDER__BY__002, ORDER__BY__003', + exselect_inner => 'title AS ORDER__BY__001, bar AS ORDER__BY__002, sensors AS ORDER__BY__003', }, ) { my $o_sel = $ord_set->{exselect_outer} @@ -152,11 +152,11 @@ is_same_sql_bind ( $books_45_and_owners->search ({}, { group_by => 'title', order_by => 'title' })->as_query, '(SELECT me.id, me.source, me.owner, me.price, owner.id, owner.name FROM ( - SELECT me.id, me.source, me.owner, me.price, ORDER__BY__1 AS title + SELECT me.id, me.source, me.owner, me.price FROM ( - SELECT me.id, me.source, me.owner, me.price, ORDER__BY__1 + SELECT me.id, me.source, me.owner, me.price, ORDER__BY__001 FROM ( - SELECT me.id, me.source, me.owner, me.price, title AS ORDER__BY__1 + SELECT me.id, me.source, me.owner, me.price, title AS ORDER__BY__001 FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) @@ -164,10 +164,10 @@ is_same_sql_bind ( ORDER BY title FETCH FIRST 5 ROWS ONLY ) me - ORDER BY ORDER__BY__1 DESC + ORDER BY ORDER__BY__001 DESC FETCH FIRST 2 ROWS ONLY ) me - ORDER BY ORDER__BY__1 + ORDER BY ORDER__BY__001 ) me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) diff --git a/t/sqlmaker/limit_dialects/rno.t b/t/sqlmaker/limit_dialects/rno.t index 4f24e56..32f67c5 100644 --- a/t/sqlmaker/limit_dialects/rno.t +++ b/t/sqlmaker/limit_dialects/rno.t @@ -101,23 +101,17 @@ my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search ({}, { order_by => 'me.id', }); -# SELECT [owner_name], [owner_books] FROM ( -# SELECT [owner_name], [owner_books], [ORDER__BY__1], ROW_NUMBER() OVER( ORDER BY [ORDER__BY__1] ) AS [rno__row__index] FROM ( -# SELECT [owner].[name] AS [owner_name], (SELECT COUNT( * ) FROM [owners] [owner] WHERE ( ( [count].[id] = [owner].[id] AND [count].[name] = ? ) )) AS [owner_books], [me].[id] AS [ORDER__BY__1] FROM [books] [me] JOIN [owners] [owner] ON [owner].[id] = [me].[owner] WHERE ( [source] = ? ) -# ) [me] -# ) [me] WHERE [rno__row__index] >= ? AND [rno__row__index] <= ? - is_same_sql_bind( $rs_selectas_rel->as_query, '( SELECT [owner_name], [owner_books] FROM ( - SELECT [owner_name], [owner_books], ROW_NUMBER() OVER( ORDER BY [ORDER__BY__1] ) AS [rno__row__index] + SELECT [owner_name], [owner_books], ROW_NUMBER() OVER( ORDER BY [ORDER__BY__001] ) AS [rno__row__index] FROM ( SELECT [owner].[name] AS [owner_name], ( SELECT COUNT( * ) FROM [owners] [owner] WHERE [count].[id] = [owner].[id] and [count].[name] = ? ) AS [owner_books], - [me].[id] AS [ORDER__BY__1] + [me].[id] AS [ORDER__BY__001] FROM [books] [me] JOIN [owners] [owner] ON [owner].[id] = [me].[owner] WHERE ( [source] = ? ) diff --git a/t/sqlmaker/limit_dialects/toplimit.t b/t/sqlmaker/limit_dialects/toplimit.t index 2f86103..11f4c08 100644 --- a/t/sqlmaker/limit_dialects/toplimit.t +++ b/t/sqlmaker/limit_dialects/toplimit.t @@ -89,58 +89,58 @@ for my $ord_set ( { order_by => \'title DESC', order_inner => 'title DESC', - order_outer => 'ORDER__BY__1 ASC', - order_req => 'ORDER__BY__1 DESC', - exselect_outer => 'ORDER__BY__1', - exselect_inner => 'title AS ORDER__BY__1', + order_outer => 'ORDER__BY__001 ASC', + order_req => 'ORDER__BY__001 DESC', + exselect_outer => 'ORDER__BY__001', + exselect_inner => 'title AS ORDER__BY__001', }, { order_by => { -asc => 'title' }, order_inner => 'title ASC', - order_outer => 'ORDER__BY__1 DESC', - order_req => 'ORDER__BY__1 ASC', - exselect_outer => 'ORDER__BY__1', - exselect_inner => 'title AS ORDER__BY__1', + order_outer => 'ORDER__BY__001 DESC', + order_req => 'ORDER__BY__001 ASC', + exselect_outer => 'ORDER__BY__001', + exselect_inner => 'title AS ORDER__BY__001', }, { order_by => { -desc => 'title' }, order_inner => 'title DESC', - order_outer => 'ORDER__BY__1 ASC', - order_req => 'ORDER__BY__1 DESC', - exselect_outer => 'ORDER__BY__1', - exselect_inner => 'title AS ORDER__BY__1', + order_outer => 'ORDER__BY__001 ASC', + order_req => 'ORDER__BY__001 DESC', + exselect_outer => 'ORDER__BY__001', + exselect_inner => 'title AS ORDER__BY__001', }, { order_by => 'title', order_inner => 'title', - order_outer => 'ORDER__BY__1 DESC', - order_req => 'ORDER__BY__1', - exselect_outer => 'ORDER__BY__1', - exselect_inner => 'title AS ORDER__BY__1', + order_outer => 'ORDER__BY__001 DESC', + order_req => 'ORDER__BY__001', + exselect_outer => 'ORDER__BY__001', + exselect_inner => 'title AS ORDER__BY__001', }, { order_by => [ qw{ title me.owner} ], order_inner => 'title, me.owner', - order_outer => 'ORDER__BY__1 DESC, me.owner DESC', - order_req => 'ORDER__BY__1, me.owner', - exselect_outer => 'ORDER__BY__1', - exselect_inner => 'title AS ORDER__BY__1', + order_outer => 'ORDER__BY__001 DESC, me.owner DESC', + order_req => 'ORDER__BY__001, me.owner', + exselect_outer => 'ORDER__BY__001', + exselect_inner => 'title AS ORDER__BY__001', }, { order_by => ['title', { -desc => 'bar' } ], order_inner => 'title, bar DESC', - order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 ASC', - order_req => 'ORDER__BY__1, ORDER__BY__2 DESC', - exselect_outer => 'ORDER__BY__1, ORDER__BY__2', - exselect_inner => 'title AS ORDER__BY__1, bar AS ORDER__BY__2', + order_outer => 'ORDER__BY__001 DESC, ORDER__BY__002 ASC', + order_req => 'ORDER__BY__001, ORDER__BY__002 DESC', + exselect_outer => 'ORDER__BY__001, ORDER__BY__002', + exselect_inner => 'title AS ORDER__BY__001, bar AS ORDER__BY__002', }, { order_by => { -asc => [qw{ title bar }] }, order_inner => 'title ASC, bar ASC', - order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 DESC', - order_req => 'ORDER__BY__1 ASC, ORDER__BY__2 ASC', - exselect_outer => 'ORDER__BY__1, ORDER__BY__2', - exselect_inner => 'title AS ORDER__BY__1, bar AS ORDER__BY__2', + order_outer => 'ORDER__BY__001 DESC, ORDER__BY__002 DESC', + order_req => 'ORDER__BY__001 ASC, ORDER__BY__002 ASC', + exselect_outer => 'ORDER__BY__001, ORDER__BY__002', + exselect_inner => 'title AS ORDER__BY__001, bar AS ORDER__BY__002', }, { order_by => [ @@ -149,10 +149,10 @@ for my $ord_set ( { -asc => [qw{me.owner sensors}]}, ], order_inner => 'title, bar DESC, me.owner ASC, sensors ASC', - order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 ASC, me.owner DESC, ORDER__BY__3 DESC', - order_req => 'ORDER__BY__1, ORDER__BY__2 DESC, me.owner ASC, ORDER__BY__3 ASC', - exselect_outer => 'ORDER__BY__1, ORDER__BY__2, ORDER__BY__3', - exselect_inner => 'title AS ORDER__BY__1, bar AS ORDER__BY__2, sensors AS ORDER__BY__3', + order_outer => 'ORDER__BY__001 DESC, ORDER__BY__002 ASC, me.owner DESC, ORDER__BY__003 DESC', + order_req => 'ORDER__BY__001, ORDER__BY__002 DESC, me.owner ASC, ORDER__BY__003 ASC', + exselect_outer => 'ORDER__BY__001, ORDER__BY__002, ORDER__BY__003', + exselect_inner => 'title AS ORDER__BY__001, bar AS ORDER__BY__002, sensors AS ORDER__BY__003', }, ) { my $o_sel = $ord_set->{exselect_outer} @@ -192,22 +192,22 @@ is_same_sql_bind ( $books_45_and_owners->search ({}, { group_by => 'title', order_by => 'title' })->as_query, '(SELECT me.id, me.source, me.owner, me.price, owner.id, owner.name FROM ( - SELECT me.id, me.source, me.owner, me.price, ORDER__BY__1 AS title + SELECT me.id, me.source, me.owner, me.price FROM ( SELECT TOP 2 - me.id, me.source, me.owner, me.price, ORDER__BY__1 + me.id, me.source, me.owner, me.price, ORDER__BY__001 FROM ( SELECT TOP 5 - me.id, me.source, me.owner, me.price, title AS ORDER__BY__1 + me.id, me.source, me.owner, me.price, title AS ORDER__BY__001 FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) GROUP BY title ORDER BY title ) me - ORDER BY ORDER__BY__1 DESC + ORDER BY ORDER__BY__001 DESC ) me - ORDER BY ORDER__BY__1 + ORDER BY ORDER__BY__001 ) me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) diff --git a/t/sqlmaker/limit_dialects/torture.t b/t/sqlmaker/limit_dialects/torture.t index 7bb116b..3b72154 100644 --- a/t/sqlmaker/limit_dialects/torture.t +++ b/t/sqlmaker/limit_dialects/torture.t @@ -2,11 +2,13 @@ use strict; use warnings; use Test::More; +use Test::Exception; use lib qw(t/lib); use DBICTest; use DBIC::SqlMakerTest; my $schema = DBICTest->init_schema; +my $native_limit_dialect = $schema->storage->sql_maker->{limit_dialect}; my $attr = {}; my @where_bind = ( @@ -53,6 +55,23 @@ my $tests = { [ { sqlt_datatype => 'integer' } => 3 ], ], ], + limit_offset_prefetch => [ + '( + SELECT me.name, books.id, books.source, books.owner, books.title, books.price + FROM ( + SELECT me.name, me.id + FROM owners me + LIMIT ? OFFSET ? + ) me + LEFT JOIN books books + ON books.owner = me.id + ORDER BY me.id + )', + [ + [ { sqlt_datatype => 'integer' } => 3 ], + [ { sqlt_datatype => 'integer' } => 1 ], + ] + ], }, LimitXY => { @@ -78,6 +97,23 @@ my $tests = { [ { sqlt_datatype => 'integer' } => 4 ], ], ], + limit_offset_prefetch => [ + '( + SELECT me.name, books.id, books.source, books.owner, books.title, books.price + FROM ( + SELECT me.name, me.id + FROM owners me + LIMIT ?,? + ) me + LEFT JOIN books books + ON books.owner = me.id + ORDER BY me.id + )', + [ + [ { sqlt_datatype => 'integer' } => 1 ], + [ { sqlt_datatype => 'integer' } => 3 ], + ] + ], }, SkipFirst => { @@ -102,6 +138,22 @@ my $tests = { @order_bind, ], ], + limit_offset_prefetch => [ + '( + SELECT me.name, books.id, books.source, books.owner, books.title, books.price + FROM ( + SELECT SKIP ? FIRST ? me.name, me.id + FROM owners me + ) me + LEFT JOIN books books + ON books.owner = me.id + ORDER BY me.id + )', + [ + [ { sqlt_datatype => 'integer' } => 1 ], + [ { sqlt_datatype => 'integer' } => 3 ], + ] + ], }, FirstSkip => { @@ -126,6 +178,22 @@ my $tests = { @order_bind, ], ], + limit_offset_prefetch => [ + '( + SELECT me.name, books.id, books.source, books.owner, books.title, books.price + FROM ( + SELECT FIRST ? SKIP ? me.name, me.id + FROM owners me + ) me + LEFT JOIN books books + ON books.owner = me.id + ORDER BY me.id + )', + [ + [ { sqlt_datatype => 'integer' } => 3 ], + [ { sqlt_datatype => 'integer' } => 1 ], + ] + ], }, RowNumberOver => do { @@ -149,10 +217,10 @@ my $tests = { my $ordered_sql = '( SELECT me.id, owner__id, owner__name, bar, baz FROM ( - SELECT me.id, owner__id, owner__name, bar, baz, ROW_NUMBER() OVER( ORDER BY ORDER__BY__1, ORDER__BY__2 ) AS rno__row__index + SELECT me.id, owner__id, owner__name, bar, baz, ROW_NUMBER() OVER( ORDER BY ORDER__BY__001, ORDER__BY__002 ) AS rno__row__index FROM ( SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz, - ? / ? AS ORDER__BY__1, ? AS ORDER__BY__2 + ? / ? AS ORDER__BY__001, ? AS ORDER__BY__002 FROM books me JOIN owners owner ON owner.id = me.owner @@ -207,6 +275,28 @@ my $tests = { [ { sqlt_datatype => 'integer' } => 7 ], ], ], + limit_offset_prefetch => [ + '( + SELECT me.name, books.id, books.source, books.owner, books.title, books.price + FROM ( + SELECT me.name, me.id + FROM ( + SELECT me.name, me.id, ROW_NUMBER() OVER() AS rno__row__index + FROM ( + SELECT me.name, me.id FROM owners me + ) me + ) me + WHERE rno__row__index >= ? AND rno__row__index <= ? + ) me + LEFT JOIN books books + ON books.owner = me.id + ORDER BY me.id + )', + [ + [ { sqlt_datatype => 'integer' } => 2 ], + [ { sqlt_datatype => 'integer' } => 4 ], + ] + ], }; }, @@ -303,6 +393,28 @@ my $tests = { [ { sqlt_datatype => 'integer' } => 4 ], ], ], + limit_offset_prefetch => [ + '( + SELECT me.name, books.id, books.source, books.owner, books.title, books.price + FROM ( + SELECT me.name, me.id + FROM ( + SELECT me.name, me.id, ROWNUM rownum__index + FROM ( + SELECT me.name, me.id + FROM owners me + ) me + ) me WHERE rownum__index BETWEEN ? AND ? + ) me + LEFT JOIN books books + ON books.owner = me.id + ORDER BY me.id + )', + [ + [ { sqlt_datatype => 'integer' } => 2 ], + [ { sqlt_datatype => 'integer' } => 4 ], + ] + ], }; }, @@ -373,9 +485,9 @@ my $tests = { '( SELECT me.id, owner__id, owner__name, bar, baz FROM ( - SELECT me.id, owner__id, owner__name, bar, baz, ORDER__BY__1, ORDER__BY__2 + SELECT me.id, owner__id, owner__name, bar, baz, ORDER__BY__001, ORDER__BY__002 FROM ( - SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz, ? / ? AS ORDER__BY__1, ? AS ORDER__BY__2 + SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz, ? / ? AS ORDER__BY__001, ? AS ORDER__BY__002 FROM books me JOIN owners owner ON owner.id = me.owner @@ -385,10 +497,10 @@ my $tests = { ORDER BY ? / ?, ? FETCH FIRST 7 ROWS ONLY ) me - ORDER BY ORDER__BY__1 DESC, ORDER__BY__2 DESC + ORDER BY ORDER__BY__001 DESC, ORDER__BY__002 DESC FETCH FIRST 4 ROWS ONLY ) me - ORDER BY ORDER__BY__1, ORDER__BY__2 + ORDER BY ORDER__BY__001, ORDER__BY__002 )', [ @select_bind, @@ -399,6 +511,26 @@ my $tests = { (map { [ @$_ ] } @order_bind), # without this is_deeply throws a fit ], ], + limit_offset_prefetch => [ + '( + SELECT me.name, books.id, books.source, books.owner, books.title, books.price + FROM ( + SELECT me.name, me.id + FROM ( + SELECT me.name, me.id + FROM owners me + ORDER BY me.id + FETCH FIRST 4 ROWS ONLY + ) me + ORDER BY me.id DESC + FETCH FIRST 3 ROWS ONLY + ) me + LEFT JOIN books books + ON books.owner = me.id + ORDER BY me.id + )', + [], + ], }, Top => { @@ -464,9 +596,9 @@ my $tests = { '( SELECT me.id, owner__id, owner__name, bar, baz FROM ( - SELECT TOP 4 me.id, owner__id, owner__name, bar, baz, ORDER__BY__1, ORDER__BY__2 + SELECT TOP 4 me.id, owner__id, owner__name, bar, baz, ORDER__BY__001, ORDER__BY__002 FROM ( - SELECT TOP 7 me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz, ? / ? AS ORDER__BY__1, ? AS ORDER__BY__2 + SELECT TOP 7 me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz, ? / ? AS ORDER__BY__001, ? AS ORDER__BY__002 FROM books me JOIN owners owner ON owner.id = me.owner @@ -475,9 +607,9 @@ my $tests = { HAVING ? ORDER BY ? / ?, ? ) me - ORDER BY ORDER__BY__1 DESC, ORDER__BY__2 DESC + ORDER BY ORDER__BY__001 DESC, ORDER__BY__002 DESC ) me - ORDER BY ORDER__BY__1, ORDER__BY__2 + ORDER BY ORDER__BY__001, ORDER__BY__002 )', [ @select_bind, @@ -488,6 +620,24 @@ my $tests = { (map { [ @$_ ] } @order_bind), # without this is_deeply throws a fit ], ], + limit_offset_prefetch => [ + '( + SELECT me.name, books.id, books.source, books.owner, books.title, books.price + FROM ( + SELECT TOP 3 me.name, me.id + FROM ( + SELECT TOP 4 me.name, me.id + FROM owners me + ORDER BY me.id + ) me + ORDER BY me.id DESC + ) me + LEFT JOIN books books + ON books.owner = me.id + ORDER BY me.id + )', + [], + ], }, RowCountOrGenericSubQ => { @@ -597,6 +747,30 @@ my $tests = { [ { sqlt_datatype => 'integer' } => 6 ], ], ], + limit_offset_prefetch => [ + '( + SELECT me.name, books.id, books.source, books.owner, books.title, books.price + FROM ( + SELECT me.name, me.id + FROM ( + SELECT me.name, me.id FROM owners me + ) me + WHERE ( + SELECT COUNT(*) + FROM owners rownum__emulation + WHERE rownum__emulation.id < me.id + ) BETWEEN ? AND ? + ORDER BY me.id + ) me + LEFT JOIN books books + ON books.owner = me.id + ORDER BY me.id + )', + [ + [ { sqlt_datatype => 'integer' } => 1 ], + [ { sqlt_datatype => 'integer' } => 3 ], + ], + ], } }; @@ -653,6 +827,27 @@ for my $limtype (sort keys %$tests) { @{$tests->{$limtype}{ordered_limit_offset}}, "$limtype: Ordered limit+offset with select/group/having", ) if $tests->{$limtype}{ordered_limit_offset}; + + # complex prefetch on partial-fetch root with limit + my $pref_rs = $schema->resultset('Owners')->search({}, { + rows => 3, + offset => 1, + columns => 'name', # only the owner name, still prefetch all the books + prefetch => 'books', + ($limtype =~ /GenericSubQ/ ? ( order_by => 'me.id' ) : () ), # needs a simple-column stable order to be happy + }); + + is_same_sql_bind ( + $pref_rs->as_query, + @{$tests->{$limtype}{limit_offset_prefetch}}, + "$limtype: Prefetch with limit+offset", + ) if $tests->{$limtype}{limit_offset_prefetch}; + + # we can actually run the query + if ($limtype eq $native_limit_dialect or $limtype eq 'GenericSubQ') { + lives_ok { is ($pref_rs->all, 1, 'Expected count of objects on limtied prefetch') } + "Complex limited prefetch works with supported limit $limtype" + } } done_testing; diff --git a/t/sqlmaker/mysql.t b/t/sqlmaker/mysql.t new file mode 100644 index 0000000..9de4c7f --- /dev/null +++ b/t/sqlmaker/mysql.t @@ -0,0 +1,93 @@ +use strict; +use warnings; + +use Test::More; + +use lib qw(t/lib); +use DBICTest; +use DBICTest::Schema; +use DBIC::SqlMakerTest; +use DBIC::DebugObj; + +my $schema = DBICTest::Schema->connect (DBICTest->_database, { quote_char => '`' }); +# cheat +require DBIx::Class::Storage::DBI::mysql; +bless ( $schema->storage, 'DBIx::Class::Storage::DBI::mysql' ); + +# check that double-subqueries are properly wrapped +{ + my ($sql, @bind); + my $debugobj = DBIC::DebugObj->new (\$sql, \@bind); + my $orig_debugobj = $schema->storage->debugobj; + my $orig_debug = $schema->storage->debug; + + $schema->storage->debugobj ($debugobj); + $schema->storage->debug (1); + + # the expected SQL may seem wastefully nonsensical - this is due to + # CD's tablename being \'cd', which triggers the "this can be anything" + # mode, and forces a subquery. This in turn forces *another* subquery + # because mysql is being mysql + # Also we know it will fail - never deployed. All we care about is the + # SQL to compare + eval { $schema->resultset ('CD')->update({ genreid => undef }) }; + is_same_sql_bind ( + $sql, + \@bind, + 'UPDATE cd SET `genreid` = ? WHERE `cdid` IN ( SELECT * FROM ( SELECT `me`.`cdid` FROM cd `me` ) `_forced_double_subquery` )', + [ 'NULL' ], + 'Correct update-SQL with double-wrapped subquery', + ); + + # same comment as above + eval { $schema->resultset ('CD')->delete }; + is_same_sql_bind ( + $sql, + \@bind, + 'DELETE FROM cd WHERE `cdid` IN ( SELECT * FROM ( SELECT `me`.`cdid` FROM cd `me` ) `_forced_double_subquery` )', + [], + 'Correct delete-SQL with double-wrapped subquery', + ); + + # and a really contrived example (we test it live in t/71mysql.t) + my $rs = $schema->resultset('Artist')->search({ name => { -like => 'baby_%' } }); + my ($count_sql, @count_bind) = @${$rs->count_rs->as_query}; + eval { + $schema->resultset('Artist')->search( + { artistid => { + -in => $rs->get_column('artistid') + ->as_query + } }, + )->update({ name => \[ "CONCAT( `name`, '_bell_out_of_', $count_sql )", @count_bind ] }); + }; + + is_same_sql_bind ( + $sql, + \@bind, + q( + UPDATE `artist` + SET `name` = CONCAT(`name`, '_bell_out_of_', ( + SELECT * + FROM ( + SELECT COUNT( * ) + FROM `artist` `me` + WHERE `name` LIKE ? + ) `_forced_double_subquery` + )) + WHERE + `artistid` IN ( + SELECT * + FROM ( + SELECT `me`.`artistid` + FROM `artist` `me` + WHERE `name` LIKE ? + ) `_forced_double_subquery` ) + ), + [ ("'baby_%'") x 2 ], + ); + + $schema->storage->debugobj ($orig_debugobj); + $schema->storage->debug ($orig_debug); +} + +done_testing; diff --git a/t/sqlmaker/op_ident.t b/t/sqlmaker/op_ident.t deleted file mode 100644 index 46668a6..0000000 --- a/t/sqlmaker/op_ident.t +++ /dev/null @@ -1,41 +0,0 @@ -use strict; -use warnings; - -use Test::More; - -use lib qw(t/lib); -use DBIC::SqlMakerTest; - -use_ok('DBICTest'); - -my $schema = DBICTest->init_schema(); - -my $sql_maker = $schema->storage->sql_maker; - -for my $q ('', '"') { - - $sql_maker->quote_char($q); - - is_same_sql_bind ( - \[ $sql_maker->select ('artist', '*', { 'artist.name' => { -ident => 'artist.pseudonym' } } ) ], - "SELECT * - FROM ${q}artist${q} - WHERE ${q}artist${q}.${q}name${q} = ${q}artist${q}.${q}pseudonym${q} - ", - [], - ); - - is_same_sql_bind ( - \[ $sql_maker->update ('artist', - { 'artist.name' => { -ident => 'artist.pseudonym' } }, - { 'artist.name' => { '!=' => { -ident => 'artist.pseudonym' } } }, - ) ], - "UPDATE ${q}artist${q} - SET ${q}artist${q}.${q}name${q} = ${q}artist${q}.${q}pseudonym${q} - WHERE ${q}artist${q}.${q}name${q} != ${q}artist${q}.${q}pseudonym${q} - ", - [], - ); -} - -done_testing; diff --git a/t/sqlmaker/op_value.t b/t/sqlmaker/op_value.t deleted file mode 100644 index ceb441e..0000000 --- a/t/sqlmaker/op_value.t +++ /dev/null @@ -1,36 +0,0 @@ -use strict; -use warnings; - -use Test::More; - -use lib qw(t/lib); -use DBIC::SqlMakerTest; - -use_ok('DBICTest'); - -my $schema = DBICTest->init_schema(); - -my $sql_maker = $schema->storage->sql_maker; - -for my $q ('', '"') { - - $sql_maker->quote_char($q); - - is_same_sql_bind ( - \[ $sql_maker->select ('artist', '*', { arr1 => { -value => [1,2] }, arr2 => { '>', { -value => [3,4] } }, field => [5,6] } ) ], - "SELECT * - FROM ${q}artist${q} - WHERE ${q}arr1${q} = ? AND - ${q}arr2${q} > ? AND - ( ${q}field${q} = ? OR ${q}field${q} = ? ) - ", - [ - [ arr1 => [1,2] ], - [ arr2 => [3,4] ], - [ field => 5 ], - [ field => 6 ], - ], - ); -} - -done_testing; diff --git a/t/sqlmaker/order_by_bindtransport.t b/t/sqlmaker/order_by_bindtransport.t index d2a4e83..b612375 100644 --- a/t/sqlmaker/order_by_bindtransport.t +++ b/t/sqlmaker/order_by_bindtransport.t @@ -9,8 +9,6 @@ use DBICTest; use DBIC::SqlMakerTest; sub test_order { - - TODO: { my $rs = shift; my $args = shift; @@ -46,7 +44,6 @@ sub test_order { ], ) || diag Dumper $args->{order_by}; }; - } } my @tests = ( diff --git a/t/storage/dbh_do.t b/t/storage/dbh_do.t index 82e33d8..0beb858 100644 --- a/t/storage/dbh_do.t +++ b/t/storage/dbh_do.t @@ -9,6 +9,16 @@ use DBICTest; my $schema = DBICTest->init_schema(); my $storage = $schema->storage; +# test (re)connection +for my $disconnect (0, 1) { + $schema->storage->_dbh->disconnect if $disconnect; + is_deeply ( + $schema->storage->dbh_do(sub { $_[1]->selectall_arrayref('SELECT 1') }), + [ [ 1 ] ], + 'dbh_do on fresh handle worked', + ); +} + my @args; my $test_func = sub { @args = @_ }; @@ -31,9 +41,11 @@ is_deeply ( [ $storage, $storage->dbh, "baz", "buz" ], ); -# test aliasing +# test nested aliasing my $res = 'original'; -$storage->dbh_do (sub { $_[2] = 'changed' }, $res); +$storage->dbh_do (sub { + shift->dbh_do(sub { $_[3] = 'changed' }, @_) +}, $res); is ($res, 'changed', "Arguments properly aliased for dbh_do"); diff --git a/t/storage/deploy.t b/t/storage/deploy.t index 444bf26..233da2c 100644 --- a/t/storage/deploy.t +++ b/t/storage/deploy.t @@ -35,9 +35,9 @@ $schema->create_ddl_dir( undef, undef, $test_dir_1 ); ok( -d $test_dir_1, 'create_ddl_dir did a make_path on its target dir' ); ok( scalar( glob $test_dir_1.'/*.sql' ), 'there are sql files in there' ); -TODO: { - local $TODO = 'we should probably add some tests here for actual deployability of the DDL?'; - ok( 0 ); +{ + local $TODO = 'we should probably add some tests here for actual deployability of the DDL?'; + ok( 0 ); } END { diff --git a/t/storage/deprecated_exception_source_bind_attrs.t b/t/storage/deprecated_exception_source_bind_attrs.t new file mode 100644 index 0000000..f6dca5a --- /dev/null +++ b/t/storage/deprecated_exception_source_bind_attrs.t @@ -0,0 +1,30 @@ +use strict; +use warnings; + +use Test::More; +use Test::Warn; +use Test::Exception; +use lib qw(t/lib); +use DBICTest; + +{ + package DBICTest::Legacy::Storage; + use base 'DBIx::Class::Storage::DBI::SQLite'; + + use Data::Dumper::Concise; + + sub source_bind_attributes { return {} } +} + + +my $schema = DBICTest::Schema->clone; +$schema->storage_type('DBICTest::Legacy::Storage'); +$schema->connection('dbi:SQLite::memory:'); + +throws_ok + { $schema->storage->ensure_connected } + qr/\Qstorage subclass DBICTest::Legacy::Storage provides (or inherits) the method source_bind_attributes()/, + 'deprecated use of source_bind_attributes throws', +; + +done_testing; diff --git a/t/storage/error.t b/t/storage/error.t index 44cc1c9..d5980eb 100644 --- a/t/storage/error.t +++ b/t/storage/error.t @@ -6,8 +6,7 @@ use Test::Warn; use Test::Exception; use lib qw(t/lib); -use_ok( 'DBICTest' ); -use_ok( 'DBICTest::Schema' ); +use DBICTest; my $schema = DBICTest->init_schema; @@ -35,7 +34,7 @@ throws_ok ( # exception fallback: SKIP: { - if (DBIx::Class::_ENV_::PEEPEENESS()) { + if (DBIx::Class::_ENV_::PEEPEENESS) { skip "Your perl version $] appears to leak like a sieve - skipping garbage collected \$schema test", 1; } diff --git a/t/storage/global_destruction.t b/t/storage/global_destruction.t index ae4260a..4fb49cb 100644 --- a/t/storage/global_destruction.t +++ b/t/storage/global_destruction.t @@ -2,20 +2,23 @@ use strict; use warnings; use Test::More; -use Test::Exception; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; -plan skip_all => 'Test segfaults on Win32' if $^O eq 'MSWin32'; - -for my $type (qw/PG MYSQL/) { +for my $type (qw/PG MYSQL SQLite/) { SKIP: { - skip "Skipping $type tests without DBICTEST_${type}_DSN", 1 - unless $ENV{"DBICTEST_${type}_DSN"}; + my @dsn = $type eq 'SQLite' + ? DBICTest->_database(sqlite_use_file => 1) + : do { + skip "Skipping $type tests without DBICTEST_${type}_DSN", 1 + unless $ENV{"DBICTEST_${type}_DSN"}; + @ENV{map { "DBICTEST_${type}_${_}" } qw/DSN USER PASS/} + } + ; if ($type eq 'PG') { skip "skipping Pg tests without dependencies installed", 1 @@ -26,7 +29,7 @@ for my $type (qw/PG MYSQL/) { unless DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_mysql'); } - my $schema = DBICTest::Schema->connect (@ENV{map { "DBICTEST_${type}_${_}" } qw/DSN USER PASS/}); + my $schema = DBICTest::Schema->connect (@dsn); # emulate a singleton-factory, just cache the object *somewhere in a different package* # to induce out-of-order destruction @@ -37,29 +40,27 @@ for my $type (qw/PG MYSQL/) { ok (!$schema->storage->connected, "$type: start disconnected"); - lives_ok (sub { - $schema->txn_do (sub { - - ok ($schema->storage->connected, "$type: transaction starts connected"); + $schema->txn_do (sub { - my $pid = fork(); - SKIP: { - skip "Fork failed: $!", 1 if (! defined $pid); + ok ($schema->storage->connected, "$type: transaction starts connected"); - if ($pid) { - note "Parent $$ sleeping..."; - wait(); - note "Parent $$ woken up after child $pid exit"; - } - else { - note "Child $$ terminating"; - undef $DBICTest::FakeSchemaFactory::schema; - exit 0; - } + my $pid = fork(); + SKIP: { + skip "Fork failed: $!", 1 if (! defined $pid); - ok ($schema->storage->connected, "$type: parent still connected (in txn_do)"); + if ($pid) { + note "Parent $$ sleeping..."; + wait(); + note "Parent $$ woken up after child $pid exit"; } - }); + else { + note "Child $$ terminating"; + undef $DBICTest::FakeSchemaFactory::schema; + exit 0; + } + + ok ($schema->storage->connected, "$type: parent still connected (in txn_do)"); + } }); ok ($schema->storage->connected, "$type: parent still connected (outside of txn_do)"); diff --git a/t/storage/reconnect.t b/t/storage/reconnect.t index b28734b..557bff8 100644 --- a/t/storage/reconnect.t +++ b/t/storage/reconnect.t @@ -15,7 +15,7 @@ my $db_tmp = "$db_orig.tmp"; my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); # Make sure we're connected by doing something -my @art = $schema->resultset("Artist")->search({ }, { order_by => 'name DESC'}); +my @art = $schema->resultset("Artist")->search({ }, { order_by => { -desc => 'name' }}); cmp_ok(@art, '==', 3, "Three artists returned"); # Disconnect the dbh, and be sneaky about it @@ -32,30 +32,28 @@ cmp_ok(@art, '==', 3, "Three artists returned"); # 2. It catches the exception, checks ->{Active}/->ping, sees the disconnected state... # 3. Reconnects, and retries the operation # 4. Success! -my @art_two = $schema->resultset("Artist")->search({ }, { order_by => 'name DESC'}); +my @art_two = $schema->resultset("Artist")->search({ }, { order_by => { -desc => 'name' }}); cmp_ok(@art_two, '==', 3, "Three artists returned"); ### Now, disconnect the dbh, and move the db file; -# create a new one and chmod 000 to prevent SQLite from connecting. +# create a new one full of garbage, prevent SQLite from connecting. $schema->storage->_dbh->disconnect; move( $db_orig, $db_tmp ) or die "failed to move $db_orig to $db_tmp: $!"; -open DBFILE, '>', $db_orig; -print DBFILE 'THIS IS NOT A REAL DATABASE'; -close DBFILE; -chmod 0000, $db_orig; +open my $db_file, '>', $db_orig; +print $db_file 'THIS IS NOT A REAL DATABASE'; +close $db_file; -### Try the operation again... it should fail, since there's no db +### Try the operation again... it should fail, since there's no valid db { - # Catch the DBI connection error - local $SIG{__WARN__} = sub {}; - dies_ok { - my @art_three = $schema->resultset("Artist")->search( {}, { order_by => 'name DESC' } ); - } 'The operation failed'; + # Catch the DBI connection error + local $SIG{__WARN__} = sub {}; + throws_ok { + my @art_three = $schema->resultset("Artist")->search( {}, { order_by => { -desc => 'name' } } ); + } qr/not a database/, 'The operation failed'; } -# otherwise can't unlink the fake db file -$schema->storage->_dbh->disconnect if $^O eq 'MSWin32'; +ok (! $schema->storage->connected, 'We are not connected' ); ### Now, move the db file back to the correct name unlink($db_orig) or die "could not delete $db_orig: $!"; @@ -65,7 +63,7 @@ move( $db_tmp, $db_orig ) ### Try the operation again... this time, it should succeed my @art_four; lives_ok { - @art_four = $schema->resultset("Artist")->search( {}, { order_by => 'name DESC' } ); + @art_four = $schema->resultset("Artist")->search( {}, { order_by => { -desc => 'name' } } ); } 'The operation succeeded'; cmp_ok( @art_four, '==', 3, "Three artists returned" ); diff --git a/t/storage/replicated.t b/t/storage/replicated.t index 6919e5f..c8d469f 100644 --- a/t/storage/replicated.t +++ b/t/storage/replicated.t @@ -79,15 +79,8 @@ TESTSCHEMACLASSES: { ## Get the Schema and set the replication storage type sub init_schema { - # current SQLT SQLite producer does not handle DROP TABLE IF EXISTS, trap warnings here - local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /no such table.+DROP TABLE/s }; - - my ($class, $schema_method) = @_; - - my $method = "get_schema_$schema_method"; - my $schema = $class->$method; - - return $schema; + #my ($class, $schema_getter) = @_; + shift->${\ ( 'get_schema_' . shift ) }; } sub get_schema_by_storage_type { diff --git a/t/storage/source_bind_compat.t b/t/storage/source_bind_compat.t deleted file mode 100644 index 268f6a8..0000000 --- a/t/storage/source_bind_compat.t +++ /dev/null @@ -1,49 +0,0 @@ -use strict; -use warnings; - -use Test::More; -use Test::Warn; -use Test::Exception; -use lib qw(t/lib); -use DBICTest; - -{ - package DBICTest::Legacy::Storage; - use base 'DBIx::Class::Storage::DBI::SQLite'; - - use Data::Dumper::Concise; - - sub source_bind_attributes { return {} } -} - - -my $schema = DBICTest::Schema->clone; -$schema->storage_type('DBICTest::Legacy::Storage'); -$schema->connection('dbi:SQLite::memory:'); - -$schema->storage->dbh_do( sub { $_[1]->do(<<'EOS') } ); -CREATE TABLE artist ( - artistid INTEGER PRIMARY KEY NOT NULL, - name varchar(100), - rank integer NOT NULL DEFAULT 13, - charfield char(10) -) -EOS - -my $legacy = sub { $schema->resultset('Artist')->search({ name => 'foo'})->next }; -if (DBIx::Class->VERSION >= 0.09) { - &throws_ok( - $legacy, - qr/XXXXXXXXX not sure what error to put here yet XXXXXXXXXXXXXXX/, - 'deprecated use of source_bind_attributes throws', - ); -} -else { - &warnings_exist ( - $legacy, - qr/\QThe source_bind_attributes() override in DBICTest::Legacy::Storage relies on a deprecated codepath/, - 'Warning issued during invocation of legacy storage codepath', - ); -} - -done_testing; diff --git a/t/storage/txn_scope_guard.t b/t/storage/txn_scope_guard.t index 739ed6c..c0cb347 100644 --- a/t/storage/txn_scope_guard.t +++ b/t/storage/txn_scope_guard.t @@ -24,7 +24,7 @@ use DBICTest; }); $guard->commit; - } qr/No such column made_up_column .*? at .*?\Q$fn\E line \d+/s, "Error propogated okay"; + } qr/No such column 'made_up_column' .*? at .*?\Q$fn\E line \d+/s, "Error propogated okay"; ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created"); diff --git a/t/zzzzzzz_perl_perf_bug.t b/t/zzzzzzz_perl_perf_bug.t index c0a96d8..f67c854 100644 --- a/t/zzzzzzz_perl_perf_bug.t +++ b/t/zzzzzzz_perl_perf_bug.t @@ -1,8 +1,19 @@ use strict; use warnings; use Test::More; -use Benchmark; use lib qw(t/lib); + +BEGIN { + plan skip_all => + 'Skipping RH perl performance bug tests as DBIC_NO_WARN_BAD_PERL set' + if ( $ENV{DBIC_NO_WARN_BAD_PERL} ); + + require DBICTest::RunMode; + plan skip_all => 'Skipping as system appears to be a smoker' + if DBICTest::RunMode->is_smoker; +} + +use Benchmark; use DBICTest ':GlobalLock'; # This is a rather unusual test. @@ -19,13 +30,6 @@ use DBICTest ':GlobalLock'; # Perl Performance Issues on Red Hat Systems in # L -plan skip_all => - 'Skipping RH perl performance bug tests as DBIC_NO_WARN_BAD_PERL set' - if ( $ENV{DBIC_NO_WARN_BAD_PERL} ); - -plan skip_all => 'Skipping as system appears to be a smoker' - if DBICTest::RunMode->is_smoker; - plan tests => 3; ok( 1, 'Dummy - prevents next test timing out' ); diff --git a/xt/eol.t b/xt/eol.t deleted file mode 100644 index 4baf714..0000000 --- a/xt/eol.t +++ /dev/null @@ -1,26 +0,0 @@ -use warnings; -use strict; - -use Test::More; -use lib 't/lib'; -use DBICTest; - -require DBIx::Class; -unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_eol') ) { - my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_eol'); - $ENV{RELEASE_TESTING} - ? die ("Failed to load release-testing module requirements: $missing") - : plan skip_all => "Test needs: $missing" -} - -Test::EOL::all_perl_files_ok({ trailing_whitespace => 1 }, - qw/t xt lib script examples/, - DBICTest::RunMode->is_author ? ('maint') : (), -); - -# Changes is not a "perl file", hence checked separately -Test::EOL::eol_unix_ok('Changes', { trailing_whitespace => 1 }); - -# FIXME - Test::EOL declares 'no_plan' which conflicts with done_testing -# https://github.com/schwern/test-more/issues/14 -#done_testing; diff --git a/xt/notabs.t b/xt/notabs.t deleted file mode 100644 index 15e218f..0000000 --- a/xt/notabs.t +++ /dev/null @@ -1,26 +0,0 @@ -use warnings; -use strict; - -use Test::More; -use lib 't/lib'; -use DBICTest; - -require DBIx::Class; -unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_notabs') ) { - my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_notabs'); - $ENV{RELEASE_TESTING} - ? die ("Failed to load release-testing module requirements: $missing") - : plan skip_all => "Test needs: $missing" -} - -Test::NoTabs::all_perl_files_ok( - qw/t xt lib script examples/, - DBICTest::RunMode->is_author ? ('maint') : (), -); - -# Changes is not a "perl file", hence checked separately -Test::NoTabs::notabs_ok('Changes'); - -# FIXME - Test::NoTabs declares 'no_plan' which conflicts with done_testing -# https://github.com/schwern/test-more/issues/14 -#done_testing; diff --git a/xt/optional_deps.t b/xt/optional_deps.t index 1b8e6f9..0ae8023 100644 --- a/xt/optional_deps.t +++ b/xt/optional_deps.t @@ -119,7 +119,7 @@ is_deeply( is_deeply( DBIx::Class::Optional::Dependencies->req_list_for('test_rdbms_pg'), { - 'Sys::SigAction' => '0', + $^O ne 'MSWin32' ? ('Sys::SigAction' => '0') : (), 'DBD::Pg' => '2.009002', }, 'optional dependencies for testing Postgres with ENV var ok'); diff --git a/xt/pod.t b/xt/pod.t index 92d650e..0ed796b 100644 --- a/xt/pod.t +++ b/xt/pod.t @@ -13,4 +13,8 @@ unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_pod') ) { : plan skip_all => "Test needs: $missing" } -Test::Pod::all_pod_files_ok(); +# this has already been required but leave it here for CPANTS static analysis +require Test::Pod; + +my $generated_pod_dir = 'maint/.Generated_Pod'; +Test::Pod::all_pod_files_ok( 'lib', -d $generated_pod_dir ? $generated_pod_dir : () ); diff --git a/xt/podcoverage.t b/xt/podcoverage.t index a5c923f..7a7804e 100644 --- a/xt/podcoverage.t +++ b/xt/podcoverage.t @@ -3,7 +3,7 @@ use strict; use Test::More; use List::Util 'first'; -use lib qw(t/lib); +use lib qw(t/lib maint/.Generated_Pod/lib); use DBICTest; use namespace::clean; @@ -15,6 +15,9 @@ unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_podcoverage') ) : plan skip_all => "Test needs: $missing" } +# this has already been required but leave it here for CPANTS static analysis +require Test::Pod::Coverage; + # Since this is about checking documentation, a little documentation # of what this is doing might be in order. # The exceptions structure below is a hash keyed by the module @@ -47,11 +50,6 @@ my $exceptions = { MULTICREATE_DEBUG /], }, - 'DBIx::Class::Storage::TxnScopeGuard' => { - ignore => [qw/ - IS_BROKEN_PERL - /], - }, 'DBIx::Class::FilterColumn' => { ignore => [qw/ new @@ -159,7 +157,7 @@ for my $string (keys %$exceptions) { $ex_lookup->{$re} = $ex; } -my @modules = sort { $a cmp $b } (Test::Pod::Coverage::all_modules()); +my @modules = sort { $a cmp $b } Test::Pod::Coverage::all_modules('lib'); foreach my $module (@modules) { SKIP: { diff --git a/xt/strictures.t b/xt/strictures.t new file mode 100644 index 0000000..9e94cfa --- /dev/null +++ b/xt/strictures.t @@ -0,0 +1,45 @@ +use warnings; +use strict; + +use Test::More; +use lib 't/lib'; +use DBICTest ':GlobalLock'; + +unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_strictures') ) { + my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_strictures'); + $ENV{RELEASE_TESTING} + ? die ("Failed to load release-testing module requirements: $missing") + : plan skip_all => "Test needs: $missing" +} + + +use File::Find; + +find({ + wanted => sub { + -f $_ or return; + m/\.(?: pm | pl | t )$ /ix or return; + + return if m{^(?: + maint/Makefile.PL.inc/.+ # all the maint inc snippets are auto-strictured + | + lib/DBIx/Class/Admin/Types.pm # MooseX::Types undetected + | + lib/DBIx/Class/Storage/DBI/Replicated/Types.pm # MooseX::Types undetected + | + lib/DBIx/Class/Storage/BlockRunner.pm # Moo undetected + | + t/lib/DBICTest/Util/OverrideRequire.pm # no stictures by design (load order sensitive) + )$}x; + + my $f = $_; + + Test::Strict::strict_ok($f); + Test::Strict::warnings_ok($f); + + #Test::Strict::syntax_ok($f) if $f =~ /^ (?: lib )/x; + }, + no_chdir => 1, +}, (qw(lib t examples maint)) ); + +done_testing; diff --git a/xt/whitespace.t b/xt/whitespace.t new file mode 100644 index 0000000..111a0db --- /dev/null +++ b/xt/whitespace.t @@ -0,0 +1,58 @@ +use warnings; +use strict; + +use Test::More; +use File::Glob 'bsd_glob'; +use lib 't/lib'; +use DBICTest ':GlobalLock'; + +require DBIx::Class; +unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_whitespace') ) { + my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_whitespace'); + $ENV{RELEASE_TESTING} + ? die ("Failed to load release-testing module requirements: $missing") + : plan skip_all => "Test needs: $missing" +} + +# FIXME - temporary workaround for RT#82032, RT#82033 +# also add all scripts (no extension) and some extra extensions +# we want to check +{ + no warnings 'redefine'; + my $is_pm = sub { + $_[0] !~ /\./ || $_[0] =~ /\.(?:pm|pod|skip|sql|json|proto)$/i || $_[0] =~ /::/; + }; + + *Test::EOL::_is_perl_module = $is_pm; + *Test::NoTabs::_is_perl_module = $is_pm; +} + +my @pl_targets = qw/t xt lib script examples maint/; +Test::EOL::all_perl_files_ok({ trailing_whitespace => 1 }, @pl_targets); +Test::NoTabs::all_perl_files_ok(@pl_targets); + +# check some non-"perl files" in the root separately +# use .gitignore as a guide of what to skip +# (or do not test at all if no .gitignore is found) +if (open(my $gi, '<', '.gitignore')) { + my $skipnames; + while (my $ln = <$gi>) { + next if $ln =~ /^\s*$/; + chomp $ln; + $skipnames->{$_}++ for bsd_glob($ln); + } + + # that we want to check anyway + delete $skipnames->{'META.yml'}; + + for my $fn (bsd_glob('*')) { + next if $skipnames->{$fn}; + next unless -f $fn; + Test::EOL::eol_unix_ok($fn, { trailing_whitespace => 1 }); + Test::NoTabs::notabs_ok($fn); + } +} + +# FIXME - Test::NoTabs and Test::EOL declare 'no_plan' which conflicts with done_testing +# https://github.com/schwern/test-more/issues/14 +#done_testing;