diff --git a/.gitattributes b/.gitattributes index db6df22a4..e72001e52 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1,15 +1,15 @@ -*.pm eol=lf -*.t eol=lf -*.pod eol=lf -*.pod.proto eol=lf -*.pl eol=lf -*.PL eol=lf -*.bash eol=lf -*.json eol=lf -*.yml eol=lf -*.sql eol=lf +*.pm eol=lf linguist-language=Perl +*.t eol=lf linguist-language=Perl +*.pod eol=lf linguist-language=Pod +*.pod.proto eol=lf linguist-language=Pod +*.pl eol=lf linguist-language=Perl +*.PL eol=lf linguist-language=Perl +*.bash eol=lf linguist-language=Shell +*.json eol=lf linguist-language=JSON +*.yml eol=lf linguist-language=YAML +*.sql eol=lf linguist-language=SQL /* eol=lf -/script/* eol=lf +/script/* eol=lf linguist-language=Perl /maint/* eol=lf * text=auto diff --git a/.gitignore b/.gitignore index c8cda3ed8..81d2445c2 100644 --- a/.gitignore +++ b/.gitignore @@ -19,3 +19,5 @@ t/var/ *~ maint/.Generated_Pod examples/Schema/db + +lib/DBIx/Class/_TempExtlib diff --git a/.mailmap b/.mailmap index ffbbe5d9b..031804bb6 100644 --- a/.mailmap +++ b/.mailmap @@ -6,6 +6,7 @@ Alexander Hartmaier Alexander Kuznetsov +Alastair McGowan-Douglas Amiri Barksdale Andrew Rodland Arthur Axel "fREW" Schmidt @@ -14,9 +15,11 @@ Brendan Byrd Brendan Byrd Brendan Byrd Brian Phillips +C.J. Adams-Collier Christian Walde Jess Robinson Dagfinn Ilmari Mannsåker +Damien Krotkine David Kamholz David Schmidt David Schmidt @@ -34,12 +37,16 @@ Jason M. Mills Jonathan Chu Jose Luis Martinez Kent Fredric +Mark Zealey Matt Phillips +Matt Phillips +Michael Reddick Norbert Csongrádi Peter Rabbitson Roman Filippov Ronald J Kimball Samuel Kaufman +Sebastian Willert Tim Bunce Toby Corkindale Tommy Butler diff --git a/.travis.yml b/.travis.yml index 2f99311c2..8ba45b2b5 100644 --- a/.travis.yml +++ b/.travis.yml @@ -14,10 +14,6 @@ # # Smoke all branches except for blocked* and wip/* -# -# Additionally master does not smoke with bleadperl -# ( implemented in maint/travis-ci_scripts/10_before_install.bash ) -# branches: except: - /^wip\// @@ -35,7 +31,7 @@ notifications: email: recipients: - - ribasushi@cpan.org + - CPAN-CI@leporine.io on_success: change on_failure: always @@ -74,23 +70,28 @@ matrix: # In genereal it is strongly recommended to keep things on the older # version indefinitely - there is little value in-depth smoking on # more recent software stacks + # Add moderate (not complete) poisoning, as these will run on PR-related + # builds, therefore contributors will get notified about *most* issues - perl: "5.8" sudo: required dist: precise env: - CLEANTEST=false + - POISON_ENV=true - perl: "5.10" sudo: required dist: precise env: - CLEANTEST=false + - POISON_ENV=true - perl: "5.22-extras" sudo: required dist: precise env: - CLEANTEST=false + - POISON_ENV=true # CLEANTEST of minimum supported with non-tracing poisoning, single thread (hence the sudo) - perl: "5.8.3_nt_mb" @@ -143,6 +144,7 @@ matrix: - perl: "5.8.8_thr" sudo: required dist: precise + group: legacy env: - VCPU_USE=1 - CLEANTEST=false @@ -190,8 +192,8 @@ matrix: dist: precise env: - CLEANTEST=false - - POISON_ENV=true - DBIC_TRACE=1 + - DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1 - BREWVER=5.16.3 - BREWOPTS="-Duseithreads -Dusemorebits" @@ -207,9 +209,51 @@ matrix: - DBICTEST_VIA_REPLICATED=0 - DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1 + # MAKE SURE TO KEEP THE FLAGS IDENTICAL TO CPERL BELOW + # allows for easier side-by-side comparison + # vcpu=1 for even more stable results + - perl: "5.24.0_thr_qm" + # explicit new infra spec preparing for a future forced upgrade + # also need to pull in a sufficiently new compiler for quadmath.h + sudo: required + dist: trusty + env: + - VCPU_USE=1 + - CLEANTEST=true + - POISON_ENV=true + - MVDT=false + - BREWVER=5.24.0 + - BREWOPTS="-Duseithreads -Dusequadmath" + ### # Start of the allow_failures block + # MAKE SURE TO KEEP THE FLAGS IDENTICAL TO STOCK 5.latest.comparable ABOVE + # allows for easier side-by-side comparison + # vcpu=1 for even more stable results + - perl: "cperl-5.24.0_thr_qm" + # explicit new infra spec preparing for a future forced upgrade + # also need to pull in a sufficiently new compiler for quadmath.h + sudo: required + dist: trusty + env: + - VCPU_USE=1 + - CLEANTEST=true + - POISON_ENV=true + - MVDT=false + - BREWVER=cperl-5.24.0 + - BREWOPTS="-Duseithreads -Dusequadmath" + + - perl: "cperl-master_thr" + sudo: false + dist: precise + env: + - CLEANTEST=true + - POISON_ENV=true + - MVDT=false + - BREWVER=cperl-master + - BREWOPTS="-Duseithreads -Dusedevel" + # threaded oldest possible with blead CPAN - perl: "devcpan_5.8.1_thr_mb" sudo: false @@ -320,6 +364,8 @@ matrix: allow_failures: # these run with various dev snapshots - allowed to fail + - perl: cperl-5.24.0_thr_qm + - perl: cperl-master_thr - perl: devcpan_5.8.1_thr_mb - perl: devcpan_5.8.1 - perl: devcpan_5.8.3_mb @@ -371,12 +417,12 @@ before_script: # need to invoke the after_failure script manually # because 'after_failure' runs only after 'script' fails # - - maint/getstatus maint/travis-ci_scripts/30_before_script.bash + - maint/getstatus /bin/bash maint/travis-ci_scripts/30_before_script.bash script: # Run actual tests # - - maint/getstatus maint/travis-ci_scripts/40_script.bash + - maint/getstatus /bin/bash maint/travis-ci_scripts/40_script.bash ### ### Set -e back, work around https://github.com/travis-ci/travis-ci/issues/3533 @@ -386,14 +432,14 @@ script: after_success: # Check if we can assemble a dist properly if not in CLEANTEST # - - maint/getstatus maint/travis-ci_scripts/50_after_success.bash + - maint/getstatus /bin/bash maint/travis-ci_scripts/50_after_success.bash || ( /bin/bash maint/travis-ci_scripts/50_after_failure.bash && /bin/false ) after_failure: # Final sysinfo printout on fail # - - maint/getstatus maint/travis-ci_scripts/50_after_failure.bash + - maint/getstatus /bin/bash maint/travis-ci_scripts/50_after_failure.bash after_script: # No tasks yet # - #- maint/getstatus maint/travis-ci_scripts/60_after_script.bash + #- maint/getstatus /bin/bash maint/travis-ci_scripts/60_after_script.bash diff --git a/AUTHORS b/AUTHORS index 086b0e0ce..9e4a9626b 100644 --- a/AUTHORS +++ b/AUTHORS @@ -19,8 +19,9 @@ acca: Alexander Kuznetsov aherzog: Adam Herzog Alexander Keusch alexrj: Alessandro Ranellucci +alh: Matthew Horsfall alnewkirk: Al Newkirk -Altreus: Alastair McGowan-Douglas +Altreus: Alastair McGowan-Douglas amiri: Amiri Barksdale amoore: Andrew Moore Andrew Mehta @@ -31,6 +32,7 @@ ank: Andres Kievsky arc: Aaron Crane arcanez: Justin Hunter ash: Ash Berlin +batman: Jan Henning Thorsen bert: Norbert Csongrádi bfwg: Colin Newell blblack: Brandon L. Black @@ -73,6 +75,7 @@ ether: Karen Etheridge evdb: Edmund von der Burg faxm0dem: Fabien Wernli felliott: Fitz Elliott +fgabolde: Fabrice Gabolde freetime: Bill Moseley frew: Arthur Axel "fREW" Schmidt gbjk: Gareth Kirwan @@ -85,7 +88,8 @@ gregoa: Gregor Herrmann groditi: Guillermo Roditi gshank: Gerda Shank guacamole: Fred Steinberg -Haarg: Graham Knop +haarg: Graham Knop +hisaichi: Hisada Kazuki hobbs: Andrew Rodland Ian Wells idn: Ian Norton @@ -93,6 +97,7 @@ ilmari: Dagfinn Ilmari Mannsåker ingy: Ingy döt Net initself: Mike Baas ironcamel: Naveed Massjouni +jalh: Mark Zealey jasonmay: Jason May jawnsy: Jonathan Yu jegade: Jens Gassmann @@ -161,6 +166,7 @@ Peter Valdemar Mørch peter: Peter Collingbourne phaylon: Robert Sedlacek plu: Johannes Plunien +pmooney: Paul Mooney Possum: Daniel LeWarne pplu: Jose Luis Martinez quicksilver: Jules Bean @@ -179,6 +185,7 @@ Robert Olson robkinyon: Rob Kinyon Roman Ardern-Corris ruoso: Daniel Ruoso +rwtnorton: Richard W. Norton Sadrak: Felix Antonius Wilhelm Ostmann sc_: Just Another Perl Hacker schwern: Michael G Schwern @@ -192,6 +199,7 @@ solomon: Jared Johnson spb: Stephen Bennett Squeeks srezic: Slaven Rezic +sri: Sebastian Riedel sszabo: Stephan Szabo Stephen Peters stonecolddevin: Devin Austin @@ -214,6 +222,7 @@ uwe: Uwe Voelker Vadim Pushtaev vanstyn: Henry Van Styn victori: Victor Igumnov +vovkasm: Vladimir Timofeev wdh: Will Hawes wesm: Wes Malone willert: Sebastian Willert diff --git a/Changes b/Changes index 954675273..fabe41dc0 100644 --- a/Changes +++ b/Changes @@ -1,64 +1,144 @@ +Current Known Issues / Regressions + - Breaks DBIx::Class::ResultSet::WithMetaData (fix pending in RT#104602) + - Breaks DBIx::Class::Tree::NestedSet (fix pending in RT#114440) + Revision history for DBIx::Class * Notable Changes and Deprecations + - The entire class hierarchy now explicitly sets the 'c3' mro, even + in cases where load_components was not used. Extensive testing led + the maintainer believe this is safe, but this is a very complex + area and reality may turn out to be different. If **ANYHTING** at + all seems out of place, please file a report at once + - The unique constraint info (including the primary key columns) is no + longer shared between related (class and schema-level) ResultSource + instances. If your app stops working with no obvious pointers, set + DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE=1 to obtain extra info - Neither exception_action() nor $SIG{__DIE__} handlers are invoked on recoverable errors. This ensures that the retry logic is fully insulated from changes in control flow, as the handlers are only invoked when an error is leaving the DBIC internals to be handled by the caller (n.b. https://github.com/PerlDancer/Dancer2/issues/1125) + (also fixes the previously rejected RT#63874) + - Overrides of ResultSourceProxy-provided methods are no longer skipped + silently: a one-per-callsite warning is issued any time this tricky + situation is encoutered https://is.gd/dbic_rsrcproxy_methodattr - $result->related_resultset() no longer passes extra arguments to an underlying search_rs(), as by design these arguments would be used only on the first call to ->related_resultset(), and ignored afterwards. Instead an exception (detailing the fix) is thrown. + - Change func_rs() and as_subselect_rs() to properly ignore list + context (i.e. wantarray). Both were implemented broken from day 1 :/ + - Increased checking for the correctness of the is_nullable attribute + within the prefetch result parser may highlight previously unknown + mismatches between your codebase and data source - Calling the set_* many-to-many helper with a list (instead of an arrayref) now emits a deprecation warning + - Calling the getter $rsrc->from("argument") now throws an exception + instead of silently discarding the argument + - search() calls with an empty select list are deprecated. While DBIC + will still issue a SELECT * ..., it now warns given there is nothing + higher up in the stack prepared to interpret the result * New Features - - When using non-scalars (e.g. arrays) as literal bind values it is no - longer necessary to explicitly specify a bindtype (this turned out - to be a mostly useless overprotection) + - DBIC now performs a range of sanity checks on the entire hierarchy + of Schema/Result/ResultSet classes loudly alerting the end user to + potential extremely hard-to-diagnose pitfalls ( RT#93976, also fully + addresses https://blog.afoolishmanifesto.com/posts/mros-and-you/ ) + - A new low-level API for relationship resolution is available as an + official method ( $rsrc->resolve_relationship_condition ). This is + mainly of interest to builders of reflection tools + - InflateColumn::DateTime now accepts the ecosystem-standard option + 'time_zone', in addition to the DBIC-only 'timezone' (GH#28) + - Massively optimised literal SQL snippet scanner - fixes all known + slowdowns ( in some cases 50x ) of very complex prefetch/selects - DBIx::Class::Optional::Dependencies now properly understands combinations of requirements and does the right thing with e.g. ->req_list_for([qw( rdbms_oracle ic_dt )]) bringing in the Oracle specific DateTime::Format dependencies * Fixes - - Ensure failing on_connect* / on_disconnect* are dealt with properly, - notably on_connect* failures now properly abort the entire connect + - Fix regresion (0.082800) of certain calls being presented stale + result source metadata (RT#107462) - Fix incorrect SQL generated with invalid {rows} on complex resultset operations, generally more robust handling of rows/offset attrs + - Fix silent failure to retrieve a primary key (RT#80283) or worse: + returning an incorrect value (RT#115381) in case a rdbms-side autoinc + column is declared as PK with the is_auto_increment attribute unset - Fix incorrect $storage state on unexpected RDBMS disconnects and other failure events, preventing clean reconnection (RT#110429) - - Ensure leaving an exception stack via Return::MultiLevel or something - similar produces a large warning - Make sure exception objects stringifying to '' are properly handled and warned about (GH#15) + - Fix incorrect data returned in a corner case of partial-select HRI + invocation (no known manifestations of this bug in the field, see + commit message for description of exact failure scenario) - Fix corner case of stringify-only overloaded objects being used in create()/populate() - - Fix spurious ROLLBACK statements when a TxnScopeGuard fails a commit - of a transaction with deferred FK checks: a guard is now inactivated - immediately before the commit is attempted (RT#107159) - - Work around unreliable $sth->finish() on INSERT ... RETURNING within - DBD::Firebird on some compiler/driver combinations (RT#110979) + - Fix spurious warning on MSSQL cursor invalidation retries (RT#102166) + - Fix incorrect ::Storage->_ping() behavior under Sybase (RT#114214) + - Fix some corner cases of non-fatal failures during relationship + resolution showing up as hard errors - Fix several corner cases with Many2Many over custom relationships - - Fix the Sybase ASE storage incorrectly attempting to retrieve an - autoinc value when inserting rows containing blobs (GH#82) + - Fix intermittent failure to infer the CASCADE attributes of relations + during deployment_statements()/deploy() + - Fix corner cases of C3 composition being broken on OLD_MRO (5.8.x) + only: https://github.com/frioux/DBIx-Class-Helpers/issues/61 * Misc + - Add explicit test for pathological example of asymmetric IC::DT setup + working with copy() in t/icdt/engine_specific/sybase.t (GH#84) + - Fix t/54taint.t failing on local::lib's with upgraded Carp on 5.8.* - Fix invalid variable names in ResultSource::View examples - - Typo fixes from downstream debian packagers (RT#112007) + - Fix missing ORDER BY leading to failures of t/prefetch/grouped.t + under upcoming libsqlite (RT#117271) - Skip tests in a way more intelligent and speedy manner when optional dependencies are missing - Make the Optional::Dependencies error messages cpanm-friendly - Incompatibly change values (not keys) of the hash returned by Optional::Dependencies::req_group_list (no known users in the wild) - - Protect tests and codebase from incomplete caller() overrides, like - e.g. RT#32640 - Stop using bare $] throughout - protects the codebase from issues similar (but likely not limited to) P5#72210 - Config::Any is no longer a core dep, but instead is migrated to a new optdep group 'config_file_reader' +0.082840 2016-06-20 07:02 (UTC) + * New Features + - When using non-scalars (e.g. arrays) as literal bind values it is no + longer necessary to explicitly specify a bindtype (this turned out + to be a mostly useless overprotection) + + * Fixes + - Ensure leaving an exception stack via Return::MultiLevel or something + similar produces a large warning + - Another relatively invasive set of ::FilterColumn changes, covering + potential data loss (RT#111567). Please run your regression tests! + - Ensure failing on_connect* / on_disconnect* are dealt with properly, + notably on_connect* failures now properly abort the entire connect + - Fix use of ::Schema::Versioned combined with a user-supplied + $dbh->{HandleError} (GH#101) + - Fix parsing of DSNs containing driver arguments (GH#99) + - Fix silencing of exceptions thrown by custom inflate_result() methods + - Fix complex prefetch when ordering over foreign boolean columns + ( Pg can't MAX(boolcol) despite being able to ORDER BY boolcol ) + - Fix infinite loop on ->svp_release("nonexistent_savepoint") (GH#97) + - Fix spurious ROLLBACK statements when a TxnScopeGuard fails a commit + of a transaction with deferred FK checks: a guard is now inactivated + immediately before the commit is attempted (RT#107159) + - Fix the Sybase ASE storage incorrectly attempting to retrieve an + autoinc value when inserting rows containing blobs (GH#82) + - Remove spurious exception warping in ::Replicated::execute_reliably + (RT#113339) + - Work around unreliable $sth->finish() on INSERT ... RETURNING within + DBD::Firebird on some compiler/driver combinations (RT#110979) + - Fix leaktest failures with upcoming version of Sub::Quote + - Really fix savepoint rollbacks on older DBD::SQLite (fix in 0.082800 + was not sufficient to cover up RT#67843) + + * Misc + - Test suite is now officially certified to work under very high random + parallelism: META x_parallel_test_certified set to true accordingly + - Typo fixes from downstream debian packagers (RT#112007) + 0.082821 2016-02-11 17:58 (UTC) * Fixes - Fix t/52leaks.t failures on compilerless systems (RT#104429) diff --git a/GOVERNANCE b/GOVERNANCE new file mode 100644 index 000000000..1ddce3c49 --- /dev/null +++ b/GOVERNANCE @@ -0,0 +1,125 @@ +DBIx::Class Core Team and Voting System + +Non normative section: + +DBIx::Class originally operated under a BDFL system, but one where it was +expected that an informal core team would be maintained, and that where +consensus could not be pre-assumed, the core team and/or the user base +would be consulted publically such that measured decisions could be made. + +This document is intended to formalise a form of this system, while still +providing room for the system to adapt later as required. + +It is intended that this system provides confidence to the user base that +decisions will be made in the open and that their wishes will be taken into +account. + +It is also intended that this system allows business as usual to happen +without unnecessary red tape. + +It is not intended that this system becomes the primary decision making +process in and of itself; instead, it is intended that this system is used +to ratify consensus as formed by discussion, and only sparingly as a tie +breaking system when consensus cannot be reached. + +Normative section: + +Terms: VM - Voting Member - part of the benevolent dictatorship + LS - List Subscriber - a subscriber to the mailing list + LAV - List Aggregate Vote - the aggregate vote of the non-VM LSes + +Voting Members are: + + Matt S Trout (mst) cpan:MSTROUT + Dagfinn Ilmari Mansaker (ilmari) cpan:ILMARI + Frew Schmidt (frew) cpan:FREW + Jess Robinson (castaway) cpan:JROBINSON + +PAUSE release perms are to be held by: + + Matt S Trout (mst) cpan:MSTROUT + Dagfinn Ilmari Mansaker (ilmari) cpan:ILMARI + Frew Schmidt (frew) cpan:FREW + Jess Robinson (castaway) cpan:JROBINSON + +First come permissions are to be held by FREW. + +(the above two lists may or may not be identical at any given time) + +A resolution must be proposed and then successfully voted upon to: + + - Make a PAUSE-indexed (i.e. non-dev) release of DBIx::Class + - Make changes to the master and blead branches of the repository + - Amend this document + +This document is currently in bootstrap phase, and as such no merges will be +made to master or blead until this sentence is removed. + +A resolution that amends the 'PAUSE release perms' list is to be assumed to +also intend the permission within PAUSE itself to be updated accordingly. + +Adding or removing entries from the list of situations requiring resolutions +is absolutely a valid topic for resolutions. + +A resolution may be proposed for reasons including, but not limited to: + + - Force/revert/block a branch merge + - Add/remove a commit bit + - Resolve a design discussion + - Anything you like, under the assumption frivolous proposals will be + voted down naturally anyway + +Merges to topic branches and similar actions that do not have a resolution +attached may be made at the discretion of those with ability to do so, but +a developer unsure if the merge will be uncontroversial is expected to ping +the list first so a vote can be called if people believe it to be required. + +Rules that restrict this "ask unless you're sure" trust-by-default position +are also absolutely a valid topic for resolutions. + +Resolution proposal: + +A resolution is proposed by starting a new thread entitled 'PROPOSAL: ...' + +A resolution must be seconded before it is voted upon. + +If a VM makes or seconds a proposal, they are required to abstain from +voting upon it. + +If a non-VM LS makes or seconds a proposal, no such restriction applies. + +Resolution voting: + +Once a proposal is seconded, the initial proposer may start a new thread +entitled 'VOTE: ...' (voting does not automatically begin after seconding +in case other feedback leads the proposer to wish to alter and re-present +their proposal). + +Each VM may cast one vote, either +1, -1 or abstain. + +Each non-VM LS may post +1 or -1, and the aggregate of those form the LAV. + +Voting closes after 72h from when the proposal was first posted. + +A resolution passes if the VM total is at least +1 and the LAV is +non-negative, to avoid requiring the list members to expend time to vote on +business as usual while still providing them a veto. + +Resolution forcing: + +If a resolution gains a positive LAV, but is voted down by the VMs, a force +vote may be proposed. This requires two list members who did not propose or +second the initial resolution to propose and second the force vote. + +A force vote also lasts 72h, and is LAV-only. If it receives at least 25% +more +1s than -1s, the resolution passes no matter the VM vote. + +This mechanism is not intended to be needed on a regular basis, but exists +to permit the list to forcibly recall a VM if they believe it to be necessary. + +Once a resolution has passed, the resolution will be carried out by those with +the power to do so. It will not be reverted without a new resolution +amending or reversing the decision of the previous once. + +Passed resolutions will be recorded in a RESOLUTIONS file maintained next +to this document. diff --git a/Makefile.PL b/Makefile.PL index f4ac1b863..7aab0d5e7 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -42,33 +42,22 @@ my $runtime_requires = { ### '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.10012', 'Class::C3::Componentised' => '1.0009', - 'Class::Inspector' => '1.24', 'Context::Preserve' => '0.01', - 'Data::Dumper::Concise' => '2.020', 'Data::Page' => '2.00', 'Devel::GlobalDestruction' => '0.09', 'Hash::Merge' => '0.12', - 'Moo' => '2.000', + 'Moo' => '2.002002', 'MRO::Compat' => '0.12', 'Module::Find' => '0.07', 'namespace::clean' => '0.24', - 'Path::Class' => '0.18', 'Scope::Guard' => '0.03', 'SQL::Abstract' => '1.81', - 'Try::Tiny' => '0.07', # Technically this is not a core dependency - it is only required # by the MySQL codepath. However this particular version is bundled @@ -86,9 +75,14 @@ my $test_requires = { 'Test::Warn' => '0.21', 'Test::More' => '0.94', - # this is already a dep of n::c, but just in case - used by t/55namespaces_cleaned.t - # remove and do a manual glob-collection if n::c is no longer a dep - 'Package::Stash' => '0.28', + # This has a bug in the caller() override, ideally we need go get rid + # of it entirely, but that's for another maint + # + # FIXME - this does protect tests, but does *NOT* protect the rest of + # DBIC itself from a faulty caller() override. Something more substantial + # needs to be done in the guts of DBIC::Carp + # + 'Sub::Uplevel' => '0.19', # needed for testing only, not for operation # we will move away from this dep eventually, perhaps to DBD::CSV or something @@ -99,7 +93,7 @@ my $test_requires = { # tests will fail # Note - these are added as test_requires *directly*, so they get properly # excluded on META.yml cleansing (even though no dist can be created from this) -# we force these reqs regarless of author_deps, worst case scenario they will +# we force these reqs regarless of --with-optdeps, worst case scenario they will # be specified twice # # also note that we *do* set dynamic_config => 0, as these are the only things @@ -205,10 +199,10 @@ sub invoke_author_mode { config => [qw/gnu_getopt bundling_override no_ignore_case pass_through/] ); my $args = { - skip_author_deps => undef, + with_optdeps => undef, }; $getopt->getoptions($args, qw/ - skip_author_deps|skip-author-deps + with_optdeps|with-optdeps /); if (@ARGV) { warn "\nIgnoring unrecognized option(s): @ARGV\n\n"; @@ -236,15 +230,10 @@ sub invoke_author_mode { "\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 # $mm_proto, $reqs and $*_requires lexicals to the included file # (some includes *do* modify $reqs above) - for my $inc (sort glob ( File::Spec->catfile('maint', 'Makefile.PL.inc', '*') ) ) { + for my $inc (sort glob ( '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", diff --git a/RESOLUTIONS b/RESOLUTIONS new file mode 100644 index 000000000..e69de29bb diff --git a/examples/Benchmarks/benchmark_join_optimizer.pl b/examples/Benchmarks/benchmark_join_optimizer.pl new file mode 100755 index 000000000..68b4a5065 --- /dev/null +++ b/examples/Benchmarks/benchmark_join_optimizer.pl @@ -0,0 +1,48 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use Time::HiRes qw(gettimeofday tv_interval); +use Digest::SHA 'sha1_hex'; + +use lib 't/lib'; +BEGIN { $ENV{DBICTEST_ANFANG_DEFANG} = 1 }; +use DBICTest; + +my $schema = DBICTest->init_schema( + quote_names => 1, + cursor_class => 'DBIx::Class::Cursor::Cached' +); + +use Cache::FileCache; +my $c = Cache::FileCache->new({ namespace => 'SchemaClass' }); + +for my $i (1..9) { + + my $t0 = [gettimeofday]; + + # getting a fresh rs makes sure we do not cache anything + my $rs = $schema->resultset("Artist")->search({},{ + cache_object => $c, + cache_for => 999999999999, + prefetch => { + cds => [ + ( { tracks => { cd_single => { artist => { cds => { tracks => 'cd_single' } } } } } ) x 50, + ], + }, + rows => 2, + }); + + my $q = ${$rs->as_query}->[0]; + + print STDERR "@{[ length $q]} byte-long query generated (via as_query() in: ".tv_interval($t0) . " seconds (take $i)\n"; + + # stuff below can be made even faster, but another time + next; + + $t0 = [ gettimeofday ]; + + my $x = $rs->all_hri; + print STDERR "Got collapsed results (via HRI) in: ".tv_interval($t0) . " seconds (take $i)\n"; +} diff --git a/examples/Schema/MyApp/Schema.pm b/examples/Schema/MyApp/Schema.pm index 3642e82be..fdfa82bc1 100644 --- a/examples/Schema/MyApp/Schema.pm +++ b/examples/Schema/MyApp/Schema.pm @@ -6,4 +6,9 @@ use strict; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_namespaces; +# no point taxing 5.8, but otherwise leave the default: a user may +# be interested in exploring and seeing what broke +__PACKAGE__->schema_sanity_checker('') + if DBIx::Class::_ENV_::OLD_MRO; + 1; diff --git a/examples/Schema/insertdb.pl b/examples/Schema/insertdb.pl index ae919b372..4fb22fa59 100755 --- a/examples/Schema/insertdb.pl +++ b/examples/Schema/insertdb.pl @@ -4,9 +4,9 @@ use warnings; use MyApp::Schema; +use DBIx::Class::_Util 'parent_dir'; -use Path::Class 'file'; -my $db_fn = file($INC{'MyApp/Schema.pm'})->dir->parent->file('db/example.db'); +my $db_fn = parent_dir( $INC{'MyApp/Schema.pm'} ) . '../db/example.db'; my $schema = MyApp::Schema->connect("dbi:SQLite:$db_fn"); diff --git a/examples/Schema/testdb.pl b/examples/Schema/testdb.pl index 32cbd6daf..0149bc2ab 100755 --- a/examples/Schema/testdb.pl +++ b/examples/Schema/testdb.pl @@ -4,9 +4,9 @@ use strict; use MyApp::Schema; +use DBIx::Class::_Util 'parent_dir'; -use Path::Class 'file'; -my $db_fn = file($INC{'MyApp/Schema.pm'})->dir->parent->file('db/example.db'); +my $db_fn = parent_dir( $INC{'MyApp/Schema.pm'} ) . '../db/example.db'; # for other DSNs, e.g. MySql, see the perldoc for the relevant dbd # driver, e.g perldoc L. diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index a87cf4a50..cdcbcbbef 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -1,5 +1,8 @@ package DBIx::Class; +# important to load early +use DBIx::Class::_Util; + use strict; use warnings; @@ -11,64 +14,28 @@ 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.082899_15'; +$VERSION = '0.082899_25'; $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases -use DBIx::Class::_Util; use mro 'c3'; -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|^Moose::Meta::'); - -# FIXME - this is not really necessary, and is in -# fact going to slow things down a bit -# However it is the right thing to do in order to get -# various install bases to highlight their brokenness -# Remove at some unknown point in the future -# -# The oddball BEGIN is there for... reason unknown -# It does make non-segfaulty difference on pre-5.8.5 perls, so shrug -BEGIN { - sub DESTROY { &DBIx::Class::_Util::detected_reinvoked_destructor }; -} -sub mk_classdata { - shift->mk_classaccessor(@_); -} - -sub mk_classaccessor { - my $self = shift; - $self->mk_group_accessors('inherited', $_[0]); - $self->set_inherited(@_) if @_ > 1; -} +__PACKAGE__->mk_classaccessor( + _skip_namespace_frames => join( '|', map { '^' . $_ } qw( + DBIx::Class + SQL::Abstract + SQL::Translator + Try::Tiny + Class::Accessor::Grouped + Context::Preserve + Moose::Meta:: + )), +); sub component_base_class { 'DBIx::Class' } -sub MODIFY_CODE_ATTRIBUTES { - my ($class,$code,@attrs) = @_; - $class->mk_classdata('__attr_cache' => {}) - unless $class->can('__attr_cache'); - $class->__attr_cache->{$code} = [@attrs]; - return (); -} - -sub _attr_cache { - my $self = shift; - my $cache = $self->can('__attr_cache') ? $self->__attr_cache : {}; - - return { - %$cache, - %{ $self->maybe::next::method || {} }, - }; -} - # *DO NOT* change this URL nor the identically named =head1 below # it is linked throughout the ecosystem sub DBIx::Class::_ENV_::HELP_URL () { @@ -291,7 +258,7 @@ accessible at the following locations: =item * Travis-CI log: L =for html -↪ Stable branch CI status: +↪ Bleeding edge dev CI status: =back diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index ea25e4f79..31cdcb0e8 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -3,33 +3,103 @@ package DBIx::Class::AccessorGroup; use strict; use warnings; -use base qw/Class::Accessor::Grouped/; -use Scalar::Util qw/weaken blessed/; +use base qw( DBIx::Class::MethodAttributes Class::Accessor::Grouped ); + +use Scalar::Util 'blessed'; +use DBIx::Class::_Util 'fail_on_internal_call'; use namespace::clean; -my $successfully_loaded_components; +sub mk_classdata :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->mk_classaccessor(@_); +} + +sub mk_classaccessor :DBIC_method_is_indirect_sugar { + my $self = shift; + $self->mk_group_accessors('inherited', $_[0]); + (@_ > 1) + ? $self->set_inherited(@_) + : ( DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call ) + ; +} + +sub mk_group_accessors { + my $class = shift; + my $type = shift; + + $class->next::method($type, @_); + + # label things + if( $type =~ /^ ( inflated_ | filtered_ )? column $/x ) { + + $class = ref $class + if length ref $class; + + for my $acc_pair ( + map + { [ $_, "_${_}_accessor" ] } + map + { ref $_ ? $_->[0] : $_ } + @_ + ) { + + for my $i (0, 1) { + + my $acc_name = $acc_pair->[$i]; + + attributes->import( + $class, + ( + $class->can($acc_name) + || + Carp::confess("Accessor '$acc_name' we just created on $class can't be found...?") + ), + 'DBIC_method_is_generated_from_resultsource_metadata', + ($i + ? "DBIC_method_is_${type}_extra_accessor" + : "DBIC_method_is_${type}_accessor" + ), + ) + } + } + } + elsif( $type eq 'inherited_ro_instance' ) { + DBIx::Class::Exception->throw( + "The 'inherted_ro_instance' CAG group has been retired - use 'inherited' instead" + ); + } +} 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} ) { + no strict 'refs'; + if ( + defined $class + and + # inherited CAG can't be set to undef effectively, so people may use '' + length $class + and + # It's already an object, just go for it. + ! defined blessed $class + and + ! ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} + ) { $_[0]->ensure_class_loaded($class); - no strict 'refs'; - $successfully_loaded_components->{$class} - = ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} - = do { \(my $anon = 'loaded') }; - weaken($successfully_loaded_components->{$class}); + ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} + = do { \(my $anon = 'loaded') }; } $class; }; sub set_component_class { - shift->set_inherited(@_); + $_[0]->set_inherited($_[1], $_[2]); + + # trigger a load for the case of $foo->component_accessor("bar")->new + $_[0]->get_component_class($_[1]) + if defined wantarray; } 1; diff --git a/lib/DBIx/Class/Admin.pm b/lib/DBIx/Class/Admin.pm index 60d8c9e73..300c48540 100644 --- a/lib/DBIx/Class/Admin.pm +++ b/lib/DBIx/Class/Admin.pm @@ -92,7 +92,7 @@ sub _build_schema { my ($self) = @_; $self->connect_info->[3]{ignore_version} = 1; - return $self->schema_class->connect(@{$self->connect_info}); + return $self->schema_class->clone->connection(@{$self->connect_info}); } =head2 resultset @@ -340,7 +340,13 @@ sub create { my $schema = $self->schema(); - $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args ); + $schema->create_ddl_dir( + $sqlt_type, + (defined $schema->schema_version ? $schema->schema_version : ""), + $self->sql_dir, + $preversion, + $sqlt_args, + ); } @@ -474,7 +480,8 @@ sub update { $where ||= $self->where(); $set ||= $self->set(); my $resultset = $self->schema->resultset($rs); - $resultset = $resultset->search( ($where||{}) ); + $resultset = $resultset->search_rs( $where ) + if $where; my $count = $resultset->count(); print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet); @@ -505,7 +512,8 @@ sub delete { $where ||= $self->where(); $attrs ||= $self->attrs(); my $resultset = $self->schema->resultset($rs); - $resultset = $resultset->search( ($where||{}), ($attrs||()) ); + $resultset = $resultset->search_rs( ($where||{}), ($attrs||()) ) + if $where or $attrs; my $count = $resultset->count(); print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet); @@ -536,7 +544,8 @@ sub select { $where ||= $self->where(); $attrs ||= $self->attrs(); my $resultset = $self->schema->resultset($rs); - $resultset = $resultset->search( ($where||{}), ($attrs||()) ); + $resultset = $resultset->search_rs( ($where||{}), ($attrs||()) ) + if $where or $attrs; my @data; my @columns = $resultset->result_source->columns(); diff --git a/lib/DBIx/Class/CDBICompat/AbstractSearch.pm b/lib/DBIx/Class/CDBICompat/AbstractSearch.pm index 8f5910614..23c009e1b 100644 --- a/lib/DBIx/Class/CDBICompat/AbstractSearch.pm +++ b/lib/DBIx/Class/CDBICompat/AbstractSearch.pm @@ -4,6 +4,8 @@ package # hide form PAUSE use strict; use warnings; +use base 'DBIx::Class'; + =head1 NAME DBIx::Class::CDBICompat::AbstractSearch - Emulates Class::DBI::AbstractSearch diff --git a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm index 15559371c..e235440ec 100644 --- a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm +++ b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm @@ -4,6 +4,8 @@ package # hide from PAUSE Indexer use strict; use warnings; +use base 'DBIx::Class'; + use Scalar::Util 'blessed'; use namespace::clean; diff --git a/lib/DBIx/Class/CDBICompat/AttributeAPI.pm b/lib/DBIx/Class/CDBICompat/AttributeAPI.pm index abf9ac09b..1e7618638 100644 --- a/lib/DBIx/Class/CDBICompat/AttributeAPI.pm +++ b/lib/DBIx/Class/CDBICompat/AttributeAPI.pm @@ -4,12 +4,14 @@ package # hide from PAUSE use strict; use warnings; +use base 'DBIx::Class'; + sub _attrs { my ($self, @atts) = @_; return @{$self->{_column_data}}{@atts}; } -*_attr = \&_attrs; +sub _attr { shift->_attrs(@_) } sub _attribute_store { my $self = shift; diff --git a/lib/DBIx/Class/CDBICompat/AutoUpdate.pm b/lib/DBIx/Class/CDBICompat/AutoUpdate.pm index c32c12520..f7ba08500 100644 --- a/lib/DBIx/Class/CDBICompat/AutoUpdate.pm +++ b/lib/DBIx/Class/CDBICompat/AutoUpdate.pm @@ -4,9 +4,9 @@ package # hide from PAUSE use strict; use warnings; -use base qw/Class::Data::Inheritable/; +use base 'DBIx::Class'; -__PACKAGE__->mk_classdata('__AutoCommit'); +__PACKAGE__->mk_group_accessors( inherited => '__AutoCommit' ); sub set_column { my $self = shift; diff --git a/lib/DBIx/Class/CDBICompat/ColumnCase.pm b/lib/DBIx/Class/CDBICompat/ColumnCase.pm index 13bec9cbe..7f308e876 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnCase.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnCase.pm @@ -4,14 +4,16 @@ package # hide from PAUSE use strict; use warnings; +use base 'DBIx::Class'; + sub _register_column_group { my ($class, $group, @cols) = @_; return $class->next::method($group => map lc, @cols); } -sub add_columns { +sub add_columns :DBIC_method_is_bypassable_resultsource_proxy { my ($class, @cols) = @_; - return $class->result_source_instance->add_columns(map lc, @cols); + return $class->result_source->add_columns(map lc, @cols); } sub has_a { diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm index f4c8ac80a..f65a35806 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm @@ -3,14 +3,16 @@ package # hide from PAUSE use strict; use warnings; -use Sub::Name (); -use List::Util (); use base qw/DBIx::Class::Row/; +use List::Util (); +use DBIx::Class::_Util 'set_subname'; +use namespace::clean; + __PACKAGE__->mk_classdata('_column_groups' => { }); -sub columns { +sub columns :DBIC_method_is_bypassable_resultsource_proxy { my $proto = shift; my $class = ref $proto || $proto; my $group = shift || "All"; @@ -32,9 +34,9 @@ sub _add_column_group { $class->_register_column_group($group => @cols); } -sub add_columns { +sub add_columns :DBIC_method_is_bypassable_resultsource_proxy { my ($class, @cols) = @_; - $class->result_source_instance->add_columns(@cols); + $class->result_source->add_columns(@cols); } sub _register_column_group { @@ -83,7 +85,23 @@ sub _register_column_group { no strict 'refs'; my $existing_accessor = *{$class .'::'. $name}{CODE}; - return $existing_accessor && !$our_accessors{$existing_accessor}; + + return( + defined $existing_accessor + and + ! $our_accessors{$existing_accessor} + and + # under 5.8 mro the CODE slot may simply be a "cached method" + ! ( + DBIx::Class::_ENV_::OLD_MRO + and + grep { + $_ ne $class + and + ( $Class::C3::MRO{$_} || {} )->{methods}{$name} + } @{mro::get_linear_isa($class)} + ) + ) } sub _deploy_accessor { @@ -95,7 +113,7 @@ sub _register_column_group { no strict 'refs'; no warnings 'redefine'; my $fullname = join '::', $class, $name; - *$fullname = Sub::Name::subname $fullname, $accessor; + *$fullname = set_subname $fullname, $accessor; } $our_accessors{$accessor}++; @@ -121,20 +139,16 @@ sub _mk_group_accessors { ($name, $field) = @$field if ref $field; - my $accessor = $class->$maker($group, $field); - my $alias = "_${name}_accessor"; - - # warn " $field $alias\n"; - { - no strict 'refs'; - - $class->_deploy_accessor($name, $accessor); - $class->_deploy_accessor($alias, $accessor); + for( $name, "_${name}_accessor" ) { + $class->_deploy_accessor( + $_, + $class->$maker($group, $field, $_) + ); } } } -sub all_columns { return shift->result_source_instance->columns; } +sub all_columns { return shift->result_source->columns; } sub primary_column { my ($class) = @_; diff --git a/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm b/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm index c5c1fe179..51b6e0baa 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm @@ -4,6 +4,7 @@ package use strict; use warnings; +use base 'DBIx::Class'; =head1 NAME diff --git a/lib/DBIx/Class/CDBICompat/Constraints.pm b/lib/DBIx/Class/CDBICompat/Constraints.pm index 1014886be..f77db5222 100644 --- a/lib/DBIx/Class/CDBICompat/Constraints.pm +++ b/lib/DBIx/Class/CDBICompat/Constraints.pm @@ -1,6 +1,8 @@ package # hide from PAUSE DBIx::Class::CDBICompat::Constraints; +use base 'DBIx::Class'; + use strict; use warnings; diff --git a/lib/DBIx/Class/CDBICompat/Constructor.pm b/lib/DBIx/Class/CDBICompat/Constructor.pm index 65ce576f1..78c6d333a 100644 --- a/lib/DBIx/Class/CDBICompat/Constructor.pm +++ b/lib/DBIx/Class/CDBICompat/Constructor.pm @@ -8,6 +8,7 @@ use base 'DBIx::Class::CDBICompat::ImaDBI'; use Carp; use DBIx::Class::_Util qw(quote_sub perlstring); +use namespace::clean; __PACKAGE__->set_sql(Retrieve => <<''); SELECT __ESSENTIAL__ diff --git a/lib/DBIx/Class/CDBICompat/Copy.pm b/lib/DBIx/Class/CDBICompat/Copy.pm index 77e7b5be7..59780e650 100644 --- a/lib/DBIx/Class/CDBICompat/Copy.pm +++ b/lib/DBIx/Class/CDBICompat/Copy.pm @@ -4,7 +4,10 @@ package # hide from PAUSE use strict; use warnings; +use base 'DBIx::Class'; + use Carp; +use namespace::clean; =head1 NAME diff --git a/lib/DBIx/Class/CDBICompat/DestroyWarning.pm b/lib/DBIx/Class/CDBICompat/DestroyWarning.pm index 61d243c42..998bc5d15 100644 --- a/lib/DBIx/Class/CDBICompat/DestroyWarning.pm +++ b/lib/DBIx/Class/CDBICompat/DestroyWarning.pm @@ -3,6 +3,9 @@ package # hide from PAUSE use strict; use warnings; + +use base 'DBIx::Class'; + use DBIx::Class::_Util 'detected_reinvoked_destructor'; use namespace::clean; diff --git a/lib/DBIx/Class/CDBICompat/GetSet.pm b/lib/DBIx/Class/CDBICompat/GetSet.pm index dd621f27d..e9480488c 100644 --- a/lib/DBIx/Class/CDBICompat/GetSet.pm +++ b/lib/DBIx/Class/CDBICompat/GetSet.pm @@ -4,7 +4,7 @@ package # hide from PAUSE use strict; use warnings; -#use base qw/Class::Accessor/; +use base 'DBIx::Class'; sub get { my ($self, @cols) = @_; diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm index 0ec699386..43537ff40 100644 --- a/lib/DBIx/Class/CDBICompat/ImaDBI.pm +++ b/lib/DBIx/Class/CDBICompat/ImaDBI.pm @@ -4,9 +4,11 @@ package # hide from PAUSE use strict; use warnings; use DBIx::ContextualFetch; -use DBIx::Class::_Util qw(quote_sub perlstring); -use base qw(Class::Data::Inheritable); +use base 'DBIx::Class'; + +use DBIx::Class::_Util qw(quote_sub perlstring); +use namespace::clean; __PACKAGE__->mk_classdata('sql_transformer_class' => 'DBIx::Class::CDBICompat::SQLTransformer'); @@ -50,9 +52,12 @@ sub sth_to_objects { $sth->execute(@$execute_args); - my @ret; + my (@ret, $rsrc); while (my $row = $sth->fetchrow_hashref) { - push(@ret, $class->inflate_result($class->result_source_instance, $row)); + push(@ret, $class->inflate_result( + ( $rsrc ||= $class->result_source ), + $row + )); } return @ret; diff --git a/lib/DBIx/Class/CDBICompat/Iterator.pm b/lib/DBIx/Class/CDBICompat/Iterator.pm index 86a3838c4..499583718 100644 --- a/lib/DBIx/Class/CDBICompat/Iterator.pm +++ b/lib/DBIx/Class/CDBICompat/Iterator.pm @@ -3,6 +3,7 @@ package DBIx::Class::CDBICompat::Iterator; use strict; use warnings; +use base 'DBIx::Class'; =head1 NAME diff --git a/lib/DBIx/Class/CDBICompat/LazyLoading.pm b/lib/DBIx/Class/CDBICompat/LazyLoading.pm index 798fcd39d..d14b4b748 100644 --- a/lib/DBIx/Class/CDBICompat/LazyLoading.pm +++ b/lib/DBIx/Class/CDBICompat/LazyLoading.pm @@ -4,11 +4,12 @@ package # hide from PAUSE use strict; use warnings; +use base 'DBIx::Class'; + sub resultset_instance { my $self = shift; - my $rs = $self->next::method(@_); - $rs = $rs->search(undef, { columns => [ $self->columns('Essential') ] }); - return $rs; + $self->next::method(@_) + ->search_rs(undef, { columns => [ $self->columns('Essential') ] }); } @@ -96,7 +97,7 @@ sub _flesh { my %want; $want{$_} = 1 for map { keys %{$self->_column_groups->{$_}} } @groups; if (my @want = grep { !exists $self->{'_column_data'}{$_} } keys %want) { - my $cursor = $self->result_source->storage->select( + my $cursor = $self->result_source->schema->storage->select( $self->result_source->name, \@want, \$self->_ident_cond, { bind => [ $self->_ident_values ] }); #my $sth = $self->storage->select($self->_table_name, \@want, diff --git a/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm b/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm index f05eff7d0..de17f97ed 100644 --- a/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm +++ b/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm @@ -5,8 +5,9 @@ use strict; use warnings; use Scalar::Util qw/weaken/; +use namespace::clean; -use base qw/Class::Data::Inheritable/; +use base 'DBIx::Class'; __PACKAGE__->mk_classdata('purge_object_index_every' => 1000); __PACKAGE__->mk_classdata('live_object_index' => { }); diff --git a/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm b/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm index f3c472da4..e98e5eb4b 100644 --- a/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm +++ b/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm @@ -4,6 +4,8 @@ package # hide from PAUSE use strict; use warnings; +use base 'DBIx::Class'; + =head1 NAME DBIx::Class::CDBICompat::NoObjectIndex - Defines empty methods for object indexing. They do nothing diff --git a/lib/DBIx/Class/CDBICompat/Pager.pm b/lib/DBIx/Class/CDBICompat/Pager.pm index 203b59855..7316d9d11 100644 --- a/lib/DBIx/Class/CDBICompat/Pager.pm +++ b/lib/DBIx/Class/CDBICompat/Pager.pm @@ -8,7 +8,9 @@ use strict; # leaving the compat layer as-is, something may in fact depend on that use warnings FATAL => 'all'; -*pager = \&page; +use base 'DBIx::Class'; + +sub pager { shift->page(@_) } sub page { my $class = shift; diff --git a/lib/DBIx/Class/CDBICompat/ReadOnly.pm b/lib/DBIx/Class/CDBICompat/ReadOnly.pm index 669a76d7f..9bab1f4c8 100644 --- a/lib/DBIx/Class/CDBICompat/ReadOnly.pm +++ b/lib/DBIx/Class/CDBICompat/ReadOnly.pm @@ -4,6 +4,8 @@ package # hide from PAUSE use strict; use warnings; +use base 'DBIx::Class'; + sub make_read_only { my $proto = shift; $proto->add_trigger("before_$_" => sub { shift->throw_exception("$proto is read only") }) diff --git a/lib/DBIx/Class/CDBICompat/Relationship.pm b/lib/DBIx/Class/CDBICompat/Relationship.pm index 95e414d1c..54962cd51 100644 --- a/lib/DBIx/Class/CDBICompat/Relationship.pm +++ b/lib/DBIx/Class/CDBICompat/Relationship.pm @@ -4,7 +4,10 @@ package use strict; use warnings; +use base 'DBIx::Class'; + use DBIx::Class::_Util 'quote_sub'; +use namespace::clean; =head1 NAME diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm index 8d923b318..7b08d07d9 100644 --- a/lib/DBIx/Class/CDBICompat/Relationships.pm +++ b/lib/DBIx/Class/CDBICompat/Relationships.pm @@ -3,12 +3,13 @@ package # hide from PAUSE use strict; use warnings; -use base 'Class::Data::Inheritable'; +use base 'DBIx::Class'; use Clone; use DBIx::Class::CDBICompat::Relationship; use Scalar::Util 'blessed'; use DBIx::Class::_Util qw(quote_sub perlstring); +use namespace::clean; __PACKAGE__->mk_classdata('__meta_info' => {}); @@ -65,7 +66,7 @@ sub _declare_has_a { } else { $self->belongs_to($col, $f_class); - $rel_info = $self->result_source_instance->relationship_info($col); + $rel_info = $self->result_source->relationship_info($col); } $rel_info->{args} = \%args; @@ -109,14 +110,14 @@ sub has_many { if( !$f_key and !@f_method ) { $class->ensure_class_loaded($f_class); - my $f_source = $f_class->result_source_instance; + my $f_source = $f_class->result_source; ($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class } $f_source->relationships; } $class->next::method($rel, $f_class, $f_key, $args); - my $rel_info = $class->result_source_instance->relationship_info($rel); + my $rel_info = $class->result_source->relationship_info($rel); $args->{mapping} = \@f_method; $args->{foreign_key} = $f_key; $rel_info->{args} = $args; @@ -127,8 +128,13 @@ sub has_many { ); if (@f_method) { - quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel), { '$rf' => \sub { my $o = shift; $o = $o->$_ for @f_method; $o } }; - my $rs = shift->search_related( %s => @_); + my @qsub_args = ( + { '$rf' => \sub { my $o = shift; $o = $o->$_ for @f_method; $o } }, + { attributes => [ 'DBIC_method_is_generated_from_resultsource_metadata' ] }, + ); + + quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel), @qsub_args; + my $rs = shift->related_resultset(%s)->search_rs( @_); $rs->{attrs}{record_filter} = $rf; return (wantarray ? $rs->all : $rs); EOC @@ -149,7 +155,7 @@ sub might_have { { proxy => \@columns }); } - my $rel_info = $class->result_source_instance->relationship_info($rel); + my $rel_info = $class->result_source->relationship_info($rel); $rel_info->{args}{import} = \@columns; $class->_extend_meta( @@ -193,7 +199,7 @@ sub meta_info { sub search { my $self = shift; my $attrs = {}; - if (@_ > 1 && ref $_[$#_] eq 'HASH') { + if (@_ > 1 && ref $_[-1] eq 'HASH') { $attrs = { %{ pop(@_) } }; } my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift) @@ -212,7 +218,10 @@ sub search { } sub new_related { - return shift->search_related(shift)->new_result(shift); + $_[0]->throw_exception("Calling new_related() as a class method is not supported") + unless length ref $_[0]; + + shift->next::method(@_); } =head1 FURTHER QUESTIONS? diff --git a/lib/DBIx/Class/CDBICompat/Retrieve.pm b/lib/DBIx/Class/CDBICompat/Retrieve.pm index 87f531818..2ddd4b297 100644 --- a/lib/DBIx/Class/CDBICompat/Retrieve.pm +++ b/lib/DBIx/Class/CDBICompat/Retrieve.pm @@ -8,6 +8,8 @@ use strict; # leaving the compat layer as-is, something may in fact depend on that use warnings FATAL => 'all'; +use base 'DBIx::Class'; + sub retrieve { my $self = shift; die "No args to retrieve" unless @_ > 0; diff --git a/lib/DBIx/Class/CDBICompat/SQLTransformer.pm b/lib/DBIx/Class/CDBICompat/SQLTransformer.pm index fd54b7e21..cc9d9f069 100644 --- a/lib/DBIx/Class/CDBICompat/SQLTransformer.pm +++ b/lib/DBIx/Class/CDBICompat/SQLTransformer.pm @@ -3,6 +3,8 @@ package DBIx::Class::CDBICompat::SQLTransformer; use strict; use warnings; +use base 'DBIx::Class'; + =head1 NAME DBIx::Class::CDBICompat::SQLTransformer - Transform SQL diff --git a/lib/DBIx/Class/CDBICompat/Stringify.pm b/lib/DBIx/Class/CDBICompat/Stringify.pm index 4d13171e8..e1c9a36a5 100644 --- a/lib/DBIx/Class/CDBICompat/Stringify.pm +++ b/lib/DBIx/Class/CDBICompat/Stringify.pm @@ -4,7 +4,7 @@ package # hide from PAUSE use strict; use warnings; -use Scalar::Util; +use base 'DBIx::Class'; use overload '""' => sub { return shift->stringify_self; }, diff --git a/lib/DBIx/Class/CDBICompat/TempColumns.pm b/lib/DBIx/Class/CDBICompat/TempColumns.pm index 428719ed2..9783d6ae7 100644 --- a/lib/DBIx/Class/CDBICompat/TempColumns.pm +++ b/lib/DBIx/Class/CDBICompat/TempColumns.pm @@ -3,9 +3,10 @@ package # hide from PAUSE use strict; use warnings; -use base qw/Class::Data::Inheritable/; +use base 'DBIx::Class'; use Carp; +use namespace::clean; __PACKAGE__->mk_classdata('_temp_columns' => { }); diff --git a/lib/DBIx/Class/CDBICompat/Triggers.pm b/lib/DBIx/Class/CDBICompat/Triggers.pm index 3f6aef7a4..0428b6acc 100644 --- a/lib/DBIx/Class/CDBICompat/Triggers.pm +++ b/lib/DBIx/Class/CDBICompat/Triggers.pm @@ -3,6 +3,9 @@ package # hide from PAUSE use strict; use warnings; + +use base 'DBIx::Class'; + use Class::Trigger; sub insert { diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm index fbd37e5b4..e1c83a0ca 100644 --- a/lib/DBIx/Class/Carp.pm +++ b/lib/DBIx/Class/Carp.pm @@ -9,22 +9,67 @@ use warnings; use Carp (); $Carp::Internal{ (__PACKAGE__) }++; +use Scalar::Util (); + +# Because... sigh +# There are cases out there where a user provides a can() that won't actually +# work as perl intends it. Since this is a reporting library, we *have* to be +# extra paranoid ( e.g. https://rt.cpan.org/Ticket/Display.html?id=90715 ) +sub __safe_can ($$) { + local $@; + local $SIG{__DIE__} if $SIG{__DIE__}; + + my $cref; + eval { + $cref = $_[0]->can( $_[1] ); + + # in case the can() isn't an actual UNIVERSAL::can() + die "Return value of $_[0]" . "->can(q($_[1])) is true yet not a code reference...\n" + if $cref and Scalar::Util::reftype($cref) ne 'CODE'; + + 1; + } or do { + undef $cref; + + # can not use DBIC::_Util::emit_loud_diag - it uses us internally + printf STDERR + "\n$0: !!! INTERNAL PANIC !!!\nClass '%s' implements or inherits a broken can() - PLEASE FIX ASAP!: %s\n\n", + ( length ref $_[0] ? ref $_[0] : $_[0] ), + $@, + ; + }; + + $cref; +} + sub __find_caller { my ($skip_pattern, $class) = @_; my $skip_class_data = $class->_skip_namespace_frames - if ($class and $class->can('_skip_namespace_frames')); + if ($class and __safe_can($class, '_skip_namespace_frames') ); $skip_pattern = qr/$skip_pattern|$skip_class_data/ if $skip_class_data; my $fr_num = 1; # skip us and the calling carp* - my (@f, $origin); + my (@f, $origin, $eval_src); while (@f = CORE::caller($fr_num++)) { - next if - ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ ); + undef $eval_src; + + next if ( + $f[2] == 0 + or + # there is no value reporting a sourceless eval frame + ( + ( $f[3] eq '(eval)' or $f[1] =~ /^\(eval \d+\)$/ ) + and + not defined ( $eval_src = (CORE::caller($fr_num))[6] ) + ) + or + $f[3] =~ /::__ANON__$/ + ); $origin ||= ( $f[3] =~ /^ (.+) :: ([^\:]+) $/x @@ -40,7 +85,7 @@ sub __find_caller { ) ? $f[3] : undef; if ( - $f[0]->can('_skip_namespace_frames') + __safe_can( $f[0], '_skip_namespace_frames' ) and my $extra_skip = $f[0]->_skip_namespace_frames ) { @@ -51,7 +96,7 @@ sub __find_caller { } my $site = @f # if empty - nothing matched - full stack - ? "at $f[1] line $f[2]" + ? ( "at $f[1] line $f[2]" . ( $eval_src ? "\n === BEGIN $f[1]\n$eval_src\n === END $f[1]" : '' ) ) : Carp::longmess() ; diff --git a/lib/DBIx/Class/Componentised.pm b/lib/DBIx/Class/Componentised.pm index 0fb91ad01..b417de6bb 100644 --- a/lib/DBIx/Class/Componentised.pm +++ b/lib/DBIx/Class/Componentised.pm @@ -7,6 +7,7 @@ use warnings; use base 'Class::C3::Componentised'; use mro 'c3'; +use DBIx::Class::_Util 'get_subname'; use DBIx::Class::Carp '^DBIx::Class|^Class::C3::Componentised'; use namespace::clean; @@ -54,8 +55,7 @@ sub inject_base { or next; if ($sc ne $base_store_column) { - require B; - my $definer = B::svref_2object($sc)->STASH->NAME; + my ($definer) = get_subname($sc); push @broken, ($definer eq $existing_comp) ? $existing_comp : "$existing_comp (via $definer)" diff --git a/lib/DBIx/Class/DB.pm b/lib/DBIx/Class/DB.pm index b7e539473..df232b305 100644 --- a/lib/DBIx/Class/DB.pm +++ b/lib/DBIx/Class/DB.pm @@ -61,7 +61,7 @@ it. See resolve_class below. =cut -__PACKAGE__->mk_classdata('class_resolver' => +__PACKAGE__->mk_classaccessor('class_resolver' => 'DBIx::Class::ClassResolver::PassThrough'); =begin hidden @@ -101,7 +101,7 @@ sub setup_schema_instance { my $class = shift; my $schema = {}; bless $schema, 'DBIx::Class::Schema'; - $class->mk_classdata('schema_instance' => $schema); + $class->mk_classaccessor('schema_instance' => $schema); } =begin hidden @@ -176,7 +176,7 @@ native L system. =cut sub resultset_instance { - $_[0]->result_source_instance->resultset + $_[0]->result_source->resultset } =begin hidden @@ -189,12 +189,12 @@ Returns an instance of the result source for this class =cut -__PACKAGE__->mk_classdata('_result_source_instance' => []); +__PACKAGE__->mk_classaccessor('_result_source_instance' => []); # Yep. this is horrific. Basically what's happening here is that # (with good reason) DBIx::Class::Schema copies the result source for # registration. Because we have a retarded setup order forced on us we need -# to actually make our ->result_source_instance -be- the source used, and we +# to actually make our ->result_source -be- the source used, and we # need to get the source name and schema into ourselves. So this makes it # happen. @@ -222,15 +222,14 @@ sub result_source_instance { } my($source, $result_class) = @{$class->_result_source_instance}; - return unless blessed $source; + return undef unless blessed $source; if ($result_class ne $class) { # new class # Give this new class its own source and register it. - $source = $source->new({ - %$source, + $source = $source->clone( source_name => $class, result_class => $class - } ); + ); $class->_result_source_instance([$source, $class]); $class->_maybe_attach_source_to_schema($source); } diff --git a/lib/DBIx/Class/FilterColumn.pm b/lib/DBIx/Class/FilterColumn.pm index fedbf79c5..c280b47a6 100644 --- a/lib/DBIx/Class/FilterColumn.pm +++ b/lib/DBIx/Class/FilterColumn.pm @@ -9,14 +9,11 @@ use namespace::clean; sub filter_column { my ($self, $col, $attrs) = @_; - my $colinfo = $self->column_info($col); + my $colinfo = $self->result_source->columns_info([$col])->{$col}; $self->throw_exception("FilterColumn can not be used on a column with a declared InflateColumn inflator") if defined $colinfo->{_inflate_info} and $self->isa('DBIx::Class::InflateColumn'); - $self->throw_exception("No such column $col to filter") - unless $self->has_column($col); - $self->throw_exception('filter_column expects a hashref of filter specifications') unless ref $attrs eq 'HASH'; @@ -34,8 +31,7 @@ sub _column_from_storage { return $value if is_literal_value($value); - my $info = $self->result_source->column_info($col) - or $self->throw_exception("No column info for $col"); + my $info = $self->result_source->columns_info([$col])->{$col}; return $value unless exists $info->{_filter_info}; @@ -49,8 +45,7 @@ sub _column_to_storage { return $value if is_literal_value($value); - my $info = $self->result_source->column_info($col) or - $self->throw_exception("No column info for $col"); + my $info = $self->result_source->columns_info([$col])->{$col}; return $value unless exists $info->{_filter_info}; @@ -63,7 +58,7 @@ sub get_filtered_column { my ($self, $col) = @_; $self->throw_exception("$col is not a filtered column") - unless exists $self->result_source->column_info($col)->{_filter_info}; + unless exists $self->result_source->columns_info->{$col}{_filter_info}; return $self->{_filtered_column}{$col} if exists $self->{_filtered_column}{$col}; @@ -78,11 +73,13 @@ sub get_filtered_column { sub get_column { my ($self, $col) = @_; - if (exists $self->{_filtered_column}{$col}) { - return $self->{_column_data}{$col} ||= $self->_column_to_storage ( - $col, $self->{_filtered_column}{$col} - ); - } + ! exists $self->{_column_data}{$col} + and + exists $self->{_filtered_column}{$col} + and + $self->{_column_data}{$col} = $self->_column_to_storage ( + $col, $self->{_filtered_column}{$col} + ); return $self->next::method ($col); } @@ -101,6 +98,22 @@ sub get_columns { $self->next::method (@_); } +# and *another* separate codepath, argh! +sub get_dirty_columns { + my $self = shift; + + $self->{_dirty_columns}{$_} + and + ! exists $self->{_column_data}{$_} + and + $self->{_column_data}{$_} = $self->_column_to_storage ( + $_, $self->{_filtered_column}{$_} + ) + for keys %{$self->{_filtered_column}||{}}; + + $self->next::method(@_); +} + sub store_column { my ($self, $col) = (shift, @_); diff --git a/lib/DBIx/Class/InflateColumn.pm b/lib/DBIx/Class/InflateColumn.pm index 27bde589e..c16375d2d 100644 --- a/lib/DBIx/Class/InflateColumn.pm +++ b/lib/DBIx/Class/InflateColumn.pm @@ -87,15 +87,14 @@ L sub inflate_column { my ($self, $col, $attrs) = @_; - my $colinfo = $self->column_info($col); + my $colinfo = $self->result_source->columns_info([$col])->{$col}; $self->throw_exception("InflateColumn can not be used on a column with a declared FilterColumn filter") if defined $colinfo->{_filter_info} and $self->isa('DBIx::Class::FilterColumn'); - $self->throw_exception("No such column $col to inflate") - unless $self->has_column($col); $self->throw_exception("inflate_column needs attr hashref") unless ref $attrs eq 'HASH'; + $colinfo->{_inflate_info} = $attrs; my $acc = $colinfo->{accessor}; $self->mk_group_accessors('inflated_column' => [ (defined $acc ? $acc : $col), $col]); @@ -111,8 +110,7 @@ sub _inflated_column { is_literal_value($value) #that would be a not-yet-reloaded literal update ); - my $info = $self->result_source->column_info($col) - or $self->throw_exception("No column info for $col"); + my $info = $self->result_source->columns_info([$col])->{$col}; return $value unless exists $info->{_inflate_info}; @@ -133,8 +131,7 @@ sub _deflated_column { is_literal_value($value) ); - my $info = $self->result_source->column_info($col) or - $self->throw_exception("No column info for $col"); + my $info = $self->result_source->columns_info([$col])->{$col}; return $value unless exists $info->{_inflate_info}; @@ -160,7 +157,7 @@ sub get_inflated_column { my ($self, $col) = @_; $self->throw_exception("$col is not an inflated column") - unless exists $self->result_source->column_info($col)->{_inflate_info}; + unless exists $self->result_source->columns_info->{$col}{_inflate_info}; # we take care of keeping things in sync return $self->{_inflated_column}{$col} diff --git a/lib/DBIx/Class/InflateColumn/DateTime.pm b/lib/DBIx/Class/InflateColumn/DateTime.pm index 8ccdf7ab1..32916680a 100644 --- a/lib/DBIx/Class/InflateColumn/DateTime.pm +++ b/lib/DBIx/Class/InflateColumn/DateTime.pm @@ -4,8 +4,7 @@ use strict; use warnings; use base qw/DBIx::Class/; use DBIx::Class::Carp; -use DBIx::Class::_Util 'dbic_internal_try'; -use Try::Tiny; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); use namespace::clean; =head1 NAME @@ -31,12 +30,19 @@ Then you can treat the specified column as a L object. print "This event starts the month of ". $event->starts_when->month_name(); -If you want to set a specific timezone and locale for that field, use: +If you want to set a specific time zone and locale for that field, use: __PACKAGE__->add_columns( - starts_when => { data_type => 'datetime', timezone => "America/Chicago", locale => "de_DE" } + starts_when => { data_type => 'datetime', time_zone => "America/Chicago", locale => "de_DE" } ); +Note: DBIC before 0.082900 only accepted C, and silently discarded +any C arguments. For backwards compatibility, C will +continue being accepted as a synonym for C, and the value will +continue to be available in the +L<< C hash|DBIx::Class::ResultSource/column_info >> +under both names. + If you want to inflate no matter what data_type your column is, use inflate_datetime or inflate_date: @@ -73,7 +79,7 @@ that this feature is new as of 0.07, so it may not be perfect yet - bug reports to the list very much welcome). If the data_type of a field is C, C or C (or -a derivative of these datatypes, e.g. C), this +a derivative of these datatypes, e.g. C), this module will automatically call the appropriate parse/format method for deflation/inflation as defined in the storage class. For instance, for a C field the methods C and C @@ -152,7 +158,7 @@ sub register_column { } if ($info->{extra}) { - for my $slot (qw/timezone locale floating_tz_ok/) { + for my $slot (qw/time_zone timezone locale floating_tz_ok/) { if ( defined $info->{extra}{$slot} ) { carp "Putting $slot into extra => { $slot => '...' } has been deprecated, ". "please put it directly into the '$column' column definition."; @@ -161,6 +167,17 @@ sub register_column { } } + # Store the time zone under both 'timezone' for backwards compatibility and + # 'time_zone' for DateTime ecosystem consistency + if ( defined $info->{timezone} ) { + $self->throw_exception("Conflicting 'timezone' and 'time_zone' values in '$column' column defintion.") + if defined $info->{time_zone} and $info->{time_zone} ne $info->{timezone}; + $info->{time_zone} = $info->{timezone}; + } + elsif ( defined $info->{time_zone} ) { + $info->{timezone} = $info->{time_zone}; + } + # shallow copy to avoid unfounded(?) Devel::Cycle complaints my $infcopy = {%$info}; @@ -198,12 +215,13 @@ sub _flate_or_fallback my $preferred_method = sprintf($method_fmt, $info->{ _ic_dt_method }); my $method = $parser->can($preferred_method) || sprintf($method_fmt, 'datetime'); - return dbic_internal_try { + dbic_internal_try { $parser->$method($value); } - catch { + dbic_internal_catch { $self->throw_exception ("Error while inflating '$value' for $info->{__dbic_colname} on ${self}: $_") unless $info->{datetime_undef_if_invalid}; + undef; # rv }; } @@ -219,13 +237,13 @@ sub _deflate_from_datetime { } sub _datetime_parser { - shift->result_source->storage->datetime_parser (@_); + shift->result_source->schema->storage->datetime_parser (@_); } sub _post_inflate_datetime { my( $self, $dt, $info ) = @_; - $dt->set_time_zone($info->{timezone}) if defined $info->{timezone}; + $dt->set_time_zone($info->{time_zone}) if defined $info->{time_zone}; $dt->set_locale($info->{locale}) if defined $info->{locale}; return $dt; @@ -234,14 +252,14 @@ sub _post_inflate_datetime { sub _pre_deflate_datetime { my( $self, $dt, $info ) = @_; - if (defined $info->{timezone}) { - carp "You're using a floating timezone, please see the documentation of" + if (defined $info->{time_zone}) { + carp "You're using a floating time zone, please see the documentation of" . " DBIx::Class::InflateColumn::DateTime for an explanation" if ref( $dt->time_zone ) eq 'DateTime::TimeZone::Floating' and not $info->{floating_tz_ok} and not $ENV{DBIC_FLOATING_TZ_OK}; - $dt->set_time_zone($info->{timezone}); + $dt->set_time_zone($info->{time_zone}); } $dt->set_locale($info->{locale}) if defined $info->{locale}; @@ -254,13 +272,13 @@ __END__ =head1 USAGE NOTES -If you have a datetime column with an associated C, and subsequently +If you have a datetime column with an associated C, and subsequently create/update this column with a DateTime object in the L -timezone, you will get a warning (as there is a very good chance this will not have the +time zone, you will get a warning (as there is a very good chance this will not have the result you expect). For example: __PACKAGE__->add_columns( - starts_when => { data_type => 'datetime', timezone => "America/Chicago" } + starts_when => { data_type => 'datetime', time_zone => "America/Chicago" } ); my $event = $schema->resultset('EventTZ')->create({ @@ -273,7 +291,7 @@ The warning can be avoided in several ways: =item Fix your broken code -When calling C on a Floating DateTime object, the timezone is simply +When calling C on a Floating DateTime object, the time zone is simply set to the requested value, and B. It is always a good idea to be supply explicit times to the database: @@ -284,7 +302,7 @@ to be supply explicit times to the database: =item Suppress the check on per-column basis __PACKAGE__->add_columns( - starts_when => { data_type => 'datetime', timezone => "America/Chicago", floating_tz_ok => 1 } + starts_when => { data_type => 'datetime', time_zone => "America/Chicago", floating_tz_ok => 1 } ); =item Suppress the check globally @@ -293,7 +311,7 @@ Set the environment variable DBIC_FLOATING_TZ_OK to some true value. =back -Putting extra attributes like timezone, locale or floating_tz_ok into extra => {} has been +Putting extra attributes like time_zone, locale or floating_tz_ok into extra => {} has been B because this gets you into trouble using L. Instead put it directly into the columns definition like in the examples above. If you still use the old way you'll see a warning - please fix your code then! @@ -305,7 +323,7 @@ use the old way you'll see a warning - please fix your code then! =item More information about the add_columns method, and column metadata, can be found in the documentation for L. -=item Further discussion of problems inherent to the Floating timezone: +=item Further discussion of problems inherent to the Floating time zone: L and L<< $dt->set_time_zone|DateTime/"Set" Methods >> diff --git a/lib/DBIx/Class/InflateColumn/File.pm b/lib/DBIx/Class/InflateColumn/File.pm index 3a515a8f6..34db2ed02 100644 --- a/lib/DBIx/Class/InflateColumn/File.pm +++ b/lib/DBIx/Class/InflateColumn/File.pm @@ -2,10 +2,17 @@ package DBIx::Class::InflateColumn::File; use strict; use warnings; + +# check deps +BEGIN { + require DBIx::Class::Optional::Dependencies; + if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('ic_file') ) { + die "The following extra modules are required for DBIx::Class::InflateColumn::File: $missing\n"; + } +} + use base 'DBIx::Class'; -use File::Path; use File::Copy; -use Path::Class; use DBIx::Class::Carp; use namespace::clean; @@ -20,7 +27,6 @@ carp 'InflateColumn::File has entered a deprecation cycle. This component ' unless $ENV{DBIC_IC_FILE_NOWARN}; - __PACKAGE__->load_components(qw/InflateColumn/); sub register_column { @@ -43,7 +49,7 @@ sub register_column { sub _file_column_file { my ($self, $column, $filename) = @_; - my $column_info = $self->result_source->column_info($column); + my $column_info = $self->result_source->columns_info->{$column}; return unless $column_info->{is_file_column}; @@ -68,7 +74,7 @@ sub delete { for ( keys %$colinfos ) { if ( $colinfos->{$_}{is_file_column} ) { - rmtree( [$self->_file_column_file($_)->dir], 0, 0 ); + $self->_file_column_file($_)->dir->rmtree; last; # if we've deleted one, we've deleted them all } } @@ -116,7 +122,7 @@ sub _save_file_column { return unless ref $value; my $fs_file = $self->_file_column_file($column, $value->{filename}); - mkpath [$fs_file->dir]; + $fs_file->dir->mkpath; # File::Copy doesn't like Path::Class (or any for that matter) objects, # thus ->stringify (http://rt.perl.org/rt3/Public/Bug/Display.html?id=59650) diff --git a/lib/DBIx/Class/Manual/Cookbook.pod b/lib/DBIx/Class/Manual/Cookbook.pod index 324ff641c..ce68fc24b 100644 --- a/lib/DBIx/Class/Manual/Cookbook.pod +++ b/lib/DBIx/Class/Manual/Cookbook.pod @@ -125,9 +125,9 @@ almost like you would define a regular ResultSource. # # do not attempt to deploy() this view - __PACKAGE__->result_source_instance->is_virtual(1); + __PACKAGE__->result_source->is_virtual(1); - __PACKAGE__->result_source_instance->view_definition(q[ + __PACKAGE__->result_source->view_definition(q[ SELECT u.* FROM user u INNER JOIN user_friends f ON u.id = f.user_id WHERE f.friend_user_id = ? diff --git a/lib/DBIx/Class/MethodAttributes.pm b/lib/DBIx/Class/MethodAttributes.pm new file mode 100644 index 000000000..9bf5a2d7a --- /dev/null +++ b/lib/DBIx/Class/MethodAttributes.pm @@ -0,0 +1,444 @@ +package DBIx::Class::MethodAttributes; + +use strict; +use warnings; + +use DBIx::Class::_Util qw( uniq refdesc visit_namespaces ); +use Scalar::Util qw( weaken refaddr ); + +use namespace::clean; + +my ( $attr_cref_registry, $attr_cache_active ); +sub DBIx::Class::__Attr_iThreads_handler__::CLONE { + + # This is disgusting, but the best we can do without even more surgery + # Note the if() at the end - we do not run this crap if we can help it + visit_namespaces( action => sub { + my $pkg = shift; + + # skip dangerous namespaces + return 1 if $pkg =~ /^ (?: + DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3 + ) $/x; + + no strict 'refs'; + + if ( + exists ${"${pkg}::"}{__cag___attr_cache} + and + ref( my $attr_stash = ${"${pkg}::__cag___attr_cache"} ) eq 'HASH' + ) { + $attr_stash->{ $attr_cref_registry->{$_}{weakref} } = delete $attr_stash->{$_} + for keys %$attr_stash; + } + + return 1; + }) if $attr_cache_active; + + # renumber the cref registry itself + %$attr_cref_registry = map { + ( defined $_->{weakref} ) + ? ( + # because of how __attr_cache works, ugh + "$_->{weakref}" => $_, + ) + : () + } values %$attr_cref_registry; +} + +sub MODIFY_CODE_ATTRIBUTES { + my $class = shift; + my $code = shift; + + my $attrs; + $attrs->{ + $_ =~ /^[a-z]+$/ ? 'builtin' + : $_ =~ /^DBIC_/ ? 'dbic' + : 'misc' + }{$_}++ for @_; + + + # compaction step + defined $attr_cref_registry->{$_}{weakref} or delete $attr_cref_registry->{$_} + for keys %$attr_cref_registry; + + # The original misc-attr API used stringification instead of refaddr - can't change that now + if( $attr_cref_registry->{$code} ) { + Carp::confess( sprintf + "Coderefs '%s' and '%s' stringify to the same value '%s': nothing will work", + refdesc($code), + refdesc($attr_cref_registry->{$code}{weakref}), + "$code" + ) if refaddr($attr_cref_registry->{$code}{weakref}) != refaddr($code); + } + else { + weaken( $attr_cref_registry->{$code}{weakref} = $code ) + } + + + # increment the pkg gen, this ensures the sanity checkers will re-evaluate + # this class when/if the time comes + mro::method_changed_in($class) if ( + ! DBIx::Class::_ENV_::OLD_MRO + and + ( $attrs->{dbic} or $attrs->{misc} ) + ); + + + # handle legacy attrs + if( $attrs->{misc} ) { + + # if the user never tickles this - we won't have to do a gross + # symtable scan in the ithread handler above, so: + # + # User - please don't tickle this + $attr_cache_active = 1; + + $class->mk_classaccessor('__attr_cache' => {}) + unless $class->can('__attr_cache'); + + $class->__attr_cache->{$code} = [ sort( uniq( + @{ $class->__attr_cache->{$code} || [] }, + keys %{ $attrs->{misc} }, + ))]; + } + + + # handle DBIC_* attrs + if( $attrs->{dbic} ) { + my $slot = $attr_cref_registry->{$code}; + + $slot->{attrs} = [ uniq + @{ $slot->{attrs} || [] }, + grep { + $class->VALID_DBIC_CODE_ATTRIBUTE($_) + or + Carp::confess( "DBIC-specific attribute '$_' did not pass validation by $class->VALID_DBIC_CODE_ATTRIBUTE() as described in DBIx::Class::MethodAttributes" ) + } keys %{$attrs->{dbic}}, + ]; + } + + + # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on: + # decidedly not cool + # + # There should be some sort of warning on unrecognized attributes or + # somesuch... OTOH people do use things in the wild hence the plan of action + # is anything but clear :/ + # + # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/lib/DBIx/Class/Service.pm#L93-110 + # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L29 + # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L36 + # + # For the time being reuse the old logic for any attribute we do not have + # explicit plans for (i.e. stuff that is neither reserved, nor DBIC-internal) + # + # Pass the "builtin attrs" onwards, as the DBIC internals can't possibly handle them + return sort keys %{ $attrs->{builtin} || {} }; +} + +# Address the above FIXME halfway - if something (e.g. DBIC::Helpers) wants to +# add extra attributes - it needs to override this in its base class to allow +# for 'return 1' on the newly defined attributes +sub VALID_DBIC_CODE_ATTRIBUTE { + #my ($class, $attr) = @_; + +### +### !!! IMPORTANT !!! +### +### *DO NOT* yield to the temptation of using free-form-argument attributes. +### The technique was proven instrumental in Catalyst a decade ago, and +### was more recently revived in Sub::Attributes. Yet, while on the surface +### they seem immensely useful, per-attribute argument lists are in fact an +### architectural dead end. +### +### In other words: you are *very strongly urged* to ensure the regex below +### does not allow anything beyond qr/^ DBIC_method_is_ [A-Z_a-z0-9]+ $/x +### + + $_[1] =~ /^ DBIC_method_is_ (?: + indirect_sugar + | + (?: bypassable | mandatory ) _resultsource_proxy + | + generated_from_resultsource_metadata + | + (?: inflated_ | filtered_ )? column_ (?: extra_)? accessor + | + single_relationship_accessor + | + (?: multi | filter ) _relationship_ (?: extra_ )? accessor + | + proxy_to_relationship + | + m2m_ (?: extra_)? sugar (?:_with_attrs)? + ) $/x; +} + +sub FETCH_CODE_ATTRIBUTES { + #my ($class,$code) = @_; + + sort( + @{ $_[0]->_attr_cache->{$_[1]} || [] }, + ( defined( $attr_cref_registry->{$_[1]}{ weakref } ) + ? @{ $attr_cref_registry->{$_[1]}{attrs} || [] } + : () + ), + ) +} + +sub _attr_cache { + my $self = shift; + +{ + %{ $self->can('__attr_cache') ? $self->__attr_cache : {} }, + %{ $self->maybe::next::method || {} }, + }; +} + +1; + +__END__ + +=head1 NAME + +DBIx::Class::MethodAttributes - DBIC-specific handling of CODE attributes + +=head1 SYNOPSIS + + my @attrlist = attributes::get( \&My::App::Schema::Result::some_method ) + +=head1 DESCRIPTION + +This class provides the L inheritance chain with the bits +necessary for L support on methods. + +Historically DBIC has accepted any string as a C attribute and made +such strings available via the semi-private L method. This +was used for e.g. the long-deprecated L, +but also has evidence of use on both C and C. + +Starting mid-2016 DBIC treats any method attribute starting with C +as an I for various DBIC-related methods. +Unlike the general attribute naming policy, strict whitelisting is imposed +on attribute names starting with C as described in +L below. + +=head2 DBIC-specific method attributes + +The following method attributes are currently recognized under the C +prefix: + +=head3 DBIC_method_is_indirect_sugar + +The presence of this attribute indicates a helper "sugar" method. Overriding +such methods in your subclasses will be of limited success at best, as DBIC +itself and various plugins are much more likely to invoke alternative direct +call paths, bypassing your override entirely. Good examples of this are +L and L. + +See also the check +L. + +=head3 DBIC_method_is_mandatory_resultsource_proxy + +=head3 DBIC_method_is_bypassable_resultsource_proxy + +The presence of one of these attributes on a L indicates +how DBIC will behave when someone calls e.g.: + + $some_result->result_source->add_columns(...) + +as opposed to the conventional + + SomeResultClass->add_columns(...) + +This distinction becomes important when someone declares a sub named after +one of the (currently 22) methods proxied from a +L to +L. While there are obviously no +problems when these methods are called at compile time, there is a lot of +ambiguity whether an override of something like +L will be respected by +DBIC and various plugins during runtime operations. + +It must be noted that there is a reason for this weird situation: during the +original design of DBIC the "ResultSourceProxy" system was established in +order to allow easy transition from Class::DBI. Unfortunately it was not +well abstracted away: it is rather difficult to use a custom ResultSource +subclass. The expansion of the DBIC project never addressed this properly +in the years since. As a result when one wishes to override a part of the +ResultSource functionality, the overwhelming practice is to hook a method +in a Result class and "hope for the best". + +The subtle changes of various internal call-chains in C make +this silent uncertainty untenable. As a solution any such override will now +issue a descriptive warning that it has been bypassed during a +C<< $rsrc->overridden_function >> invocation. A user B determine how +each individual override must behave in this situation, and tag it with one +of the above two attributes. + +Naturally any override marked with C<..._bypassable_resultsource_proxy> will +behave like it did before: it will be silently ignored. This is the attribute +you want to set if your code appears to work fine, and you do not wish to +receive the warning anymore (though you are strongly encouraged to understand +the other option). + +However overrides marked with C<..._mandatory_resultsource_proxy> will always +be reinvoked by DBIC itself, so that any call of the form: + + $some_result->result_source->columns_info(...) + +will be transformed into: + + $some_result->result_source->result_class->columns_info(...) + +with the rest of the callchain flowing out of that (provided the override did +invoke L where appropriate) + +=head3 DBIC_method_is_generated_from_resultsource_metadata + +This attribute is applied to all methods dynamically installed after various +invocations of L. Notably +this includes L, +L, +L +and the various L, +B the L (given its +effects are never reflected as C). + +=head3 DBIC_method_is_column_accessor + +This attribute is applied to all methods dynamically installed as a result of +invoking L. + +=head3 DBIC_method_is_inflated_column_accessor + +This attribute is applied to all methods dynamically installed as a result of +invoking L. + +=head3 DBIC_method_is_filtered_column_accessor + +This attribute is applied to all methods dynamically installed as a result of +invoking L. + +=head3 DBIC_method_is_*column_extra_accessor + +For historical reasons any L accessor is generated +twice as C<{name}> and C<_{name}_accessor>. The second method is marked with +C correspondingly. + +=head3 DBIC_method_is_single_relationship_accessor + +This attribute is applied to all methods dynamically installed as a result of +invoking L, +L or +L (though for C +see L<...filter_rel...|/DBIC_method_is_filter_relationship_accessor> below. + +=head3 DBIC_method_is_multi_relationship_accessor + +This attribute is applied to the main method dynamically installed as a result +of invoking L. + +=head3 DBIC_method_is_multi_relationship_extra_accessor + +This attribute is applied to the two extra methods dynamically installed as a +result of invoking L: +C<$relname_rs> and C. + +=head3 DBIC_method_is_filter_relationship_accessor + +This attribute is applied to (legacy) methods dynamically installed as a +result of invoking L with an +already-existing identically named column. The method is internally +implemented as an L +and is labeled with both atributes at the same time. + +=head3 DBIC_method_is_filter_relationship_extra_accessor + +Same as L. + +=head3 DBIC_method_is_proxy_to_relationship + +This attribute is applied to methods dynamically installed as a result of +providing L. + +=head3 DBIC_method_is_m2m_sugar + +=head3 DBIC_method_is_m2m_sugar_with_attrs + +One of the above attributes is applied to the main method dynamically +installed as a result of invoking +L. The C<_with_atrs> suffix +serves to indicate whether the user supplied any C<\%attrs> to the +C call. There is deliberately no mechanism to retrieve the actual +supplied values: if you really need this functionality you would need to rely on +L. + +=head3 DBIC_method_is_extra_m2m_sugar + +=head3 DBIC_method_is_extra_m2m_sugar_with_attrs + +One of the above attributes is applied to the extra B methods dynamically +installed as a result of invoking +L: C<$m2m_rs>, C, +C and C. + +=head1 METHODS + +=head2 MODIFY_CODE_ATTRIBUTES + +See L. + +=head2 FETCH_CODE_ATTRIBUTES + +See L. Always returns the combination of +all attributes: both the free-form strings registered via the +L and the DBIC-specific ones. + +=head2 VALID_DBIC_CODE_ATTRIBUTE + +=over + +=item Arguments: $attribute_string + +=item Return Value: ( true| false ) + +=back + +This method is invoked when processing each DBIC-specific attribute (the ones +starting with C). An attribute is considered invalid and an exception +is thrown unless this method returns a C value. + +=head2 _attr_cache + +=over + +=item Arguments: none + +=item Return Value: B + +=back + +The legacy method of retrieving attributes declared on DBIC methods +(L was not defined until mid-2016). This method +B, and is kept for backwards +compatibility only. + +In order to query the attributes of a particular method use +L as shown in the L. + +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm index a7ab5e5bc..4bb44ff7f 100644 --- a/lib/DBIx/Class/Optional/Dependencies.pm +++ b/lib/DBIx/Class/Optional/Dependencies.pm @@ -144,6 +144,16 @@ my $dbic_reqs = { }, }, + ic_file => { + req => { + 'Path::Class' => '0.18', + }, + pod => { + title => 'DBIx::Class::InflateColumn::File (Deprecated)', + desc => 'Modules required for the deprecated L', + }, + }, + ic_dt => { req => { 'DateTime' => '0.55', @@ -168,7 +178,6 @@ my $dbic_reqs = { cdbicompat => { req => { - 'Class::Data::Inheritable' => '0', 'Class::Trigger' => '0', 'DBIx::ContextualFetch' => '0', 'Clone' => '0.32', @@ -861,7 +870,9 @@ sub skip_without { if ( my $err = $self->req_missing_for($groups) ) { my ($fn, $ln) = (caller(0))[1,2]; $tb->skip("block in $fn around line $ln requires $err"); - local $^W = 0; + + BEGIN { ${^WARNING_BITS} = "" } + last SKIP; } @@ -1144,6 +1155,9 @@ sub _errorlist_for_modreqs { my $v = $reqs->{$m}; if (! exists $req_unavailability_cache{$m}{$v} ) { + # masking this off is important, as it may very well be + # a transient error + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; eval( "require $m;" . ( $v ? "$m->VERSION(q($v))" : '' ) ); $req_unavailability_cache{$m}{$v} = $@; @@ -1204,16 +1218,12 @@ 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]); + require DBIx::Class::_Util; + DBIx::Class::_Util::mkdir_p( DBIx::Class::_Util::parent_dir( $podfn ) ); my $sqltver = $class->req_list_for('deploy')->{'SQL::Translator'} or die "Hrmm? No sqlt dep?"; diff --git a/lib/DBIx/Class/Ordered.pm b/lib/DBIx/Class/Ordered.pm index 4c9a14c6b..cef565efd 100644 --- a/lib/DBIx/Class/Ordered.pm +++ b/lib/DBIx/Class/Ordered.pm @@ -3,7 +3,7 @@ use strict; use warnings; use base qw( DBIx::Class ); -use List::Util 'first'; +use DBIx::Class::_Util qw( bag_eq fail_on_internal_call ); use namespace::clean; =head1 NAME @@ -109,7 +109,7 @@ positional value of each record. Defaults to "position". =cut -__PACKAGE__->mk_classdata( 'position_column' => 'position' ); +__PACKAGE__->mk_classaccessor( 'position_column' => 'position' ); =head2 grouping_column @@ -121,7 +121,7 @@ ordered lists within the same table. =cut -__PACKAGE__->mk_classdata( 'grouping_column' ); +__PACKAGE__->mk_group_accessors( inherited => 'grouping_column' ); =head2 null_position_value @@ -136,7 +136,7 @@ indeed start from 0. =cut -__PACKAGE__->mk_classdata( 'null_position_value' => 0 ); +__PACKAGE__->mk_classaccessor( 'null_position_value' => 0 ); =head2 siblings @@ -146,13 +146,28 @@ __PACKAGE__->mk_classdata( 'null_position_value' => 0 ); Returns an B resultset of all other objects in the same group excluding the one you called it on. +Underneath calls L, and therefore returns +objects by implicitly invoking Lall() >>|DBIx::Class::ResultSet/all> +in list context. + The ordering is a backwards-compatibility artifact - if you need a resultset with no ordering applied use C<_siblings> =cut + sub siblings { - my $self = shift; - return $self->_siblings->search ({}, { order_by => $self->position_column } ); + #my $self = shift; + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + wantarray + and + ! eval { fail_on_internal_call; 1 } + and + die "ILLEGAL LIST CONTEXT INVOCATION: $@"; + + # *MUST* be context sensitive due to legacy (DO NOT call search_rs) + $_[0]->_siblings->search ({}, { order_by => $_[0]->position_column } ); } =head2 previous_siblings @@ -163,15 +178,29 @@ sub siblings { Returns a resultset of all objects in the same group positioned before the object on which this method was called. +Underneath calls L, and therefore returns +objects by implicitly invoking Lall() >>|DBIx::Class::ResultSet/all> +in list context. + =cut sub previous_siblings { my $self = shift; my $position_column = $self->position_column; my $position = $self->get_column ($position_column); - return ( defined $position + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + wantarray + and + ! eval { fail_on_internal_call; 1 } + and + die "ILLEGAL LIST CONTEXT INVOCATION: $@"; + + # *MUST* be context sensitive due to legacy (DO NOT call search_rs) + defined( $position ) ? $self->_siblings->search ({ $position_column => { '<', $position } }) : $self->_siblings - ); + ; } =head2 next_siblings @@ -182,15 +211,29 @@ sub previous_siblings { Returns a resultset of all objects in the same group positioned after the object on which this method was called. +Underneath calls L, and therefore returns +objects by implicitly invoking Lall() >>|DBIx::Class::ResultSet/all> +in list context. + =cut sub next_siblings { my $self = shift; my $position_column = $self->position_column; my $position = $self->get_column ($position_column); - return ( defined $position + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + wantarray + and + ! eval { fail_on_internal_call; 1 } + and + die "ILLEGAL LIST CONTEXT INVOCATION: $@"; + + # *MUST* be context sensitive due to legacy (DO NOT call search_rs) + defined( $position ) ? $self->_siblings->search ({ $position_column => { '>', $position } }) : $self->_siblings - ); + ; } =head2 previous_sibling @@ -206,12 +249,12 @@ sub previous_sibling { my $self = shift; my $position_column = $self->position_column; - my $psib = $self->previous_siblings->search( + my $psib = $self->previous_siblings->search_rs( {}, { rows => 1, order_by => { '-desc' => $position_column } }, )->single; - return defined $psib ? $psib : 0; + return defined( $psib ) ? $psib : 0; } =head2 first_sibling @@ -227,12 +270,12 @@ sub first_sibling { my $self = shift; my $position_column = $self->position_column; - my $fsib = $self->previous_siblings->search( + my $fsib = $self->previous_siblings->search_rs( {}, { rows => 1, order_by => { '-asc' => $position_column } }, )->single; - return defined $fsib ? $fsib : 0; + return defined( $fsib ) ? $fsib : 0; } =head2 next_sibling @@ -247,12 +290,12 @@ if the current object is the last one. sub next_sibling { my $self = shift; my $position_column = $self->position_column; - my $nsib = $self->next_siblings->search( + my $nsib = $self->next_siblings->search_rs( {}, { rows => 1, order_by => { '-asc' => $position_column } }, )->single; - return defined $nsib ? $nsib : 0; + return defined( $nsib ) ? $nsib : 0; } =head2 last_sibling @@ -267,12 +310,12 @@ sibling. sub last_sibling { my $self = shift; my $position_column = $self->position_column; - my $lsib = $self->next_siblings->search( + my $lsib = $self->next_siblings->search_rs( {}, { rows => 1, order_by => { '-desc' => $position_column } }, )->single; - return defined $lsib ? $lsib : 0; + return defined( $lsib ) ? $lsib : 0; } # an optimized method to get the last sibling position value without inflating a result object @@ -280,13 +323,12 @@ sub _last_sibling_posval { my $self = shift; my $position_column = $self->position_column; - my $cursor = $self->next_siblings->search( + my $cursor = $self->next_siblings->search_rs( {}, { rows => 1, order_by => { '-desc' => $position_column }, select => $position_column }, )->cursor; - my ($pos) = $cursor->next; - return $pos; + ($cursor->next)[0]; } =head2 move_previous @@ -367,8 +409,10 @@ sub move_to { my $position_column = $self->position_column; + my $rsrc = $self->result_source; + my $is_txn; - if ($is_txn = $self->result_source->schema->storage->transaction_depth) { + if ($is_txn = $rsrc->schema->storage->transaction_depth) { # Reload position state from storage # The thinking here is that if we are in a transaction, it is # *more likely* the object went out of sync due to resultset @@ -378,9 +422,8 @@ sub move_to { $self->store_column( $position_column, - ( $self->result_source - ->resultset - ->search($self->_storage_ident_condition, { rows => 1, columns => $position_column }) + ( $rsrc->resultset + ->search_rs($self->_storage_ident_condition, { rows => 1, columns => $position_column }) ->cursor ->next )[0] || $self->throw_exception( @@ -403,7 +446,7 @@ sub move_to { return 0; } - my $guard = $is_txn ? undef : $self->result_source->schema->txn_scope_guard; + my $guard = $is_txn ? undef : $rsrc->schema->txn_scope_guard; my ($direction, @between); if ( $from_position < $to_position ) { @@ -418,7 +461,7 @@ sub move_to { my $new_pos_val = $self->_position_value ($to_position); # record this before the shift # we need to null-position the moved row if the position column is part of a constraint - if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $self->result_source->unique_constraints }} ) ) ) { + if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) { $self->_ordered_internal_update({ $position_column => $self->null_position_value }); } @@ -564,7 +607,7 @@ sub update { if (! keys %$changed_ordering_cols) { return $self->next::method( undef, @_ ); } - elsif (defined first { exists $changed_ordering_cols->{$_} } @group_columns ) { + elsif (grep { exists $changed_ordering_cols->{$_} } @group_columns ) { $self->move_to_group( # since the columns are already re-set the _grouping_clause is correct # move_to_group() knows how to get the original storage values @@ -614,7 +657,11 @@ sub delete { # add the current position/group to the things we track old values for sub _track_storage_value { my ($self, $col) = @_; - return $self->next::method($col) || defined first { $_ eq $col } ($self->position_column, $self->_grouping_columns); + return ( + $self->next::method($col) + || + grep { $_ eq $col } ($self->position_column, $self->_grouping_columns) + ); } =head1 METHODS FOR EXTENDING ORDERED @@ -678,7 +725,7 @@ L below. Defaults to 1. =cut -__PACKAGE__->mk_classdata( '_initial_position_value' => 1 ); +__PACKAGE__->mk_classaccessor( '_initial_position_value' => 1 ); =head2 _next_position_value @@ -728,7 +775,7 @@ sub _shift_siblings { $ord = 'desc'; } - my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } }); + my $shift_rs = $self->_group_rs-> search_rs ({ $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. @@ -740,11 +787,11 @@ sub _shift_siblings { local $rsrc->schema->{_ORDERED_INTERNAL_UPDATE} = 1; my @pcols = $rsrc->primary_columns; if ( - first { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) + grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) { my $clean_rs = $rsrc->resultset; - for ( $shift_rs->search ( + for ( $shift_rs->search_rs ( {}, { order_by => { "-$ord", $position_column }, select => [$position_column, @pcols] } )->cursor->all ) { my $pos = shift @$_; @@ -760,8 +807,18 @@ sub _shift_siblings { # This method returns a resultset containing all members of the row # group (including the row itself). sub _group_rs { - my $self = shift; - return $self->result_source->resultset->search({$self->_grouping_clause()}); + #my $self = shift; + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + wantarray + and + ! eval { fail_on_internal_call; 1 } + and + die "ILLEGAL LIST CONTEXT INVOCATION: $@"; + + # *MUST* be context sensitive due to legacy (DO NOT call search_rs) + $_[0]->result_source->resultset->search({ $_[0]->_grouping_clause() }); } # Returns an unordered resultset of all objects in the same group @@ -770,7 +827,17 @@ sub _siblings { my $self = shift; my $position_column = $self->position_column; my $pos; - return defined ($pos = $self->get_column($position_column)) + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + wantarray + and + ! eval { fail_on_internal_call; 1 } + and + die "ILLEGAL LIST CONTEXT INVOCATION: $@"; + + # *MUST* be context sensitive due to legacy (DO NOT call search_rs) + defined( $pos = $self->get_column($position_column) ) ? $self->_group_rs->search( { $position_column => { '!=' => $pos } }, ) @@ -813,17 +880,26 @@ sub _is_in_group { my ($self, $other) = @_; my $current = {$self->_grouping_clause}; - no warnings qw/uninitialized/; - - return 0 if ( - join ("\x00", sort keys %$current) - ne - join ("\x00", sort keys %$other) - ); - for my $key (keys %$current) { - return 0 if $current->{$key} ne $other->{$key}; - } - return 1; + ( + bag_eq( + [ keys %$current ], + [ keys %$other ], + ) + and + ! grep { + ( + defined( $current->{$_} ) + xor + defined( $other->{$_} ) + ) + or + ( + defined $current->{$_} + and + $current->{$_} ne $other->{$_} + ) + } keys %$other + ) ? 1 : 0; } # This is a short-circuited method, that is used internally by this @@ -839,9 +915,8 @@ sub _is_in_group { # you are doing use this method which bypasses any hooks introduced by # this module. sub _ordered_internal_update { - my $self = shift; - local $self->result_source->schema->{_ORDERED_INTERNAL_UPDATE} = 1; - return $self->update (@_); + local $_[0]->result_source->schema->{_ORDERED_INTERNAL_UPDATE} = 1; + shift->update (@_); } 1; diff --git a/lib/DBIx/Class/PK.pm b/lib/DBIx/Class/PK.pm index 9bda5cac4..0ef470b33 100644 --- a/lib/DBIx/Class/PK.pm +++ b/lib/DBIx/Class/PK.pm @@ -5,6 +5,9 @@ use warnings; use base qw/DBIx::Class::Row/; +use DBIx::Class::_Util 'fail_on_internal_call'; +use namespace::clean; + =head1 NAME DBIx::Class::PK - Primary Key class @@ -27,12 +30,16 @@ a class method. =cut -sub id { - my ($self) = @_; - $self->throw_exception( "Can't call id() as a class method" ) - unless ref $self; - my @id_vals = $self->_ident_values; - return (wantarray ? @id_vals : $id_vals[0]); +sub id :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + + $_[0]->throw_exception( "Can't call id() as a class method" ) + unless ref $_[0]; + + wantarray + ? $_[0]->_ident_values + : ($_[0]->_ident_values)[0] # FIXME - horrible horrible legacy crap + ; } sub _ident_values { diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index 40deeafa4..d8a0d991f 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -24,7 +24,16 @@ sub add_relationship_accessor { my ($class, $rel, $acc_type) = @_; if ($acc_type eq 'single') { - quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel); + + my @qsub_args = ( {}, { + attributes => [qw( + DBIC_method_is_single_relationship_accessor + DBIC_method_is_generated_from_resultsource_metadata + )] + }); + + + quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel), @qsub_args; my $self = shift; if (@_) { @@ -35,24 +44,29 @@ sub add_relationship_accessor { return $self->{_relationship_data}{%1$s}; } else { - my $relcond = $self->result_source->_resolve_relationship_condition( - rel_name => %1$s, - foreign_alias => %1$s, - self_alias => 'me', - self_result_object => $self, - ); + my $rsrc = $self->result_source; + + my $jfc; return undef if ( - $relcond->{join_free_condition} - and - $relcond->{join_free_condition} ne DBIx::Class::_Util::UNRESOLVABLE_CONDITION + + $rsrc->relationship_info(%1$s)->{attrs}{undef_on_null_fk} + and - scalar grep { not defined $_ } values %%{ $relcond->{join_free_condition} || {} } + + $jfc = ( $rsrc->resolve_relationship_condition( + rel_name => %1$s, + foreign_alias => %1$s, + self_alias => 'me', + self_result_object => $self, + )->{join_free_condition} || {} ) + and - $self->result_source->relationship_info(%1$s)->{attrs}{undef_on_null_fk} + + grep { not defined $_ } values %%$jfc ); - my $val = $self->search_related( %1$s )->single; + my $val = $self->related_resultset( %1$s )->single; return $val unless $val; # $val instead of undef so that null-objects can go through return $self->{_relationship_data}{%1$s} = $val; @@ -60,15 +74,18 @@ sub add_relationship_accessor { EOC } elsif ($acc_type eq 'filter') { - $class->throw_exception("No such column '$rel' to filter") - unless $class->has_column($rel); - my $f_class = $class->relationship_info($rel)->{class}; + my $rsrc = $class->result_source_instance; + + $rsrc->throw_exception("No such column '$rel' to filter") + unless $rsrc->has_column($rel); + + my $f_class = $rsrc->relationship_info($rel)->{class}; $class->inflate_column($rel, { inflate => sub { my ($val, $self) = @_; - return $self->find_or_new_related($rel, {}, {}); + return $self->find_or_new_related($rel, {}); }, deflate => sub { my ($val, $self) = @_; @@ -93,15 +110,76 @@ EOC return $pk_val; }, }); + + + # god this is horrible... + my $acc = + $rsrc->columns_info->{$rel}{accessor} + || + $rel + ; + + # because CDBI may elect to never make an accessor at all... + if( my $main_cref = $class->can($acc) ) { + + attributes->import( + $class, + $main_cref, + qw( + DBIC_method_is_filter_relationship_accessor + DBIC_method_is_generated_from_resultsource_metadata + ), + ); + + if( my $extra_cref = $class->can("_${acc}_accessor") ) { + attributes->import( + $class, + $extra_cref, + qw( + DBIC_method_is_filter_relationship_extra_accessor + DBIC_method_is_generated_from_resultsource_metadata + ), + ); + } + } } elsif ($acc_type eq 'multi') { - quote_sub "${class}::${rel}_rs", "shift->search_related_rs( $rel => \@_ )"; - quote_sub "${class}::add_to_${rel}", "shift->create_related( $rel => \@_ )"; - quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel ); - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; - shift->search_related( %s => @_ ) + + my @qsub_args = ( + {}, + { + attributes => [qw( + DBIC_method_is_multi_relationship_accessor + DBIC_method_is_generated_from_resultsource_metadata + DBIC_method_is_indirect_sugar + )] + }, + ); + + + quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel ), @qsub_args; + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; + shift->related_resultset(%s)->search( @_ ) EOC + + + $qsub_args[1]{attributes}[0] + =~ s/^DBIC_method_is_multi_relationship_accessor$/DBIC_method_is_multi_relationship_extra_accessor/ + or die "Unexpected attr '$qsub_args[1]{attributes}[0]' ..."; + + + quote_sub "${class}::${rel}_rs", sprintf( <<'EOC', perlstring $rel ), @qsub_args; + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; + shift->related_resultset(%s)->search_rs( @_ ) +EOC + + + quote_sub "${class}::add_to_${rel}", sprintf( <<'EOC', perlstring $rel ), @qsub_args; + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; + shift->create_related( %s => @_ ); +EOC + } else { $class->throw_exception("No such relationship accessor type '$acc_type'"); diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index f5d34f81d..b7e74eb58 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -6,8 +6,18 @@ use warnings; use base qw/DBIx::Class/; use Scalar::Util qw/weaken blessed/; -use Try::Tiny; -use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION'; +use DBIx::Class::_Util qw( + UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR + dbic_internal_try dbic_internal_catch fail_on_internal_call +); +use DBIx::Class::SQLMaker::Util 'extract_equality_conditions'; +use DBIx::Class::Carp; + +# FIXME - this should go away +# instead Carp::Skip should export usable keywords or something like that +my $unique_carper; +BEGIN { $unique_carper = \&carp_unique } + use namespace::clean; =head1 NAME @@ -514,83 +524,119 @@ sub related_resultset { my ($self, $rel) = @_; - return $self->{related_resultsets}{$rel} = do { + my $rsrc = $self->result_source; - my $rsrc = $self->result_source; + my $rel_info = $rsrc->relationship_info($rel) + or $self->throw_exception( "No such relationship '$rel'" ); - my $rel_info = $rsrc->relationship_info($rel) - or $self->throw_exception( "No such relationship '$rel'" ); + my $relcond_is_freeform = ref $rel_info->{cond} eq 'CODE'; - my $cond_res = $rsrc->_resolve_relationship_condition( - rel_name => $rel, - self_result_object => $self, + my $rrc_args = { + rel_name => $rel, + self_result_object => $self, - # this may look weird, but remember that we are making a resultset - # out of an existing object, with the new source being at the head - # of the FROM chain. Having a 'me' alias is nothing but expected there - foreign_alias => 'me', + # an extra sanity check guard + require_join_free_condition => !!( + ! $relcond_is_freeform + and + $self->in_storage + ), - self_alias => "!!!\xFF()!!!_SHOULD_NEVER_BE_SEEN_IN_USE_!!!()\xFF!!!", + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, - # not strictly necessary, but shouldn't hurt either - require_join_free_condition => !!(ref $rel_info->{cond} ne 'CODE'), - ); + # this may look weird, but remember that we are making a resultset + # out of an existing object, with the new source being at the head + # of the FROM chain. Having a 'me' alias is nothing but expected there + foreign_alias => 'me', + }; - # keep in mind that the following if() block is part of a do{} - no return()s!!! - if ( - ! $cond_res->{join_free_condition} - and - ref $rel_info->{cond} eq 'CODE' - ) { + my $jfc = ( + # In certain extraordinary circumstances the relationship resolution may + # throw (e.g. when walking through elaborate custom conds) + # In case the object is "real" (i.e. in_storage) we just go ahead and + # let the exception surface. Otherwise we carp and move on. + # + # The elaborate code-duplicating ternary is there because the xsified + # ->in_storage() is orders of magnitude faster than the Try::Tiny-like + # construct below ( perl's low level tooling is truly shit :/ ) + ( $self->in_storage or DBIx::Class::_Util::in_internal_try ) + ? $rsrc->resolve_relationship_condition($rrc_args)->{join_free_condition} + : dbic_internal_try { + $rsrc->resolve_relationship_condition($rrc_args)->{join_free_condition} + } + dbic_internal_catch { + $unique_carper->( + "Resolution of relationship '$rel' failed unexpectedly, " + . 'please relay the following error and seek assistance via ' + . DBIx::Class::_ENV_::HELP_URL . ". Encountered error: $_" + ); + + # FIXME - this is questionable + # force skipping re-resolution, and instead just return an UC rset + $relcond_is_freeform = 0; + + # RV + undef; + } + ); - # A WHOREIFFIC hack to reinvoke the entire condition resolution - # with the correct alias. Another way of doing this involves a - # lot of state passing around, and the @_ positions are already - # mapped out, making this crap a less icky option. - # - # The point of this exercise is to retain the spirit of the original - # $obj->search_related($rel) where the resulting rset will have the - # root alias as 'me', instead of $rel (as opposed to invoking - # $rs->search_related) - - # make the fake 'me' rel - local $rsrc->{_relationships}{me} = { - %{ $rsrc->{_relationships}{$rel} }, - _original_name => $rel, - }; + my $rel_rset; - my $obj_table_alias = lc($rsrc->source_name) . '__row'; - $obj_table_alias =~ s/\W+/_/g; + if( defined $jfc ) { - $rsrc->resultset->search( - $self->ident_condition($obj_table_alias), - { alias => $obj_table_alias }, - )->search_related('me', undef, $rel_info->{attrs}) - } - else { - - # FIXME - this conditional doesn't seem correct - got to figure out - # at some point what it does. Also the entire UNRESOLVABLE_CONDITION - # business seems shady - we could simply not query *at all* - my $attrs; - if ( $cond_res->{join_free_condition} eq UNRESOLVABLE_CONDITION ) { - $attrs = { %{$rel_info->{attrs}} }; - my $reverse = $rsrc->reverse_relationship_info($rel); - foreach my $rev_rel (keys %$reverse) { - if ($reverse->{$rev_rel}{attrs}{accessor} && $reverse->{$rev_rel}{attrs}{accessor} eq 'multi') { - weaken($attrs->{related_objects}{$rev_rel}[0] = $self); - } else { - weaken($attrs->{related_objects}{$rev_rel} = $self); - } - } - } + $rel_rset = $rsrc->related_source($rel)->resultset->search_rs( + $jfc, + $rel_info->{attrs}, + ); + } + elsif( $relcond_is_freeform ) { + + # A WHOREIFFIC hack to reinvoke the entire condition resolution + # with the correct alias. Another way of doing this involves a + # lot of state passing around, and the @_ positions are already + # mapped out, making this crap a less icky option. + # + # The point of this exercise is to retain the spirit of the original + # $obj->search_related($rel) where the resulting rset will have the + # root alias as 'me', instead of $rel (as opposed to invoking + # $rs->search_related) + + # make the fake 'me' rel + local $rsrc->{_relationships}{me} = { + %{ $rsrc->{_relationships}{$rel} }, + _original_name => $rel, + }; + + my $obj_table_alias = lc($rsrc->source_name) . '__row'; + $obj_table_alias =~ s/\W+/_/g; + + $rel_rset = $rsrc->resultset->search_rs( + $self->ident_condition($obj_table_alias), + { alias => $obj_table_alias }, + )->related_resultset('me')->search_rs(undef, $rel_info->{attrs}) + } + else { + + my $attrs = { %{$rel_info->{attrs}} }; + my $reverse = $rsrc->reverse_relationship_info($rel); + + # FIXME - this loop doesn't seem correct - got to figure out + # at some point what exactly it does. + # See also the FIXME at the end of new_related() + ( ( $reverse->{$_}{attrs}{accessor}||'') eq 'multi' ) + ? weaken( $attrs->{related_objects}{$_}[0] = $self ) + : weaken( $attrs->{related_objects}{$_} = $self ) + for keys %$reverse; + + $rel_rset = $rsrc->related_source($rel)->resultset->search_rs( + UNRESOLVABLE_CONDITION, # guards potential use of the $rs in the future + $attrs, + ); + } - $rsrc->related_source($rel)->resultset->search( - $cond_res->{join_free_condition}, - $attrs || $rel_info->{attrs}, - ); - } - }; + $self->{related_resultsets}{$rel} = $rel_rset; } =head2 search_related @@ -611,8 +657,9 @@ See L for more information. =cut -sub search_related { - return shift->related_resultset(shift)->search(@_); +sub search_related :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->related_resultset(shift)->search(@_); } =head2 search_related_rs @@ -622,8 +669,9 @@ it guarantees a resultset, even in list context. =cut -sub search_related_rs { - return shift->related_resultset(shift)->search_rs(@_); +sub search_related_rs :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->related_resultset(shift)->search_rs(@_) } =head2 count_related @@ -641,8 +689,9 @@ current result or where conditions. =cut -sub count_related { - shift->search_related(@_)->count; +sub count_related :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->related_resultset(shift)->search_rs(@_)->count; } =head2 new_related @@ -665,13 +714,94 @@ your storage until you call L on it. sub new_related { my ($self, $rel, $data) = @_; - return $self->search_related($rel)->new_result( $self->result_source->_resolve_relationship_condition ( - infer_values_based_on => $data, + $self->throw_exception( + "Result object instantiation requires a hashref as argument" + ) unless ref $data eq 'HASH'; + + my $rsrc = $self->result_source; + my $rel_rsrc = $rsrc->related_source($rel); + +### +### This section deliberately does not rely on require_join_free_values, +### as quite often the resulting related object is useless without the +### contents of $data mixed in. Originally this code was part of +### resolve_relationship_condition() but given it has a single, very +### context-specific call-site it made no sense to expose it to end users. +### + + my $rel_resolution = $rsrc->resolve_relationship_condition ( rel_name => $rel, self_result_object => $self, - foreign_alias => $rel, - self_alias => 'me', - )->{inferred_values} ); + + # In case we are *not* in_storage it is ok to treat failed resolution as an empty hash + # This happens e.g. as a result of various in-memory related graph of objects + require_join_free_condition => !! $self->in_storage, + + # dummy aliases with deliberately known lengths, so that we can + # quickly strip them below if needed + foreign_alias => 'F', + self_alias => 'S', + ); + + my $rel_values = + $rel_resolution->{join_free_values} + || + { map { substr( $_, 2 ) => $rel_resolution->{join_free_condition}{$_} } keys %{ $rel_resolution->{join_free_condition} } } + ; + + # mix everything together + my $amalgamated_values = { + %{ + # in case we got back join_free_values - they already have passed the extractor + $rel_resolution->{join_free_values} + ? $rel_values + : extract_equality_conditions( + $rel_values, + 'consider_nulls' + ) + }, + %$data, + }; + + # cleanup possible rogue { somecolumn => [ -and => 1,2 ] } + ($amalgamated_values->{$_}||'') eq UNRESOLVABLE_CONDITION + and + delete $amalgamated_values->{$_} + for keys %$amalgamated_values; + + if( my @nonvalues = grep { ! exists $amalgamated_values->{$_} } keys %$rel_values ) { + + $self->throw_exception( + "Unable to complete value inferrence - relationship '$rel' " + . "on source '@{[ $rsrc->source_name ]}' results " + . 'in expression(s) instead of definitive values: ' + . do { + # FIXME - used for diag only, but still icky + my $sqlm = + dbic_internal_try { $rsrc->schema->storage->sql_maker } + || + ( + require DBIx::Class::SQLMaker + and + DBIx::Class::SQLMaker->new + ) + ; + local $sqlm->{quote_char}; + local $sqlm->{_dequalify_idents} = 1; + ($sqlm->_recurse_where({ map { $_ => $rel_values->{$_} } @nonvalues }))[0] + } + ); + } + + # And more complications - in case the relationship did not resolve + # we *have* to loop things through search_related ( essentially re-resolving + # everything we did so far, but with different type of handholding ) + # FIXME - this is still a mess, just a *little* better than it was + # See also the FIXME at the end of related_resultset() + exists $rel_resolution->{join_free_values} + ? $rel_rsrc->result_class->new({ -result_source => $rel_rsrc, %$amalgamated_values }) + : $self->related_resultset($rel)->new_result( $amalgamated_values ) + ; } =head2 create_related @@ -717,9 +847,10 @@ See L for details. =cut -sub find_related { +sub find_related :DBIC_method_is_indirect_sugar { #my ($self, $rel, @args) = @_; - return shift->search_related(shift)->find(@_); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + return shift->related_resultset(shift)->find(@_); } =head2 find_or_new_related @@ -739,8 +870,9 @@ for details. sub find_or_new_related { my $self = shift; - my $obj = $self->find_related(@_); - return defined $obj ? $obj : $self->new_related(@_); + my $rel = shift; + my $obj = $self->related_resultset($rel)->find(@_); + return defined $obj ? $obj : $self->related_resultset($rel)->new_result(@_); } =head2 find_or_create_related @@ -760,8 +892,9 @@ L for details. sub find_or_create_related { my $self = shift; - my $obj = $self->find_related(@_); - return (defined($obj) ? $obj : $self->create_related(@_)); + my $rel = shift; + my $obj = $self->related_resultset($rel)->find(@_); + return (defined($obj) ? $obj : $self->create_related( $rel => @_ )); } =head2 update_or_create_related @@ -779,8 +912,9 @@ L for details. =cut -sub update_or_create_related { +sub update_or_create_related :DBIC_method_is_indirect_sugar { #my ($self, $rel, @args) = @_; + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->related_resultset(shift)->update_or_create(@_); } @@ -813,13 +947,43 @@ L to update them in the storage. sub set_from_related { my ($self, $rel, $f_obj) = @_; - $self->set_columns( $self->result_source->_resolve_relationship_condition ( - infer_values_based_on => {}, + $self->set_columns( $self->result_source->resolve_relationship_condition ( + require_join_free_values => 1, rel_name => $rel, - foreign_values => $f_obj, - foreign_alias => $rel, - self_alias => 'me', - )->{inferred_values} ); + foreign_values => ( + # maintain crazy set_from_related interface + # + ( ! defined $f_obj ) ? +{} + : ( ! defined blessed $f_obj ) ? $f_obj + : do { + + my $f_result_class = $self->result_source->related_source($rel)->result_class; + + unless( $f_obj->isa($f_result_class) ) { + + $self->throw_exception( + 'Object supplied to set_from_related() must inherit from ' + . "'$DBIx::Class::ResultSource::__expected_result_class_isa'" + ) unless $f_obj->isa( + $DBIx::Class::ResultSource::__expected_result_class_isa + ); + + carp_unique( + 'Object supplied to set_from_related() usually should inherit from ' + . "the related ResultClass ('$f_result_class'), perhaps you've made " + . 'a mistake?' + ); + } + + +{ $f_obj->get_columns }; + } + ), + + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, + + )->{join_free_values} ); return 1; } @@ -868,8 +1032,9 @@ And returns the result of that. sub delete_related { my $self = shift; - my $obj = $self->search_related(@_)->delete; - delete $self->{related_resultsets}->{$_[0]}; + my $rel = shift; + my $obj = $self->related_resultset($rel)->search_rs(@_)->delete; + delete $self->{related_resultsets}->{$rel}; return $obj; } diff --git a/lib/DBIx/Class/Relationship/BelongsTo.pm b/lib/DBIx/Class/Relationship/BelongsTo.pm index a3e7dbc16..0a0f0dbd2 100644 --- a/lib/DBIx/Class/Relationship/BelongsTo.pm +++ b/lib/DBIx/Class/Relationship/BelongsTo.pm @@ -6,8 +6,7 @@ package # hide from PAUSE use strict; use warnings; -use Try::Tiny; -use DBIx::Class::_Util 'dbic_internal_try'; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); use namespace::clean; our %_pod_inherit_config = @@ -39,16 +38,16 @@ sub belongs_to { $class->throw_exception( "No such column '$f_key' declared yet on ${class} ($guess)" - ) unless $class->has_column($f_key); + ) unless $class->result_source->has_column($f_key); $class->ensure_class_loaded($f_class); my $f_rsrc = dbic_internal_try { - $f_class->result_source_instance; + $f_class->result_source; } - catch { + dbic_internal_catch { $class->throw_exception( "Foreign class '$f_class' does not seem to be a Result class " - . "(or it simply did not load entirely due to a circular relation chain)" + . "(or it simply did not load entirely due to a circular relation chain): $_" ); }; @@ -81,7 +80,7 @@ sub belongs_to { and (keys %$cond)[0] =~ /^foreign\./ and - $class->has_column($rel) + $class->result_source->has_column($rel) ) ? 'filter' : 'single'; my $fk_columns = ($acc_type eq 'single' and ref $cond eq 'HASH') diff --git a/lib/DBIx/Class/Relationship/CascadeActions.pm b/lib/DBIx/Class/Relationship/CascadeActions.pm index 59aefc12e..6fcfbe600 100644 --- a/lib/DBIx/Class/Relationship/CascadeActions.pm +++ b/lib/DBIx/Class/Relationship/CascadeActions.pm @@ -29,7 +29,7 @@ sub delete { my $ret = $self->next::method(@rest); foreach my $rel (@cascade) { - if( my $rel_rs = dbic_internal_try { $self->search_related($rel) } ) { + if( my $rel_rs = dbic_internal_try { $self->related_resultset($rel) } ) { $rel_rs->delete_all; } else { carp "Skipping cascade delete on relationship '$rel' - related resultsource '$rels{$rel}{class}' is not registered with this schema"; diff --git a/lib/DBIx/Class/Relationship/HasMany.pm b/lib/DBIx/Class/Relationship/HasMany.pm index 053eda6d5..6ef09fb74 100644 --- a/lib/DBIx/Class/Relationship/HasMany.pm +++ b/lib/DBIx/Class/Relationship/HasMany.pm @@ -16,7 +16,7 @@ sub has_many { unless (ref $cond) { - my $pri = $class->result_source_instance->_single_pri_col_or_die; + my $pri = $class->result_source->_single_pri_col_or_die; my ($f_key,$guess); if (defined $cond && length $cond) { @@ -30,7 +30,7 @@ sub has_many { # FIXME - this check needs to be moved to schema-composition time... # # only perform checks if the far side appears already loaded -# if (my $f_rsrc = dbic_internal_try { $f_class->result_source_instance } ) { +# if (my $f_rsrc = dbic_internal_try { $f_class->result_source } ) { # $class->throw_exception( # "No such column '$f_key' on foreign class ${f_class} ($guess)" # ) if !$f_rsrc->has_column($f_key); diff --git a/lib/DBIx/Class/Relationship/HasOne.pm b/lib/DBIx/Class/Relationship/HasOne.pm index 3141259fd..2894aa05b 100644 --- a/lib/DBIx/Class/Relationship/HasOne.pm +++ b/lib/DBIx/Class/Relationship/HasOne.pm @@ -4,8 +4,7 @@ package # hide from PAUSE use strict; use warnings; use DBIx::Class::Carp; -use Try::Tiny; -use DBIx::Class::_Util 'dbic_internal_try'; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); use namespace::clean; our %_pod_inherit_config = @@ -24,7 +23,7 @@ sub has_one { sub _has_one { my ($class, $join_type, $rel, $f_class, $cond, $attrs) = @_; unless (ref $cond) { - my $pri = $class->result_source_instance->_single_pri_col_or_die; + my $pri = $class->result_source->_single_pri_col_or_die; my ($f_key,$guess,$f_rsrc); if (defined $cond && length $cond) { @@ -36,12 +35,12 @@ sub _has_one { $class->ensure_class_loaded($f_class); $f_rsrc = dbic_internal_try { - my $r = $f_class->result_source_instance; + my $r = $f_class->result_source; die "There got to be some columns by now... (exception caught and rewritten by catch below)" unless $r->columns; $r; } - catch { + dbic_internal_catch { $class->throw_exception( "Foreign class '$f_class' does not seem to be a Result class " . "(or it simply did not load entirely due to a circular relation chain)" @@ -60,8 +59,8 @@ sub _has_one { # FIXME - this check needs to be moved to schema-composition time... # # only perform checks if the far side was not preloaded above *AND* -# # appears to have been loaded by something else (has a rsrc_instance) -# if (! $f_rsrc and $f_rsrc = dbic_internal_try { $f_class->result_source_instance }) { +# # appears to have been loaded by something else (has a rsrc) +# if (! $f_rsrc and $f_rsrc = dbic_internal_try { $f_class->result_source }) { # $class->throw_exception( # "No such column '$f_key' on foreign class ${f_class} ($guess)" # ) if !$f_rsrc->has_column($f_key); @@ -97,12 +96,18 @@ sub _validate_has_one_condition { 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") - unless $class->has_column($key); - my $column_info = $class->column_info($key); - if ( $column_info->{is_nullable} ) { - carp(qq'"might_have/has_one" must not be on columns with is_nullable set to true ($class/$key). This might indicate an incorrect use of those relationship helpers instead of belongs_to.'); - } + + my $column_info = $class->result_source->columns_info->{$key} + or $class->throw_exception( + "Defining rel on ${class} that includes '$key' " + . 'but no such column defined there yet' + ); + + carp( + "'might_have'/'has_one' must not be used on columns with is_nullable " + . "set to true ($class/$key). This almost certainly indicates an " + . "incorrect use of these relationship helpers instead of 'belongs_to'" + ) if $column_info->{is_nullable}; } } diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm index c000a84bd..7075fbdfe 100644 --- a/lib/DBIx/Class/Relationship/ManyToMany.pm +++ b/lib/DBIx/Class/Relationship/ManyToMany.pm @@ -5,11 +5,12 @@ use strict; use warnings; use DBIx::Class::Carp; -use DBIx::Class::_Util qw(fail_on_internal_wantarray quote_sub); +use DBIx::Class::_Util qw( quote_sub perlstring ); -# FIXME - this souldn't be needed -my $cu; -BEGIN { $cu = \&carp_unique } +# FIXME - this should go away +# instead Carp::Skip should export usable keywords or something like that +my $unique_carper; +BEGIN { $unique_carper = \&carp_unique } use namespace::clean; @@ -56,38 +57,66 @@ EOW } } - my $qsub_attrs = { - '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } }, - '$carp_unique' => \$cu, - }; - - quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', $rel, $f_rel ), $qsub_attrs; - - # this little horror is there replicating a deprecation from - # within search_rs() itself - shift->search_related_rs( q{%1$s} ) - ->search_related_rs( - q{%2$s}, - undef, - ( @_ > 1 and ref $_[-1] eq 'HASH' ) - ? { %%$rel_attrs, %%{ pop @_ } } - : $rel_attrs - )->search_rs(@_) - ; + my @main_meth_qsub_args = ( + {}, + { attributes => [ + 'DBIC_method_is_indirect_sugar', + ( keys( %{$rel_attrs||{}} ) + ? 'DBIC_method_is_m2m_sugar_with_attrs' + : 'DBIC_method_is_m2m_sugar' + ), + ] }, + ); + + + quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ), @main_meth_qsub_args; + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; + shift->%s( @_ )->search; EOC - quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ); + my @extra_meth_qsub_args = ( + { + '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } }, + '$carp_unique' => \$unique_carper, + }, + { attributes => [ + 'DBIC_method_is_indirect_sugar', + ( keys( %{$rel_attrs||{}} ) + ? 'DBIC_method_is_m2m_extra_sugar_with_attrs' + : 'DBIC_method_is_m2m_extra_sugar' + ), + ] }, + ); + - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; + quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', map { perlstring $_ } ( "${class}::${meth}", $rel, $f_rel ) ), @extra_meth_qsub_args; - my $rs = shift->%s( @_ ); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + # allow nested calls from our ->many_to_many, see comment below + ( (CORE::caller(1))[3] ne %s ) + and + DBIx::Class::_Util::fail_on_internal_call; - wantarray ? $rs->all : $rs; + # this little horror is there replicating a deprecation from + # within search_rs() itself + shift->related_resultset( %s ) + ->related_resultset( %s ) + ->search_rs ( + undef, + ( @_ > 1 and ref $_[-1] eq 'HASH' ) + ? { %%$rel_attrs, %%{ pop @_ } } + : $rel_attrs + )->search_rs(@_) + ; EOC + # the above is the only indirect method, the 3 below have too much logic + shift @{$extra_meth_qsub_args[1]{attributes}}; - quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), $qsub_attrs; + + quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), @extra_meth_qsub_args; ( @_ >= 2 and @_ <= 3 ) or $_[0]->throw_exception( "'%1$s' expects an object or hashref to link to, and an optional hashref of link data" @@ -101,7 +130,7 @@ EOC my $guard; - # the API needs is always expected to return the far object, possibly + # the API is always expected to return the far object, possibly # creating it in the process if( not defined Scalar::Util::blessed( $far_obj ) ) { @@ -131,7 +160,7 @@ EOC EOC - quote_sub "${class}::${set_meth}", sprintf( <<'EOC', $set_meth, $add_meth, $rel, $f_rel ), $qsub_attrs; + quote_sub "${class}::${set_meth}", sprintf( <<'EOC', $set_meth, $add_meth, $rel, $f_rel ), @extra_meth_qsub_args; my $self = shift; @@ -153,7 +182,7 @@ EOC ) if ( @_ > 1 or - ( @_ and ref $_[0] ne 'HASH' ) + ( defined $_[0] and ref $_[0] ne 'HASH' ) ); my $guard; @@ -164,13 +193,13 @@ EOC # if there is a where clause in the attributes, ensure we only delete # rows that are within the where restriction - $self->search_related( - q{%3$s}, - ( $rel_attrs->{where} - ? ( $rel_attrs->{where}, { join => q{%4$s} } ) - : () - ) - )->delete; + $self->related_resultset( q{%3$s} ) + ->search_rs( + ( $rel_attrs->{where} + ? ( $rel_attrs->{where}, { join => q{%4$s} } ) + : () + ) + )->delete; # add in the set rel objects $self->%2$s( @@ -182,12 +211,16 @@ EOC EOC - quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel ); + # the last method needs no captures - just kill it all with fire + $extra_meth_qsub_args[0] = {}; + + + quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel ), @extra_meth_qsub_args; $_[0]->throw_exception("'%1$s' expects an object") unless defined Scalar::Util::blessed( $_[1] ); - $_[0]->search_related_rs( q{%2$s} ) + $_[0]->related_resultset( q{%2$s} ) ->search_rs( $_[1]->ident_condition( q{%3$s} ), { join => q{%3$s} } ) ->delete; EOC diff --git a/lib/DBIx/Class/Relationship/ProxyMethods.pm b/lib/DBIx/Class/Relationship/ProxyMethods.pm index 0db5780da..ee49fe8f8 100644 --- a/lib/DBIx/Class/Relationship/ProxyMethods.pm +++ b/lib/DBIx/Class/Relationship/ProxyMethods.pm @@ -24,11 +24,18 @@ sub proxy_to_related { my ($class, $rel, $proxy_args) = @_; my %proxy_map = $class->_build_proxy_map_from($proxy_args); - quote_sub "${class}::$_", sprintf( <<'EOC', $rel, $proxy_map{$_} ) + my @qsub_args = ( {}, { + attributes => [qw( + DBIC_method_is_proxy_to_relationship + DBIC_method_is_generated_from_resultsource_metadata + )], + } ); + + quote_sub "${class}::$_", sprintf( <<'EOC', $rel, $proxy_map{$_} ), @qsub_args my $self = shift; my $relobj = $self->%1$s; if (@_ && !defined $relobj) { - $relobj = $self->create_related( %1$s => { %2$s => $_[0] } ); + $relobj = $self->create_related( q{%1$s} => { %2$s => $_[0] } ); @_ = (); } $relobj ? $relobj->%2$s(@_) : undef; diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 0a6c002c7..030f2924b 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -2,19 +2,20 @@ package DBIx::Class::ResultSet; use strict; use warnings; -use base qw/DBIx::Class/; + +use base 'DBIx::Class'; + use DBIx::Class::Carp; use DBIx::Class::ResultSetColumn; use DBIx::Class::ResultClass::HashRefInflator; -use Scalar::Util qw/blessed weaken reftype/; +use Scalar::Util qw( blessed reftype ); +use SQL::Abstract 'is_literal_value'; use DBIx::Class::_Util qw( - dbic_internal_try - fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION + dbic_internal_try dbic_internal_catch dump_value emit_loud_diag + fail_on_internal_call UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR ); -use Try::Tiny; - -# not importing first() as it will clash with our own method -use List::Util (); +use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); +use DBIx::Class::ResultSource::FromSpec::Util 'find_join_path_to_alias'; BEGIN { # De-duplication in _merge_attr() is disabled, but left in for reference @@ -389,28 +390,27 @@ L. =cut -sub search { - my $self = shift; - my $rs = $self->search_rs( @_ ); +sub search :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; - if (wantarray) { - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray; - return $rs->all; - } - elsif (defined wantarray) { - return $rs; - } - else { - # we can be called by a relationship helper, which in - # turn may be called in void context due to some braindead - # overload or whatever else the user decided to be clever - # at this particular day. Thus limit the exception to - # external code calls only - $self->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense') - if (caller)[0] !~ /^\QDBIx::Class::/; - - return (); - } + my $rs = shift->search_rs( @_ ); + + return $rs->all + if wantarray; + + return $rs + if defined wantarray; + + # we can be called by a relationship helper, which in + # turn may be called in void context due to some braindead + # overload or whatever else the user decided to be clever + # at this particular day. Thus limit the exception to + # external code calls only + $rs->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense') + if (caller)[0] !~ /^\QDBIx::Class::/; + + # we are in void ctx here, but just in case + return (); } =head2 search_rs @@ -466,7 +466,7 @@ sub search_rs { # see if we can keep the cache (no $rs changes) my $cache; my %safe = (alias => 1, cache => 1); - if ( ! List::Util::first { !$safe{$_} } keys %$call_attrs and ( + if ( ! grep { !$safe{$_} } keys %$call_attrs and ( ! defined $call_cond or ref $call_cond eq 'HASH' && ! keys %$call_cond @@ -490,9 +490,8 @@ sub search_rs { my @selector_attrs = qw/select as columns cols +select +as +columns include_columns/; # reset the current selector list if new selectors are supplied - if (List::Util::first { exists $call_attrs->{$_} } qw/columns cols select as/) { - delete @{$old_attrs}{(@selector_attrs, '_dark_selector')}; - } + delete @{$old_attrs}{(@selector_attrs, '_dark_selector')} + if grep { exists $call_attrs->{$_} } qw(columns cols select as); # Normalize the new selector list (operates on the passed-in attr structure) # Need to do it on every chain instead of only once on _resolved_attrs, in @@ -554,7 +553,6 @@ sub search_rs { return $rs; } -my $dark_sel_dumper; sub _normalize_selection { my ($self, $attrs) = @_; @@ -619,11 +617,10 @@ sub _normalize_selection { else { $attrs->{_dark_selector} = { plus_stage => $pref, - string => ($dark_sel_dumper ||= do { - require Data::Dumper::Concise; - Data::Dumper::Concise::DumperObject()->Indent(0); - })->Values([$_])->Dump - , + string => do { + local $Data::Dumper::Indent = 0; + dump_value $_; + }, }; last SELECTOR; } @@ -657,17 +654,15 @@ sub _stack_cond { (ref $_ eq 'HASH' and ! keys %$_) ) and $_ = undef for ($left, $right); - # either one of the two undef - if ( (defined $left) xor (defined $right) ) { - return defined $left ? $left : $right; - } - # both undef - elsif ( ! defined $left ) { - return undef - } - else { - return $self->result_source->schema->storage->_collapse_cond({ -and => [$left, $right] }); - } + return( + # either one of the two undef + ( (defined $left) xor (defined $right) ) ? ( defined $left ? $left : $right ) + + # both undef + : ( ! defined $left ) ? undef + + : { -and => [$left, $right] } + ); } =head2 search_literal @@ -702,7 +697,9 @@ Example of how to use C instead of C =cut -sub search_literal { +sub search_literal :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + my ($self, $sql, @bind) = @_; my $attr; if ( @bind && ref($bind[-1]) eq 'HASH' ) { @@ -780,9 +777,8 @@ See also L and L. sub find { my $self = shift; - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); - my $rsrc = $self->result_source; my $constraint_name; if (exists $attrs->{key}) { @@ -795,6 +791,8 @@ sub find { # Parse out the condition from input my $call_cond; + my $rsrc = $self->result_source; + if (ref $_[0] eq 'HASH') { $call_cond = { %{$_[0]} }; } @@ -817,25 +815,59 @@ sub find { } # process relationship data if any + my $rel_list; + for my $key (keys %$call_cond) { if ( + # either a structure or a result-ish object length ref($call_cond->{$key}) and - my $relinfo = $rsrc->relationship_info($key) + ( $rel_list ||= { map { $_ => 1 } $rsrc->relationships } ) + ->{$key} + and + ! is_literal_value( $call_cond->{$key} ) and - # implicitly skip has_many's (likely MC) - (ref (my $val = delete $call_cond->{$key}) ne 'ARRAY' ) + # implicitly skip has_many's (likely MC), via the delete() + ( ref( my $foreign_val = delete $call_cond->{$key} ) ne 'ARRAY' ) ) { - my ($rel_cond, $crosstable) = $rsrc->_resolve_condition( - $relinfo->{cond}, $val, $key, $key - ); - $self->throw_exception("Complex condition via relationship '$key' is unsupported in find()") - if $crosstable or ref($rel_cond) ne 'HASH'; + # FIXME: it seems wrong that relationship conditions take precedence...? + $call_cond = { + %$call_cond, + + %{ $rsrc->resolve_relationship_condition( + require_join_free_values => 1, + rel_name => $key, + foreign_values => ( + (! defined blessed $foreign_val) ? $foreign_val : do { + + my $f_result_class = $rsrc->related_source($key)->result_class; + + unless( $foreign_val->isa($f_result_class) ) { + + $self->throw_exception( + 'Objects supplied to find() must inherit from ' + . "'$DBIx::Class::ResultSource::__expected_result_class_isa'" + ) unless $foreign_val->isa( + $DBIx::Class::ResultSource::__expected_result_class_isa + ); - # supplement condition - # relationship conditions take precedence (?) - @{$call_cond}{keys %$rel_cond} = values %$rel_cond; + carp_unique( + "Objects supplied to find() via '$key' usually should inherit from " + . "the related ResultClass ('$f_result_class'), perhaps you've made " + . 'a mistake?' + ); + } + + +{ $foreign_val->get_columns }; + } + ), + + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, + )->{join_free_values} }, + }; } } @@ -844,7 +876,7 @@ sub find { if (defined $constraint_name) { $final_cond = $self->_qualify_cond_columns ( - $self->result_source->_minimal_valueset_satisfying_constraint( + $rsrc->_minimal_valueset_satisfying_constraint( constraint_name => $constraint_name, values => ($self->_merge_with_rscond($call_cond))[0], carp_on_nulls => 1, @@ -881,15 +913,15 @@ sub find { dbic_internal_try { push @unique_queries, $self->_qualify_cond_columns( - $self->result_source->_minimal_valueset_satisfying_constraint( + $rsrc->_minimal_valueset_satisfying_constraint( constraint_name => $c_name, values => ($self->_merge_with_rscond($call_cond))[0], - columns_info => ($ci ||= $self->result_source->columns_info), + columns_info => ($ci ||= $rsrc->columns_info), ), $alias ); } - catch { + dbic_internal_catch { push @fc_exceptions, $_ if $_ =~ /\bFilterColumn\b/; }; } @@ -902,7 +934,7 @@ sub find { } # Run the query, passing the result_class since it should propagate for find - my $rs = $self->search ($final_cond, {result_class => $self->result_class, %$attrs}); + my $rs = $self->search_rs( $final_cond, {result_class => $self->result_class, %$attrs} ); if ($rs->_resolved_attrs->{collapse}) { my $row = $rs->next; carp "Query returned more than one row" if $rs->next; @@ -990,7 +1022,8 @@ See also L. =cut -sub search_related { +sub search_related :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return shift->related_resultset(shift)->search(@_); } @@ -1001,7 +1034,8 @@ it guarantees a resultset, even in list context. =cut -sub search_related_rs { +sub search_related_rs :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return shift->related_resultset(shift)->search_rs(@_); } @@ -1025,7 +1059,7 @@ sub cursor { return $self->{cursor} ||= do { my $attrs = $self->_resolved_attrs; - $self->result_source->storage->select( + $self->result_source->schema->storage->select( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs ); }; @@ -1098,7 +1132,7 @@ sub single { } } - my $data = [ $self->result_source->storage->select_single( + my $data = [ $self->result_source->schema->storage->select_single( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs )]; @@ -1125,9 +1159,7 @@ Returns a L instance for a column of the ResultSet =cut sub get_column { - my ($self, $column) = @_; - my $new = DBIx::Class::ResultSetColumn->new($self, $column); - return $new; + DBIx::Class::ResultSetColumn->new(@_); } =head2 search_like @@ -1160,14 +1192,16 @@ instead. An example conversion is: =cut -sub search_like { +sub search_like :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + my $class = shift; carp_unique ( 'search_like() is deprecated and will be removed in DBIC version 0.09.' .' Instead use ->search({ x => { -like => "y%" } })' .' (note the outer pair of {}s - they are important!)' ); - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); my $query = ref $_[0] eq 'HASH' ? { %{shift()} }: {@_}; $query->{$_} = { 'like' => $query->{$_} } for keys %$query; return $class->search($query, { %$attrs }); @@ -1191,7 +1225,9 @@ three records, call: =cut -sub slice { +sub slice :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + my ($self, $min, $max) = @_; my $attrs = {}; # = { %{ $self->{attrs} || {} } }; $attrs->{offset} = $self->{attrs}{offset} || 0; @@ -1415,7 +1451,7 @@ sub _construct_results { : '@$rows = map { $inflator_cref->($res_class, $rsrc, { %s } ) } @$rows' ), ( join (', ', map { "\$infmap->[$_] => \$_->[$_]" } 0..$#$infmap ) ) - ); + ) . '; 1' or die; } } else { @@ -1425,60 +1461,30 @@ sub _construct_results { : 'classic_nonpruning' ; - # $args and $attrs to _mk_row_parser are separated to delineate what is - # core collapser stuff and what is dbic $rs specific - @{$self->{_row_parser}{$parser_type}}{qw(cref nullcheck)} = $rsrc->_mk_row_parser({ - eval => 1, - inflate_map => $infmap, - collapse => $attrs->{collapse}, - premultiplied => $attrs->{_main_source_premultiplied}, - hri_style => $self->{_result_inflator}{is_hri}, - prune_null_branches => $self->{_result_inflator}{is_hri} || $self->{_result_inflator}{is_core_row}, - }, $attrs) unless $self->{_row_parser}{$parser_type}{cref}; - - # column_info metadata historically hasn't been too reliable. - # We need to start fixing this somehow (the collapse resolver - # can't work without it). Add an explicit check for the *main* - # result, hopefully this will gradually weed out such errors - # - # FIXME - this is a temporary kludge that reduces performance - # It is however necessary for the time being - my ($unrolled_non_null_cols_to_check, $err); + unless( $self->{_row_parser}{$parser_type}{cref} ) { - if (my $check_non_null_cols = $self->{_row_parser}{$parser_type}{nullcheck} ) { + # $args and $attrs to _mk_row_parser are separated to delineate what is + # core collapser stuff and what is dbic $rs specific + $self->{_row_parser}{$parser_type}{src} = $rsrc->_mk_row_parser({ + inflate_map => $infmap, + collapse => $attrs->{collapse}, + premultiplied => $attrs->{_main_source_premultiplied}, + hri_style => $self->{_result_inflator}{is_hri}, + prune_null_branches => $self->{_result_inflator}{is_hri} || $self->{_result_inflator}{is_core_row}, + }, $attrs); - $err = - 'Collapse aborted due to invalid ResultSource metadata - the following ' - . 'selections are declared non-nullable but NULLs were retrieved: ' - ; + $self->{_row_parser}{$parser_type}{cref} = do { + package # hide form PAUSE + DBIx::Class::__GENERATED_ROW_PARSER__; - my @violating_idx; - COL: for my $i (@$check_non_null_cols) { - ! defined $_->[$i] and push @violating_idx, $i and next COL for @$rows; - } - - $self->throw_exception( $err . join (', ', map { "'$infmap->[$_]'" } @violating_idx ) ) - if @violating_idx; - - $unrolled_non_null_cols_to_check = join (',', @$check_non_null_cols); - - utf8::upgrade($unrolled_non_null_cols_to_check) - if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE; + eval $self->{_row_parser}{$parser_type}{src}; + } || die $@; } - my $next_cref = - ($did_fetch_all or ! $attrs->{collapse}) ? undef - : defined $unrolled_non_null_cols_to_check ? eval sprintf <<'EOS', $unrolled_non_null_cols_to_check -sub { - # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref - my @r = $cursor->next or return; - if (my @violating_idx = grep { ! defined $r[$_] } (%s) ) { - $self->throw_exception( $err . join (', ', map { "'$infmap->[$_]'" } @violating_idx ) ) - } - \@r -} -EOS - : sub { + # this needs to close over the *current* cursor, hence why it is not cached above + my $next_cref = ($did_fetch_all or ! $attrs->{collapse}) + ? undef + : sub { # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref my @r = $cursor->next or return; \@r @@ -1487,9 +1493,25 @@ EOS $self->{_row_parser}{$parser_type}{cref}->( $rows, - $next_cref ? ( $next_cref, $self->{_stashed_rows} = [] ) : (), + $next_cref, + ( $self->{_stashed_rows} = [] ), + ( my $null_violations = {} ), ); + $self->throw_exception( + 'Collapse aborted - the following columns are declared (or defaulted to) ' + . 'non-nullable within DBIC but NULLs were retrieved from storage: ' + . join( ', ', map { "'$infmap->[$_]'" } sort { $a <=> $b } keys %$null_violations ) + . ' within data row ' . dump_value({ + map { + $infmap->[$_] => + ( ! defined $self->{_stashed_rows}[0][$_] or length $self->{_stashed_rows}[0][$_] < 50 ) + ? $self->{_stashed_rows}[0][$_] + : substr( $self->{_stashed_rows}[0][$_], 0, 50 ) . '...' + } 0 .. $#{$self->{_stashed_rows}[0]} + }) + ) if keys %$null_violations; + # simple in-place substitution, does not regrow $rows if ($self->{_result_inflator}{is_core_row}) { $_ = $inflator_cref->($res_class, $rsrc, @$_) for @$rows @@ -1589,7 +1611,7 @@ C<< $rs->search ($cond, \%attrs)->count >> sub count { my $self = shift; - return $self->search(@_)->count if @_ and defined $_[0]; + return $self->search_rs(@_)->count if @_ and defined $_[0]; return scalar @{ $self->get_cache } if $self->get_cache; my $attrs = { %{ $self->_resolved_attrs } }; @@ -1637,7 +1659,7 @@ the same single value obtainable via L. sub count_rs { my $self = shift; - return $self->search(@_)->count_rs if @_; + return $self->search_rs(@_)->count_rs if @_; # this may look like a lack of abstraction (count() does about the same) # but in fact an _rs *must* use a subquery for the limits, as the @@ -1666,7 +1688,7 @@ sub _count_rs { # overwrite the selector (supplied by the storage) $rsrc->resultset_class->new($rsrc, { %$tmp_attrs, - select => $rsrc->storage->_count_select ($rsrc, $attrs), + select => $rsrc->schema->storage->_count_select ($rsrc, $attrs), as => 'count', })->get_column ('count'); } @@ -1697,7 +1719,7 @@ sub _count_subq_rs { # Calculate subquery selector if (my $g = $sub_attrs->{group_by}) { - my $sql_maker = $rsrc->storage->sql_maker; + my $sql_maker = $rsrc->schema->storage->sql_maker; # necessary as the group_by may refer to aliased functions my $sel_index; @@ -1764,7 +1786,7 @@ sub _count_subq_rs { return $rsrc->resultset_class ->new ($rsrc, $sub_attrs) ->as_subselect_rs - ->search ({}, { columns => { count => $rsrc->storage->_count_select ($rsrc, $attrs) } }) + ->search_rs ({}, { columns => { count => $rsrc->schema->storage->_count_select ($rsrc, $attrs) } }) ->get_column ('count'); } @@ -1787,7 +1809,10 @@ with the passed arguments, then L. =cut -sub count_literal { shift->search_literal(@_)->count; } +sub count_literal :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->search_literal(@_)->count +} =head2 all @@ -1864,7 +1889,8 @@ an object for the first result (or C if the resultset is empty). =cut -sub first { +sub first :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return $_[0]->reset->next; } @@ -1904,7 +1930,7 @@ sub _rs_update_delete { $storage->_prune_unused_joins ($attrs); # any non-pruneable non-local restricting joins imply subq - $needs_subq = defined List::Util::first { $_ ne $attrs->{alias} } keys %{ $join_classifications->{restricting} || {} }; + $needs_subq = grep { $_ ne $attrs->{alias} } keys %{ $join_classifications->{restricting} || {} }; } # check if the head is composite (by now all joins are thrown out unless $needs_subq) @@ -1921,7 +1947,7 @@ sub _rs_update_delete { # 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; + my $sqla = $rsrc->schema->storage->sql_maker; local $sqla->{_dequalify_idents} = 1; \[ $sqla->_recurse_where($self->{cond}) ]; }; @@ -1991,7 +2017,7 @@ sub _rs_update_delete { } } - $subrs = $subrs->search({}, { group_by => $attrs->{columns} }); + $subrs = $subrs->search_rs({}, { group_by => $attrs->{columns} }); } $guard = $storage->txn_scope_guard; @@ -2235,6 +2261,9 @@ sub populate { # FIXME - no cref handling # At this point assume either hashes or arrays + my $rsrc = $self->result_source; + my $storage = $rsrc->schema->storage; + if(defined wantarray) { my (@results, $guard); @@ -2242,7 +2271,7 @@ sub populate { # column names only, nothing to do return if @$data == 1; - $guard = $self->result_source->schema->storage->txn_scope_guard + $guard = $storage->txn_scope_guard if @$data > 2; @results = map @@ -2252,7 +2281,7 @@ sub populate { } else { - $guard = $self->result_source->schema->storage->txn_scope_guard + $guard = $storage->txn_scope_guard if @$data > 1; @results = map { $self->new_result($_)->insert } @$data; @@ -2266,7 +2295,6 @@ sub populate { # this means we have to walk the data structure twice # whether we want this or not # jnap, I hate you ;) - my $rsrc = $self->result_source; my $rel_info = { map { $_ => $rsrc->relationship_info($_) } $rsrc->relationships }; my ($colinfo, $colnames, $slices_with_rels); @@ -2303,7 +2331,18 @@ sub populate { or ref $data->[$i][$_->{pos}] eq 'HASH' or - ( defined blessed $data->[$i][$_->{pos}] and $data->[$i][$_->{pos}]->isa('DBIx::Class::Row') ) + ( + defined blessed $data->[$i][$_->{pos}] + and + $data->[$i][$_->{pos}]->isa( + $DBIx::Class::ResultSource::__expected_result_class_isa + || + emit_loud_diag( + confess => 1, + msg => 'Global $DBIx::Class::ResultSource::__expected_result_class_isa unexpectedly unset...' + ) + ) + ) ) and 1 @@ -2311,7 +2350,18 @@ sub populate { # moar sanity check... sigh for ( ref $data->[$i][$_->{pos}] eq 'ARRAY' ? @{$data->[$i][$_->{pos}]} : $data->[$i][$_->{pos}] ) { - if ( defined blessed $_ and $_->isa('DBIx::Class::Row' ) ) { + if ( + defined blessed $_ + and + $_->isa( + $DBIx::Class::ResultSource::__expected_result_class_isa + || + emit_loud_diag( + confess => 1, + msg => 'Global $DBIx::Class::ResultSource::__expected_result_class_isa unexpectedly unset...' + ) + ) + ) { carp_unique("Fast-path populate() with supplied related objects is not possible - falling back to regular create()"); return my $throwaway = $self->populate(@_); } @@ -2353,7 +2403,18 @@ sub populate { or ref $data->[$i]{$_} eq 'HASH' or - ( defined blessed $data->[$i]{$_} and $data->[$i]{$_}->isa('DBIx::Class::Row') ) + ( + defined blessed $data->[$i]{$_} + and + $data->[$i]{$_}->isa( + $DBIx::Class::ResultSource::__expected_result_class_isa + || + emit_loud_diag( + confess => 1, + msg => 'Global $DBIx::Class::ResultSource::__expected_result_class_isa unexpectedly unset...' + ) + ) + ) ) and 1 @@ -2361,7 +2422,18 @@ sub populate { # moar sanity check... sigh for ( ref $data->[$i]{$_} eq 'ARRAY' ? @{$data->[$i]{$_}} : $data->[$i]{$_} ) { - if ( defined blessed $_ and $_->isa('DBIx::Class::Row' ) ) { + if ( + defined blessed $_ + and + $_->isa( + $DBIx::Class::ResultSource::__expected_result_class_isa + || + emit_loud_diag( + confess => 1, + msg => 'Global $DBIx::Class::ResultSource::__expected_result_class_isa unexpectedly unset...' + ) + ) + ) { carp_unique("Fast-path populate() with supplied related objects is not possible - falling back to regular create()"); return my $throwaway = $self->populate(@_); } @@ -2423,13 +2495,13 @@ sub populate { ### start work my $guard; - $guard = $rsrc->schema->storage->txn_scope_guard + $guard = $storage->txn_scope_guard if $slices_with_rels; ### main source data # FIXME - need to switch entirely to a coderef-based thing, # so that large sets aren't copied several times... I think - $rsrc->storage->_insert_bulk( + $storage->_insert_bulk( $rsrc, [ @$colnames, sort keys %$rs_data ], [ map { @@ -2463,18 +2535,20 @@ sub populate { $colinfo->{$rel}{rs} = $rsrc->related_source($rel)->resultset; - $colinfo->{$rel}{fk_map} = { reverse %{ $rsrc->_resolve_relationship_condition( + $colinfo->{$rel}{fk_map} = { reverse %{ $rsrc->resolve_relationship_condition( rel_name => $rel, - self_alias => "\xFE", # irrelevant - foreign_alias => "\xFF", # irrelevant + + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, )->{identity_map} || {} } }; } - $colinfo->{$rel}{rs}->search({ map # only so that we inherit them values properly, no actual search + $colinfo->{$rel}{rs}->search_rs({ map # only so that we inherit them values properly, no actual search { $_ => { '=' => - ( $main_proto_rs ||= $rsrc->resultset->search($main_proto) ) + ( $main_proto_rs ||= $rsrc->resultset->search_rs($main_proto) ) ->get_column( $colinfo->{$rel}{fk_map}{$_} ) ->as_query } @@ -2580,11 +2654,8 @@ Passes the hashref of input on to L. sub new_result { my ($self, $values) = @_; - $self->throw_exception( "new_result takes only one argument - a hashref of values" ) - if @_ > 2; - - $self->throw_exception( "Result object instantiation requires a hashref as argument" ) - unless (ref $values eq 'HASH'); + $self->throw_exception( "Result object instantiation requires a single hashref argument" ) + if @_ > 2 or ref $values ne 'HASH'; my ($merged_cond, $cols_from_relations) = $self->_merge_with_rscond($values); @@ -2634,7 +2705,7 @@ sub _merge_with_rscond { @cols_from_relations = keys %{ $implied_data || {} }; } else { - my $eqs = $self->result_source->schema->storage->_extract_fixed_condition_columns($self->{cond}, 'consider_nulls'); + my $eqs = extract_equality_conditions( $self->{cond}, 'consider_nulls' ); $implied_data = { map { ( ($eqs->{$_}||'') eq UNRESOLVABLE_CONDITION ) ? () : ( $_ => $eqs->{$_} ) } keys %$eqs }; @@ -2748,7 +2819,7 @@ sub as_query { my $attrs = { %{ $self->_resolved_attrs } }; - my $aq = $self->result_source->storage->_select_args_to_query ( + my $aq = $self->result_source->schema->storage->_select_args_to_query ( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs ); @@ -2794,7 +2865,7 @@ all in the call to C, even when set to C. sub find_or_new { my $self = shift; - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); my $hash = ref $_[0] eq 'HASH' ? shift : {@_}; if (keys %$hash and my $row = $self->find($hash, $attrs) ) { return $row; @@ -2883,7 +2954,7 @@ L. =cut -sub create { +sub create :DBIC_method_is_indirect_sugar { #my ($self, $col_data) = @_; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return shift->new_result(shift)->insert; @@ -2963,7 +3034,7 @@ database! sub find_or_create { my $self = shift; - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); my $hash = ref $_[0] eq 'HASH' ? shift : {@_}; if (keys %$hash and my $row = $self->find($hash, $attrs) ) { return $row; @@ -3029,7 +3100,7 @@ database! sub update_or_create { my $self = shift; - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); my $cond = ref $_[0] eq 'HASH' ? shift : {@_}; my $row = $self->find($cond, $attrs); @@ -3092,7 +3163,7 @@ See also L, L and L. sub update_or_new { my $self = shift; - my $attrs = ( @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {} ); + my $attrs = ( @_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {} ); my $cond = ref $_[0] eq 'HASH' ? shift : {@_}; my $row = $self->find( $cond, $attrs ); @@ -3201,7 +3272,7 @@ sub is_paged { sub is_ordered { my ($self) = @_; - return scalar $self->result_source->storage->_extract_order_criteria($self->{attrs}{order_by}); + return scalar $self->result_source->schema->storage->_extract_order_criteria($self->{attrs}{order_by}); } =head2 related_resultset @@ -3243,13 +3314,11 @@ sub related_resultset { my $attrs = $self->_chain_relationship($rel); - my $storage = $rsrc->schema->storage; - # Previously this atribute was deleted (instead of being set as it is now) # Doing so seems to be harmless in all available test permutations # See also 01d59a6a6 and mst's comment below # - $attrs->{alias} = $storage->relname_to_table_alias( + $attrs->{alias} = $rsrc->schema->storage->relname_to_table_alias( $rel, $attrs->{seen_join}{$rel} ); @@ -3257,8 +3326,55 @@ sub related_resultset { # since this is search_related, and we already slid the select window inwards # (the select/as attrs were deleted in the beginning), we need to flip all # left joins to inner, so we get the expected results - # read the comment on top of the actual function to see what this does - $attrs->{from} = $storage->_inner_join_to_node( $attrs->{from}, $attrs->{alias} ); + # + # The DBIC relationship chaining implementation is pretty simple - every + # new related_relationship is pushed onto the {from} stack, and the {select} + # window simply slides further in. This means that when we count somewhere + # in the middle, we got to make sure that everything in the join chain is an + # actual inner join, otherwise the count will come back with unpredictable + # results (a resultset may be generated with _some_ rows regardless of if + # the relation which the $rs currently selects has rows or not). E.g. + # $artist_rs->cds->count - normally generates: + # SELECT COUNT( * ) FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid + # which actually returns the number of artists * (number of cds || 1) + # + # So what we do here is crawl {from}, determine if the current alias is at + # the top of the stack, and if not - make sure the chain is inner-joined down + # to the root. + # + my $switch_branch = find_join_path_to_alias( + $attrs->{from}, + $attrs->{alias}, + ); + + if ( @{ $switch_branch || [] } ) { + + # So it looks like we will have to switch some stuff around. + # local() is useless here as we will be leaving the scope + # anyway, and deep cloning is just too fucking expensive + # So replace the first hashref in the node arrayref manually + my @new_from = $attrs->{from}[0]; + my $sw_idx = { map { (values %$_), 1 } @$switch_branch }; #there's one k/v per join-path + + for my $j ( @{$attrs->{from}}[ 1 .. $#{$attrs->{from}} ] ) { + my $jalias = $j->[0]{-alias}; + + if ($sw_idx->{$jalias}) { + my %attrs = %{$j->[0]}; + delete $attrs{-join_type}; + push @new_from, [ + \%attrs, + @{$j}[ 1 .. $#$j ], + ]; + } + else { + push @new_from, $j; + } + } + + $attrs->{from} = \@new_from; + } + #XXX - temp fix for result_class bug. There likely is a more elegant fix -groditi delete $attrs->{result_class}; @@ -3392,9 +3508,19 @@ but because we isolated the group by into a subselect the above works. =cut sub as_subselect_rs { + + # FIXME - remove at some point in the future (2018-ish) + wantarray + and + carp_unique( + 'Starting with DBIC@0.082900 as_subselect_rs() always returns a ResultSet ' + . 'instance regardless of calling context. Please force scalar() context to ' + . 'silence this warning' + ); + my $self = shift; - my $attrs = $self->_resolved_attrs; + my $alias = $self->current_source_alias; my $fresh_rs = (ref $self)->new ( $self->result_source @@ -3404,13 +3530,13 @@ sub as_subselect_rs { delete $fresh_rs->{cond}; delete @{$fresh_rs->{attrs}}{qw/where bind/}; - return $fresh_rs->search( {}, { + $fresh_rs->search_rs( {}, { from => [{ - $attrs->{alias} => $self->as_query, - -alias => $attrs->{alias}, + $alias => $self->as_query, + -alias => $alias, -rsrc => $self->result_source, }], - alias => $attrs->{alias}, + alias => $alias, }); } @@ -3451,7 +3577,7 @@ sub _chain_relationship { # Nuke the prefetch (if any) before the new $rs attrs # are resolved (prefetch is useless - we are wrapping # a subquery anyway). - my $rs_copy = $self->search; + my $rs_copy = $self->search_rs; $rs_copy->{attrs}{join} = $self->_merge_joinpref_attr ( $rs_copy->{attrs}{join}, delete $rs_copy->{attrs}{prefetch}, @@ -3544,10 +3670,13 @@ sub _resolved_attrs { if ( $attrs->{rows} =~ /[^0-9]/ or $attrs->{rows} <= 0 ); } + # normalize where condition + $attrs->{where} = normalize_sqla_condition( $attrs->{where} ) + if $attrs->{where}; # default selection list $attrs->{columns} = [ $source->columns ] - unless List::Util::first { exists $attrs->{$_} } qw/columns cols select as/; + unless grep { exists $attrs->{$_} } qw/columns cols select as/; # merge selectors together for (qw/columns select as/) { @@ -3708,7 +3837,7 @@ sub _resolved_attrs { if ( ! $attrs->{_main_source_premultiplied} and - ! List::Util::first { ! $_->[0]{-is_single} } @fromlist + ! grep { ! $_->[0]{-is_single} } @fromlist ) { $attrs->{collapse} = 0; } @@ -3730,7 +3859,7 @@ sub _resolved_attrs { else { $attrs->{_grouped_by_distinct} = 1; # distinct affects only the main selection part, not what prefetch may add below - ($attrs->{group_by}, my $new_order) = $source->storage->_group_over_selection($attrs); + ($attrs->{group_by}, my $new_order) = $source->schema->storage->_group_over_selection($attrs); # FIXME possibly ignore a rewritten order_by (may turn out to be an issue) # The thinking is: if we are collapsing the subquerying prefetch engine will @@ -3938,7 +4067,7 @@ sub _merge_joinpref_attr { }, ARRAY => sub { return $_[1] if !defined $_[0]; - return $_[1] if __HM_DEDUP and List::Util::first { $_ eq $_[0] } @{$_[1]}; + return $_[1] if __HM_DEDUP and grep { $_ eq $_[0] } @{$_[1]}; return [$_[0], @{$_[1]}] }, HASH => sub { @@ -3951,7 +4080,7 @@ sub _merge_joinpref_attr { ARRAY => { SCALAR => sub { return $_[0] if !defined $_[1]; - return $_[0] if __HM_DEDUP and List::Util::first { $_ eq $_[1] } @{$_[0]}; + return $_[0] if __HM_DEDUP and grep { $_ eq $_[1] } @{$_[0]}; return [@{$_[0]}, $_[1]] }, ARRAY => sub { @@ -3964,7 +4093,7 @@ sub _merge_joinpref_attr { HASH => sub { return [ $_[1] ] if ! @{$_[0]}; return $_[0] if !keys %{$_[1]}; - return $_[0] if __HM_DEDUP and List::Util::first { $_ eq $_[1] } @{$_[0]}; + return $_[0] if __HM_DEDUP and grep { $_ eq $_[1] } @{$_[0]}; return [ @{$_[0]}, $_[1] ]; }, }, @@ -3979,7 +4108,7 @@ sub _merge_joinpref_attr { return [] if !keys %{$_[0]} and !@{$_[1]}; return [ $_[0] ] if !@{$_[1]}; return $_[1] if !keys %{$_[0]}; - return $_[1] if __HM_DEDUP and List::Util::first { $_ eq $_[0] } @{$_[1]}; + return $_[1] if __HM_DEDUP and grep { $_ eq $_[0] } @{$_[1]}; return [ $_[0], @{$_[1]} ]; }, HASH => sub { diff --git a/lib/DBIx/Class/ResultSetColumn.pm b/lib/DBIx/Class/ResultSetColumn.pm index e26b6c2f3..1efdc35ee 100644 --- a/lib/DBIx/Class/ResultSetColumn.pm +++ b/lib/DBIx/Class/ResultSetColumn.pm @@ -5,12 +5,9 @@ use warnings; use base 'DBIx::Class'; use DBIx::Class::Carp; -use DBIx::Class::_Util 'fail_on_internal_wantarray'; +use DBIx::Class::_Util 'fail_on_internal_call'; use namespace::clean; -# not importing first() as it will clash with our own method -use List::Util (); - =head1 NAME DBIx::Class::ResultSetColumn - helpful methods for messing @@ -56,7 +53,7 @@ sub new { # (to create a new column definition on-the-fly). my $as_list = $orig_attrs->{as} || []; my $select_list = $orig_attrs->{select} || []; - my $as_index = List::Util::first { ($as_list->[$_] || "") eq $column } 0..$#$as_list; + my ($as_index) = grep { ($as_list->[$_] || "") eq $column } 0..$#$as_list; my $select = defined $as_index ? $select_list->[$as_index] : $column; my $colmap; @@ -154,12 +151,10 @@ one value. =cut sub next { - my $self = shift; + #my $self = shift; # using cursor so we don't inflate anything - my ($row) = $self->_resultset->cursor->next; - - return $row; + ($_[0]->_resultset->cursor->next)[0]; } =head2 all @@ -181,10 +176,10 @@ than result objects. =cut sub all { - my $self = shift; + #my $self = shift; # using cursor so we don't inflate anything - return map { $_->[0] } $self->_resultset->cursor->all; + map { $_->[0] } $_[0]->_resultset->cursor->all; } =head2 reset @@ -205,9 +200,10 @@ Much like L. =cut sub reset { - my $self = shift; - $self->_resultset->cursor->reset; - return $self; + #my $self = shift; + + $_[0]->_resultset->reset; + $_[0]; } =head2 first @@ -227,14 +223,13 @@ Much like L but just returning the one value. =cut -sub first { - my $self = shift; +sub first :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; # using cursor so we don't inflate anything - $self->_resultset->cursor->reset; - my ($row) = $self->_resultset->cursor->next; - - return $row; + my $cursor = $_[0]->_resultset->cursor; + $cursor->reset; + ($cursor->next)[0]; } =head2 single @@ -254,14 +249,14 @@ is issued before discarding the cursor. =cut sub single { - my $self = shift; + #my $self = shift; - my $attrs = $self->_resultset->_resolved_attrs; - my ($row) = $self->_resultset->result_source->storage->select_single( - $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs - ); + my $rs = $_[0]->_resultset; - return $row; + my $attrs = $rs->_resolved_attrs; + ($rs->result_source->schema->storage->select_single( + $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs + ))[0]; } =head2 min @@ -281,8 +276,9 @@ resultset (or C if there are none). =cut -sub min { - return shift->func('MIN'); +sub min :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->func('MIN'); } =head2 min_rs @@ -301,7 +297,10 @@ Wrapper for ->func_rs for function MIN(). =cut -sub min_rs { return shift->func_rs('MIN') } +sub min_rs :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->func_rs('MIN') +} =head2 max @@ -320,8 +319,9 @@ resultset (or C if there are none). =cut -sub max { - return shift->func('MAX'); +sub max :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->func('MAX'); } =head2 max_rs @@ -340,7 +340,10 @@ Wrapper for ->func_rs for function MAX(). =cut -sub max_rs { return shift->func_rs('MAX') } +sub max_rs :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->func_rs('MAX') +} =head2 sum @@ -359,8 +362,9 @@ the resultset. Use on varchar-like columns at your own risk. =cut -sub sum { - return shift->func('SUM'); +sub sum :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->func('SUM'); } =head2 sum_rs @@ -379,7 +383,10 @@ Wrapper for ->func_rs for function SUM(). =cut -sub sum_rs { return shift->func_rs('SUM') } +sub sum_rs :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->func_rs('SUM') +} =head2 func @@ -401,16 +408,16 @@ value. Produces the following SQL: =cut -sub func { - my ($self,$function) = @_; - my $cursor = $self->func_rs($function)->cursor; +sub func :DBIC_method_is_indirect_sugar{ + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; - if( wantarray ) { - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray; - return map { $_->[ 0 ] } $cursor->all; - } + #my ($self,$function) = @_; + my $cursor = $_[0]->func_rs($_[1])->cursor; - return ( $cursor->next )[ 0 ]; + wantarray + ? map { $_->[ 0 ] } $cursor->all + : ( $cursor->next )[ 0 ] + ; } =head2 func_rs @@ -439,7 +446,16 @@ sub func_rs { $rs = $rs->as_subselect_rs; } - $rs->search( undef, { + # FIXME - remove at some point in the future (2018-ish) + wantarray + and + carp_unique( + 'Starting with DBIC@0.082900 func_rs() always returns a ResultSet ' + . 'instance regardless of calling context. Please force scalar() context to ' + . 'silence this warning' + ); + + $rs->search_rs( undef, { columns => { $self->{_as} => { $function => $select } } } ); } @@ -494,11 +510,11 @@ sub _resultset { # collapse the selector to a literal so that it survives the distinct parse # if it turns out to be an aggregate - at least the user will get a proper exception # instead of silent drop of the group_by altogether - $select = \[ $rsrc->storage->sql_maker->_recurse_fields($select) ]; + $select = \[ $rsrc->schema->storage->sql_maker->_recurse_fields($select) ]; } } - $self->{_parent_resultset}->search(undef, { + $self->{_parent_resultset}->search_rs(undef, { columns => { $self->{_as} => $select } }); }; diff --git a/lib/DBIx/Class/ResultSetManager.pm b/lib/DBIx/Class/ResultSetManager.pm index bb9f3bf06..e4adae57a 100644 --- a/lib/DBIx/Class/ResultSetManager.pm +++ b/lib/DBIx/Class/ResultSetManager.pm @@ -2,8 +2,9 @@ package DBIx::Class::ResultSetManager; use strict; use warnings; use base 'DBIx::Class'; -use Sub::Name (); -use Class::Inspector; + +use DBIx::Class::_Util qw( set_subname describe_class_methods ); +use namespace::clean; warn "DBIx::Class::ResultSetManager never left experimental status and has now been DEPRECATED. This module will be deleted in 09000 so please @@ -27,8 +28,9 @@ appropriate My::Schema::ResultSet::* classes for it to pick up."; =cut -__PACKAGE__->mk_classdata($_) - for qw/ base_resultset_class table_resultset_class_suffix /; +__PACKAGE__->mk_group_accessors(inherited => qw( + base_resultset_class table_resultset_class_suffix +)); __PACKAGE__->base_resultset_class('DBIx::Class::ResultSet'); __PACKAGE__->table_resultset_class_suffix('::_resultset'); @@ -53,16 +55,22 @@ sub _register_attributes { my $cache = $self->_attr_cache; return if keys %$cache == 0; - foreach my $meth (@{Class::Inspector->methods($self) || []}) { - my $attrs = $cache->{$self->can($meth)}; - next unless $attrs; - if ($attrs->[0] eq 'ResultSet') { - no strict 'refs'; - my $resultset_class = $self->_setup_resultset_class; - my $name = join '::',$resultset_class, $meth; - *$name = Sub::Name::subname $name, $self->can($meth); - delete ${"${self}::"}{$meth}; - } + for my $meth( + map + { $_->{name} } + grep + { $_->{attributes}{ResultSet} } + map + { $_->[0] } + values %{ describe_class_methods( ref $self || $self )->{methods} } + ) { + # This codepath is extremely old, miht as well keep it running + # as-is with no room for surprises + no strict 'refs'; + my $resultset_class = $self->_setup_resultset_class; + my $name = join '::',$resultset_class, $meth; + *$name = set_subname $name, $self->can($meth); + delete ${"${self}::"}{$meth}; } } @@ -80,12 +88,11 @@ sub _register_resultset_class { my $self = shift; my $resultset_class = $self . $self->table_resultset_class_suffix; no strict 'refs'; - if (@{"$resultset_class\::ISA"}) { - $self->result_source_instance->resultset_class($resultset_class); - } else { - $self->result_source_instance->resultset_class - ($self->base_resultset_class); - } + $self->result_source->resultset_class( + ( scalar @{"${resultset_class}::ISA"} ) + ? $resultset_class + : $self->base_resultset_class + ); } =head1 FURTHER QUESTIONS? diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 0940e0dd1..aa8338b2b 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -1,34 +1,61 @@ package DBIx::Class::ResultSource; +### !!!NOTE!!! +# +# Some of the methods defined here will be around()-ed by code at the +# end of ::ResultSourceProxy. The reason for this strange arrangement +# is that the list of around()s of methods in this class depends +# directly on the list of may-not-be-defined-yet methods within +# ::ResultSourceProxy itself. +# If this sounds terrible - it is. But got to work with what we have. +# + use strict; use warnings; -use base qw/DBIx::Class::ResultSource::RowParser DBIx::Class/; - -use DBIx::Class::ResultSet; -use DBIx::Class::ResultSourceHandle; +use base 'DBIx::Class::ResultSource::RowParser'; use DBIx::Class::Carp; -use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try ); +use DBIx::Class::_Util qw( + UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR + dbic_internal_try fail_on_internal_call + refdesc emit_loud_diag dump_value serialize bag_eq +); +use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; use SQL::Abstract 'is_literal_value'; use Devel::GlobalDestruction; -use Scalar::Util qw/blessed weaken isweak/; +use Scalar::Util qw( blessed weaken isweak refaddr ); -use namespace::clean; +# FIXME - somehow breaks ResultSetManager, do not remove until investigated +use DBIx::Class::ResultSet; -__PACKAGE__->mk_group_accessors(simple => qw/ - source_name name source_info - _ordered_columns _columns _primaries _unique_constraints - _relationships resultset_attributes - column_info_from_storage -/); +use namespace::clean; -__PACKAGE__->mk_group_accessors(component_class => qw/ +# This global is present for the afaik nonexistent, but nevertheless possible +# case of folks using stock ::ResultSet with a completely custom Result-class +# hierarchy, not derived from DBIx::Class::Row at all +# Instead of patching stuff all over the place - this would be one convenient +# place to override things if need be +our $__expected_result_class_isa = 'DBIx::Class::Row'; + +my @hashref_attributes = qw( + source_info resultset_attributes + _columns _unique_constraints _relationships +); +my @arrayref_attributes = qw( + _ordered_columns _primaries +); +__PACKAGE__->mk_group_accessors(rsrc_instance_specific_attribute => + @hashref_attributes, + @arrayref_attributes, + qw( source_name name column_info_from_storage sqlt_deploy_callback ), +); + +__PACKAGE__->mk_group_accessors(rsrc_instance_specific_handler => qw( resultset_class result_class -/); - -__PACKAGE__->mk_classdata( sqlt_deploy_callback => 'default_sqlt_deploy_hook' ); +)); =head1 NAME @@ -56,8 +83,8 @@ DBIx::Class::ResultSource - Result source object __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year2000cds'); - __PACKAGE__->result_source_instance->is_virtual(1); - __PACKAGE__->result_source_instance->view_definition( + __PACKAGE__->result_source->is_virtual(1); + __PACKAGE__->result_source->view_definition( "SELECT cdid, artist, title FROM cd WHERE year ='2000'" ); @@ -117,19 +144,350 @@ Creates a new ResultSource object. Not normally called directly by end users. =cut -sub new { - my ($class, $attrs) = @_; - $class = ref $class if ref $class; - - my $new = bless { %{$attrs || {}} }, $class; - $new->{resultset_class} ||= 'DBIx::Class::ResultSet'; - $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} }; - $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}]; - $new->{_columns} = { %{$new->{_columns}||{}} }; - $new->{_relationships} = { %{$new->{_relationships}||{}} }; - $new->{name} ||= "!!NAME NOT SET!!"; - $new->{_columns_info_loaded} ||= 0; - return $new; +{ + my $rsrc_registry; + + sub __derived_instances { + map { + (defined $_->{weakref}) + ? $_->{weakref} + : () + } values %{ $rsrc_registry->{ refaddr($_[0]) }{ derivatives } } + } + + sub new { + my ($class, $attrs) = @_; + $class = ref $class if ref $class; + + my $ancestor = delete $attrs->{__derived_from}; + + my $self = bless { %$attrs }, $class; + + + DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + and + # a constructor with 'name' as sole arg clearly isn't "inheriting" from anything + ( not ( keys(%$self) == 1 and exists $self->{name} ) ) + and + defined CORE::caller(1) + and + (CORE::caller(1))[3] !~ / ::new$ | ^ DBIx::Class :: (?: + ResultSourceProxy::Table::table + | + ResultSourceProxy::Table::_init_result_source_instance + | + ResultSource::clone + ) $ /x + and + local $Carp::CarpLevel = $Carp::CarpLevel + 1 + and + Carp::confess("Incorrect instantiation of '$self': you almost certainly wanted to call ->clone() instead"); + + + my $own_slot = $rsrc_registry->{ + my $own_addr = refaddr $self + } = { derivatives => {} }; + + weaken( $own_slot->{weakref} = $self ); + + if( + length ref $ancestor + and + my $ancestor_slot = $rsrc_registry->{ + my $ancestor_addr = refaddr $ancestor + } + ) { + + # on ancestry recording compact registry slots, prevent unbound growth + for my $r ( $rsrc_registry, map { $_->{derivatives} } values %$rsrc_registry ) { + defined $r->{$_}{weakref} or delete $r->{$_} + for keys %$r; + } + + weaken( $_->{$own_addr} = $own_slot ) for map + { $_->{derivatives} } + ( + $ancestor_slot, + (grep + { defined $_->{derivatives}{$ancestor_addr} } + values %$rsrc_registry + ), + ) + ; + } + + + $self->{resultset_class} ||= 'DBIx::Class::ResultSet'; + $self->{name} ||= "!!NAME NOT SET!!"; + $self->{_columns_info_loaded} ||= 0; + $self->{sqlt_deploy_callback} ||= 'default_sqlt_deploy_hook'; + + $self->{$_} = { %{ $self->{$_} || {} } } + for @hashref_attributes, '__metadata_divergencies'; + + $self->{$_} = [ @{ $self->{$_} || [] } ] + for @arrayref_attributes; + + $self; + } + + sub DBIx::Class::__Rsrc_Ancestry_iThreads_handler__::CLONE { + for my $r ( $rsrc_registry, map { $_->{derivatives} } values %$rsrc_registry ) { + %$r = map { + defined $_->{weakref} + ? ( refaddr $_->{weakref} => $_ ) + : () + } values %$r + } + } + + + # needs direct access to $rsrc_registry under an assert + # + sub set_rsrc_instance_specific_attribute { + + # only mark if we are setting something different + if ( + ( + defined( $_[2] ) + xor + defined( $_[0]->{$_[1]} ) + ) + or + ( + # both defined + defined( $_[2] ) + and + ( + # differ in ref-ness + ( + length ref( $_[2] ) + xor + length ref( $_[0]->{$_[1]} ) + ) + or + # both refs (the mark-on-same-ref is deliberate) + length ref( $_[2] ) + or + # both differing strings + $_[2] ne $_[0]->{$_[1]} + ) + ) + ) { + + my $callsite; + # need to protect $_ here + for my $derivative ( + $_[0]->__derived_instances, + + # DO NOT REMOVE - this blob is marking *ancestors* as tainted, here to + # weed out any fallout from https://github.com/dbsrgits/dbix-class/commit/9e36e3ec + # Note that there is no way to kill this warning, aside from never + # calling set_primary_key etc more than once per hierarchy + # (this is why the entire thing is guarded by an assert) + ( + ( + DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + and + grep { $_[1] eq $_ } qw( _unique_constraints _primaries source_info ) + ) + ? ( + map + { defined($_->{weakref}) ? $_->{weakref} : () } + grep + { defined( ( $_->{derivatives}{refaddr($_[0])} || {} )->{weakref} ) } + values %$rsrc_registry + ) + : () + ), + ) { + + $derivative->{__metadata_divergencies}{$_[1]}{ $callsite ||= do { + + # + # FIXME - this is horrible, but it's the best we can do for now + # Replace when Carp::Skip is written (it *MUST* take this use-case + # into consideration) + # + my ($cs) = DBIx::Class::Carp::__find_caller(__PACKAGE__); + + my ($fr_num, @fr) = 1; + while( @fr = CORE::caller($fr_num++) ) { + $cs =~ /^ \Qat $fr[1] line $fr[2]\E (?: $ | \n )/x + and + $fr[3] =~ s/.+::// + and + last + } + + # FIXME - using refdesc here isn't great, but I can't think of anything + # better at this moment + @fr + ? "@{[ refdesc $_[0] ]}->$fr[3](...) $cs" + : "$cs" + ; + } } = 1; + } + } + + $_[0]->{$_[1]} = $_[2]; + } +} + +sub get_rsrc_instance_specific_attribute { + + $_[0]->__emit_stale_metadata_diag( $_[1] ) if ( + ! $_[0]->{__in_rsrc_setter_callstack} + and + $_[0]->{__metadata_divergencies}{$_[1]} + ); + + $_[0]->{$_[1]}; +} + + +# reuse the elaborate set logic of instance_specific_attr +sub set_rsrc_instance_specific_handler { + $_[0]->set_rsrc_instance_specific_attribute($_[1], $_[2]); + + # trigger a load for the case of $foo->handler_accessor("bar")->new + $_[0]->get_rsrc_instance_specific_handler($_[1]) + if defined wantarray; +} + +# This is essentially the same logic as get_component_class +# (in DBIC::AccessorGroup). However the latter is a grouped +# accessor type, and here we are strictly after a 'simple' +# So we go ahead and recreate the logic as found in ::AG +sub get_rsrc_instance_specific_handler { + + # emit desync warnings if any + my $val = $_[0]->get_rsrc_instance_specific_attribute( $_[1] ); + + # plain string means class - load it + no strict 'refs'; + if ( + defined $val + and + # inherited CAG can't be set to undef effectively, so people may use '' + length $val + and + ! defined blessed $val + and + ! ${"${val}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} + ) { + $_[0]->ensure_class_loaded($val); + + ${"${val}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} + = do { \(my $anon = 'loaded') }; + } + + $val; +} + + +sub __construct_stale_metadata_diag { + return '' unless $_[0]->{__metadata_divergencies}{$_[1]}; + + my ($fr_num, @fr); + + # find the CAG getter FIRST + # allows unlimited user-namespace overrides without screwing around with + # $LEVEL-like crap + while( + @fr = CORE::caller(++$fr_num) + and + $fr[3] ne 'DBIx::Class::ResultSource::get_rsrc_instance_specific_attribute' + ) { 1 } + + Carp::confess( "You are not supposed to call __construct_stale_metadata_diag here..." ) + unless @fr; + + # then find the first non-local, non-private reportable callsite + while ( + @fr = CORE::caller(++$fr_num) + and + ( + $fr[2] == 0 + or + $fr[3] eq '(eval)' + or + $fr[1] =~ /^\(eval \d+\)$/ + or + $fr[3] =~ /::(?: __ANON__ | _\w+ )$/x + or + $fr[0] =~ /^DBIx::Class::ResultSource/ + ) + ) { 1 } + + my $by = ( @fr and $fr[3] =~ s/.+::// ) + # FIXME - using refdesc here isn't great, but I can't think of anything + # better at this moment + ? " by 'getter' @{[ refdesc $_[0] ]}->$fr[3](...)\n within the callstack beginning" + : '' + ; + + # Given the full stacktrace combined with the really involved callstack + # there is no chance the emitter will properly deduplicate this + # Only complain once per callsite per source + return( ( $by and $_[0]->{__encountered_divergencies}{$by}++ ) + + ? '' + + : "$_[0] (the metadata instance of source '@{[ $_[0]->source_name ]}') is " + . "*OUTDATED*, and does not reflect the modifications of its " + . "*ancestors* as follows:\n" + . join( "\n", + map + { " * $_->[0]" } + sort + { $a->[1] cmp $b->[1] } + map + { [ $_, ( $_ =~ /( at .+? line \d+)/ ) ] } + keys %{ $_[0]->{__metadata_divergencies}{$_[1]} } + ) + . "\nStale metadata accessed${by}" + ); +} + +sub __emit_stale_metadata_diag { + emit_loud_diag( + msg => ( + # short circuit: no message - no diag + $_[0]->__construct_stale_metadata_diag($_[1]) + || + return 0 + ), + # the constructor already does deduplication + emit_dups => 1, + confess => DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE, + ); +} + +=head2 clone + + $rsrc_instance->clone( atribute_name => overridden_value ); + +A wrapper around L inheriting any defaults from the callee. This method +also not normally invoked directly by end users. + +=cut + +sub clone { + my $self = shift; + + $self->new({ + ( + (length ref $self) + ? ( %$self, __derived_from => $self ) + : () + ), + ( + (@_ == 1 and ref $_[0] eq 'HASH') + ? %{ $_[0] } + : @_ + ), + }); } =pod @@ -330,15 +688,25 @@ info keys as L. sub add_columns { my ($self, @cols) = @_; + + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + $self->_ordered_columns(\@cols) unless $self->_ordered_columns; - my @added; + my ( @added, $colinfos ); my $columns = $self->_columns; + while (my $col = shift @cols) { - my $column_info = {}; - if ($col =~ s/^\+//) { - $column_info = $self->column_info($col); - } + my $column_info = + ( + $col =~ s/^\+// + and + ( $colinfos ||= $self->columns_info )->{$col} + ) + || + {} + ; # If next entry is { ... } use that for the column info, if not # use an empty hashref @@ -349,11 +717,16 @@ sub add_columns { push(@added, $col) unless exists $columns->{$col}; $columns->{$col} = $column_info; } + push @{ $self->_ordered_columns }, @added; + $self->_columns($columns); return $self; } -sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB +sub add_column :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->add_columns(@_) +} =head2 has_column @@ -394,36 +767,11 @@ contents of the hashref. =cut -sub column_info { - my ($self, $column) = @_; - $self->throw_exception("No such column $column") - unless exists $self->_columns->{$column}; - - if ( ! $self->_columns->{$column}{data_type} - and ! $self->{_columns_info_loaded} - and $self->column_info_from_storage - and my $stor = dbic_internal_try { $self->storage } ) - { - $self->{_columns_info_loaded}++; - - # try for the case of storage without table - dbic_internal_try { - my $info = $stor->columns_info_for( $self->from ); - my $lc_info = { map - { (lc $_) => $info->{$_} } - ( keys %$info ) - }; - - foreach my $col ( keys %{$self->_columns} ) { - $self->_columns->{$col} = { - %{ $self->_columns->{$col} }, - %{ $info->{$col} || $lc_info->{lc $col} || {} } - }; - } - }; - } +sub column_info :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; - return $self->_columns->{$column}; + #my ($self, $column) = @_; + $_[0]->columns_info([ $_[1] ])->{$_[1]}; } =head2 columns @@ -480,7 +828,7 @@ sub columns_info { and grep { ! $_->{data_type} } values %$colinfo and - my $stor = dbic_internal_try { $self->storage } + my $stor = dbic_internal_try { $self->schema->storage } ) { $self->{_columns_info_loaded}++; @@ -518,6 +866,8 @@ sub columns_info { } } else { + # the shallow copy is crucial - there are exists() checks within + # the wider codebase %ret = %$colinfo; } @@ -566,6 +916,9 @@ broken result source. sub remove_columns { my ($self, @to_remove) = @_; + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + my $columns = $self->_columns or return; @@ -578,7 +931,10 @@ sub remove_columns { $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]); } -sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB +sub remove_column :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->remove_columns(@_) +} =head2 set_primary_key @@ -607,6 +963,9 @@ for more info. sub set_primary_key { my ($self, @cols) = @_; + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + my $colinfo = $self->columns_info(\@cols); for my $col (@cols) { carp_unique(sprintf ( @@ -689,6 +1048,9 @@ will be applied to the L of each L sub sequence { my ($self,$seq) = @_; + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + my @pks = $self->primary_columns or return; @@ -701,7 +1063,7 @@ sub sequence { =over 4 -=item Arguments: $name?, \@colnames +=item Arguments: $name?, \%uq_info | \@colnames =item Return Value: not defined @@ -710,14 +1072,45 @@ sub sequence { Declare a unique constraint on this source. Call once for each unique constraint. +The C key to the C<\%uq_info> hashref will be an arrayref +containing the columns to affect. + # For UNIQUE (column1, column2) + __PACKAGE__->add_unique_constraint( + constraint_name => { + columns => [ qw/column1 column2/ ], + } + ); + +Currently, the key C is also supported, which will be +passed to L. + + __PACKAGE__->add_unique_constraint( + constraint_name => { + columns => [ qw/column1 column2/ ], + sqlt_extra => { deferrable => 1 }, + } + ); + +Alternatively, you can use the columns arrayref directly, although +this form is discouraged. + __PACKAGE__->add_unique_constraint( constraint_name => [ qw/column1 column2/ ], ); -Alternatively, you can specify only the columns: +Finally, you can also omit the constraint name; but this is also discouraged. - __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]); + __PACKAGE__->add_unique_constraint( + [ qw/column1 column2/ ], + ); + + __PACKAGE__->add_unique_constraint( + { + columns => [ qw/column1 column2/ ], + sqlt_extra => { deferrable => 1 }, + } + ); This will result in a unique constraint named C, where C is replaced with the table @@ -730,11 +1123,18 @@ only columns in the constraint are searched. Throws an error if any of the given column names do not yet exist on the result source. +Note also that the keys C
, C, and C in +C will be ignored. See +L for other valid keys. + =cut sub add_unique_constraint { my $self = shift; + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + if (@_ > 2) { $self->throw_exception( 'add_unique_constraint() does not accept multiple constraints, use ' @@ -742,25 +1142,37 @@ sub add_unique_constraint { ); } - my $cols = pop @_; - if (ref $cols ne 'ARRAY') { + my $constraint = pop @_; + + if (ref $constraint eq 'ARRAY') { + $constraint = { + columns => $constraint + }; + } + elsif (ref $constraint ne 'HASH') { $self->throw_exception ( - 'Expecting an arrayref of constraint columns, got ' . ($cols||'NOTHING') + 'Expecting a hashref of constraint info, got ' . ($constraint||'NOTHING') + ); + } + + if (! $constraint->{columns}) { + $self->throw_exception ( + 'Expecting "columns" key in hashref, but it was not present' ); } my $name = shift @_; - $name ||= $self->name_unique_constraint($cols); + $name ||= $self->name_unique_constraint($constraint->{columns}); - foreach my $col (@$cols) { + foreach my $col (@{$constraint->{columns}}) { $self->throw_exception("No such column $col on table " . $self->name) unless $self->has_column($col); } - my %unique_constraints = $self->unique_constraints; - $unique_constraints{$name} = $cols; - $self->_unique_constraints(\%unique_constraints); + my $unique_constraints = $self->_unique_constraints; + $unique_constraints->{$name} = $constraint; + $self->_unique_constraints($unique_constraints); } =head2 add_unique_constraints @@ -776,28 +1188,26 @@ sub add_unique_constraint { Declare multiple unique constraints on this source. __PACKAGE__->add_unique_constraints( - constraint_name1 => [ qw/column1 column2/ ], - constraint_name2 => [ qw/column2 column3/ ], - ); - -Alternatively, you can specify only the columns: - - __PACKAGE__->add_unique_constraints( - [ qw/column1 column2/ ], - [ qw/column3 column4/ ] + constraint_name1 => { + columns => [ qw/column1 column2/ ] + }, + constraint_name2 => { + columns => [ qw/column2 column3/ ] + }, ); -This will result in unique constraints named C and -C, where C
is replaced with the table name. +Works exactly like L, inasmuch as you can +omit the column names, or use just the arrayrefs; but the form shown +above is preferred. Throws an error if any of the given column names do not yet exist on the result source. -See also L. - =cut -sub add_unique_constraints { +sub add_unique_constraints :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + my $self = shift; my @constraints = @_; @@ -873,7 +1283,37 @@ column names as values. =cut sub unique_constraints { - return %{shift->_unique_constraints||{}}; + my $uniques = shift->_unique_constraints || {}; + + return map { $_ => $uniques->{$_}->{columns} } keys %$uniques; +} + +=head2 unique_constraints_info + +=over 4 + +=item Arguments: none + +=item Return Value: Hashref of unique constraint data + +=back + + my $unique_info = $source->unique_constraints_info(); + +Read-only accessor returning all information about unique constraints. + +The hashref is keyed by the constraint name, and the values are the +hashrefs originally provided to L (or +L). See L for the +structure of these hashrefs. + +B that while similar functions return flattened hashes as a +list, this one returns a single hashref; just like L. + +=cut + +sub unique_constraints_info { + return shift->_unique_constraints; } =head2 unique_constraint_names @@ -938,11 +1378,11 @@ sub unique_constraint_columns { =back - __PACKAGE__->sqlt_deploy_callback('mycallbackmethod'); + __PACKAGE__->result_source->sqlt_deploy_callback('mycallbackmethod'); or - __PACKAGE__->sqlt_deploy_callback(sub { + __PACKAGE__->result_source->sqlt_deploy_callback(sub { my ($source_instance, $sqlt_table) = @_; ... } ); @@ -1090,12 +1530,15 @@ Store a collection of resultset attributes, that will be set on every 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! +bugs! Notably the contents of the attributes are B, which +greatly hinders composability (things like L can not possibly be respected). +While C isn't deprecated per se, you are strongly urged +to seek alternatives. 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. +the defaults B, so you are stuck with them. In most cases, what you should actually be using are project-specific methods: @@ -1221,10 +1664,11 @@ result source instance has been attached to. sub schema { if (@_ > 1) { - $_[0]->{schema} = $_[1]; + # invoke the mark-diverging logic + $_[0]->set_rsrc_instance_specific_attribute( schema => $_[1] ); } else { - $_[0]->{schema} || do { + $_[0]->get_rsrc_instance_specific_attribute( 'schema' ) || do { my $name = $_[0]->{source_name} || '_unnamed_'; my $err = 'Unable to perform storage-dependent operations with a detached result source ' . "(source '$name' is not associated with a schema)."; @@ -1254,7 +1698,10 @@ Returns the L for the current schema. =cut -sub storage { shift->schema->storage; } +sub storage :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->schema->storage +} =head2 add_relationship @@ -1337,6 +1784,10 @@ be resolved. sub add_relationship { my ($self, $rel, $f_source_name, $cond, $attrs) = @_; + + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + $self->throw_exception("Can't create relationship without join condition") unless $cond; $attrs ||= {}; @@ -1377,7 +1828,7 @@ Returns all relationship names for this source. =cut sub relationships { - return keys %{shift->_relationships}; + keys %{$_[0]->_relationships}; } =head2 relationship_info @@ -1446,85 +1897,111 @@ L. sub reverse_relationship_info { my ($self, $rel) = @_; - my $rel_info = $self->relationship_info($rel) - or $self->throw_exception("No such relationship '$rel'"); + # This may be a partial schema or something else equally esoteric + # in which case this will throw + # + my $other_rsrc = $self->related_source($rel); - my $ret = {}; + # Some custom rels may not resolve without a $schema + # + my $our_resolved_relcond = dbic_internal_try { + $self->resolve_relationship_condition( + rel_name => $rel, - return $ret unless ((ref $rel_info->{cond}) eq 'HASH'); + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, + ) + }; - my $stripped_cond = $self->__strip_relcond ($rel_info->{cond}); + # only straight-equality is compared + return {} + unless $our_resolved_relcond->{identity_map_matches_condition}; - my $registered_source_name = $self->source_name; + my( $our_registered_source_name, $our_result_class) = + ( $self->source_name, $self->result_class ); - # this may be a partial schema or something else equally esoteric - my $other_rsrc = $self->related_source($rel); + my $ret = {}; # Get all the relationships for that source that related to this source # whose foreign column set are our self columns on $rel and whose self # columns are our foreign columns on $rel foreach my $other_rel ($other_rsrc->relationships) { + # this will happen when we have a self-referential class + next if ( + $other_rel eq $rel + and + $self == $other_rsrc + ); + # only consider stuff that points back to us # "us" here is tricky - if we are in a schema registration, we want # to use the source_names, otherwise we will use the actual classes - # the schema may be partial - my $roundtrip_rsrc = dbic_internal_try { $other_rsrc->related_source($other_rel) } - or next; + my $roundtripped_rsrc; + next unless ( - if ($registered_source_name) { - next if $registered_source_name ne ($roundtrip_rsrc->source_name || '') - } - else { - next if $self->result_class ne $roundtrip_rsrc->result_class; - } + # the schema may be partially loaded + $roundtripped_rsrc = dbic_internal_try { $other_rsrc->related_source($other_rel) } - my $other_rel_info = $other_rsrc->relationship_info($other_rel); + and - # this can happen when we have a self-referential class - next if $other_rel_info eq $rel_info; + ( - next unless ref $other_rel_info->{cond} eq 'HASH'; - my $other_stripped_cond = $self->__strip_relcond($other_rel_info->{cond}); + ( + $our_registered_source_name + and + ( + $our_registered_source_name + eq + $roundtripped_rsrc->source_name||'' + ) + ) - $ret->{$other_rel} = $other_rel_info if ( - $self->_compare_relationship_keys ( - [ keys %$stripped_cond ], [ values %$other_stripped_cond ] + or + + ( + $our_result_class + eq + $roundtripped_rsrc->result_class + ) ) + and - $self->_compare_relationship_keys ( - [ values %$stripped_cond ], [ keys %$other_stripped_cond ] - ) + + my $their_resolved_relcond = dbic_internal_try { + $other_rsrc->resolve_relationship_condition( + rel_name => $other_rel, + + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, + ) + } ); - } - return $ret; -} -# all this does is removes the foreign/self prefix from a condition -sub __strip_relcond { - +{ - map - { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) } - keys %{$_[1]} - } -} + $ret->{$other_rel} = $other_rsrc->relationship_info($other_rel) if ( -sub compare_relationship_keys { - carp 'compare_relationship_keys is a private method, stop calling it'; - my $self = shift; - $self->_compare_relationship_keys (@_); -} + $their_resolved_relcond->{identity_map_matches_condition} -# Returns true if both sets of keynames are the same, false otherwise. -sub _compare_relationship_keys { -# my ($self, $keys1, $keys2) = @_; - return - join ("\x00", sort @{$_[1]}) - eq - join ("\x00", sort @{$_[2]}) - ; + and + + keys %{ $our_resolved_relcond->{identity_map} } + == + keys %{ $their_resolved_relcond->{identity_map} } + + and + + serialize( $our_resolved_relcond->{identity_map} ) + eq + serialize( { reverse %{ $their_resolved_relcond->{identity_map} } } ) + + ); + } + + return $ret; } # optionally takes either an arrayref of column names, or a hashref of already @@ -1559,7 +2036,7 @@ sub _minimal_valueset_satisfying_constraint { $args->{columns_info} ||= $self->columns_info; - my $vals = $self->storage->_extract_fixed_condition_columns( + my $vals = extract_equality_conditions( $args->{values}, ($args->{carp_on_nulls} ? 'consider_nulls' : undef ), ); @@ -1573,7 +2050,7 @@ sub _minimal_valueset_satisfying_constraint { $cols->{$args->{carp_on_nulls} ? 'undefined' : 'missing'}{$col} = undef; } else { - # we need to inject back the '=' as _extract_fixed_condition_columns + # we need to inject back the '=' as extract_equality_conditions() # will strip it from literals and values alike, resulting in an invalid # condition in the end $cols->{present}{$col} = { '=' => $vals->{$col} }; @@ -1648,7 +2125,7 @@ sub _resolve_join { $force_left ||= lc($rel_info->{attrs}{join_type}||'') eq 'left'; # the actual seen value will be incremented by the recursion - my $as = $self->storage->relname_to_table_alias( + my $as = $self->schema->storage->relname_to_table_alias( $rel, ($seen->{$rel} && $seen->{$rel} + 1) ); @@ -1667,7 +2144,7 @@ sub _resolve_join { } else { my $count = ++$seen->{$join}; - my $as = $self->storage->relname_to_table_alias( + my $as = $self->schema->storage->relname_to_table_alias( $join, ($count > 1 && $count) ); @@ -1692,7 +2169,7 @@ sub _resolve_join { -alias => $as, -relation_chain_depth => ( $seen->{-relation_chain_depth} || 0 ) + 1, }, - $self->_resolve_relationship_condition( + $self->resolve_relationship_condition( rel_name => $join, self_alias => $alias, foreign_alias => $as, @@ -1730,31 +2207,64 @@ sub _pk_depends_on { # auto-increment my $rel_source = $self->related_source($rel_name); + my $colinfos; + foreach my $p ($self->primary_columns) { - if (exists $keyhash->{$p}) { - unless (defined($rel_data->{$keyhash->{$p}}) - || $rel_source->column_info($keyhash->{$p}) - ->{is_auto_increment}) { - return 0; - } - } + return 0 if ( + exists $keyhash->{$p} + and + ! defined( $rel_data->{$keyhash->{$p}} ) + and + ! ( $colinfos ||= $rel_source->columns_info ) + ->{$keyhash->{$p}}{is_auto_increment} + ) } return 1; } -sub resolve_condition { - carp 'resolve_condition is a private method, stop calling it'; +sub __strip_relcond :DBIC_method_is_indirect_sugar { + DBIx::Class::Exception->throw( + '__strip_relcond() has been removed with no replacement, ' + . 'ask for advice on IRC if this affected you' + ); +} + +sub compare_relationship_keys :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + carp_unique( 'compare_relationship_keys() is deprecated, ask on IRC for a better alternative' ); + bag_eq( $_[1], $_[2] ); +} + +sub _compare_relationship_keys :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + carp_unique( '_compare_relationship_keys() is deprecated, ask on IRC for a better alternative' ); + bag_eq( $_[1], $_[2] ); +} + +sub _resolve_relationship_condition :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + + # carp() - has been on CPAN for less than 2 years + carp '_resolve_relationship_condition() is deprecated - see resolve_relationship_condition() instead'; + + shift->resolve_relationship_condition(@_); +} + +sub resolve_condition :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + + # carp() - has been discouraged forever + carp 'resolve_condition() is deprecated - see resolve_relationship_condition() instead'; + shift->_resolve_condition (@_); } -sub _resolve_condition { -# carp_unique sprintf -# '_resolve_condition is a private method, and moreover is about to go ' -# . 'away. Please contact the development team at %s if you believe you ' -# . 'have a genuine use for this method, in order to discuss alternatives.', -# DBIx::Class::_ENV_::HELP_URL, -# ; +sub _resolve_condition :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + + # carp_unique() - the interface replacing it only became reality in Sep 2016 + carp_unique '_resolve_condition() is deprecated - see resolve_relationship_condition() instead'; ####################### ### API Design? What's that...? (a backwards compatible shim, kill me now) @@ -1779,6 +2289,10 @@ sub _resolve_condition { $is_objlike[$_] = 0; $res_args[$_] = '__gremlins__'; } + # more compat + elsif( $_ == 0 and $res_args[0]->isa( $__expected_result_class_isa ) ) { + $res_args[0] = { $res_args[0]->get_columns }; + } } else { $res_args[$_] ||= {}; @@ -1802,21 +2316,21 @@ sub _resolve_condition { }; # Allowing passing relconds different than the relationshup itself is cute, - # but likely dangerous. Remove that from the (still unofficial) API of - # _resolve_relationship_condition, and instead make it "hard on purpose" + # but likely dangerous. Remove that from the API of resolve_relationship_condition, + # and instead make it "hard on purpose" local $self->relationship_info( $args->{rel_name} )->{cond} = $cond if defined $cond; ####################### # now it's fucking easy isn't it?! - my $rc = $self->_resolve_relationship_condition( $args ); + my $rc = $self->resolve_relationship_condition( $args ); my @res = ( ( $rc->{join_free_condition} || $rc->{condition} ), ! $rc->{join_free_condition}, ); - # _resolve_relationship_condition always returns qualified cols even in the + # resolve_relationship_condition always returns qualified cols even in the # case of join_free_condition, but nothing downstream expects this if ($rc->{join_free_condition} and ref $res[0] eq 'HASH') { $res[0] = { map @@ -1838,34 +2352,73 @@ our $UNRESOLVABLE_CONDITION = UNRESOLVABLE_CONDITION; # we are moving to a constant Internals::SvREADONLY($UNRESOLVABLE_CONDITION => 1); -# Resolves the passed condition to a concrete query fragment and extra -# metadata -# -## self-explanatory API, modeled on the custom cond coderef: -# rel_name => (scalar) -# foreign_alias => (scalar) -# foreign_values => (either not supplied, or a hashref, or a foreign ResultObject (to be ->get_columns()ed), or plain undef ) -# self_alias => (scalar) -# self_result_object => (either not supplied or a result object) -# require_join_free_condition => (boolean, throws on failure to construct a JF-cond) -# infer_values_based_on => (either not supplied or a hashref, implies require_join_free_condition) -# -## returns a hash -# condition => (a valid *likely fully qualified* sqla cond structure) -# identity_map => (a hashref of foreign-to-self *unqualified* column equality names) -# join_free_condition => (a valid *fully qualified* sqla cond structure, maybe unset) -# inferred_values => (in case of an available join_free condition, this is a hashref of -# *unqualified* column/value *EQUALITY* pairs, representing an amalgamation -# of the JF-cond parse and infer_values_based_on -# always either complete or unset) -# -sub _resolve_relationship_condition { +=head2 resolve_relationship_condition + +NOTE: You generally B need to use this functionality... until you +do. The API description is terse on purpose. If the text below doesn't make +sense right away (based on the context which prompted you to look here) it is +almost certain you are reaching for the wrong tool. Please consider asking for +advice in any of the support channels before proceeding. + +=over 4 + +=item Arguments: C<\%args> as shown below (C> denotes mandatory args): + + * rel_name => $string + + * foreign_alias => $string + + * self_alias => $string + + foreign_values => \%column_value_pairs + + self_result_object => $ResultObject + + require_join_free_condition => $bool ( results in exception on failure to construct a JF-cond ) + + require_join_free_values => $bool ( results in exception on failure to return an equality-only JF-cond ) + +=item Return Value: C<\%resolution_result> as shown below (C> denotes always-resent parts of the result): + + * condition => $sqla_condition ( always present, valid, *likely* fully qualified, SQL::Abstract-compatible structure ) + + identity_map => \%foreign_to_self_equailty_map ( list of declared-equal foreign/self *unqualified* column names ) + + identity_map_matches_condition => $bool ( indicates whether the entire condition is expressed within the identity_map ) + + join_free_condition => \%sqla_condition_fully_resolvable_via_foreign_table + ( always a hash, all keys guaranteed to be valid *fully qualified* columns ) + + join_free_values => \%unqalified_version_of_join_free_condition + ( IFF the returned join_free_condition contains only exact values (no expressions), this would be + a hashref identical to join_free_condition, except with all column names *unqualified* ) + +=back + +This is the low-level method used to convert a declared relationship into +various parameters consumed by higher level functions. It is provided as a +stable official API, as the logic it encapsulates grew incredibly complex with +time. While calling this method directly B, you +absolutely B in codepaths containing the moral equivalent +of: + + ... + if( ref $some_rsrc->relationship_info($somerel)->{cond} eq 'HASH' ) { + ... + } + ... + +=cut + +# TODO - expand the documentation above, too terse + +sub resolve_relationship_condition { my $self = shift; my $args = { ref $_[0] eq 'HASH' ? %{ $_[0] } : @_ }; for ( qw( rel_name self_alias foreign_alias ) ) { - $self->throw_exception("Mandatory argument '$_' to _resolve_relationship_condition() is not a plain string") + $self->throw_exception("Mandatory argument '$_' to resolve_relationship_condition() is not a plain string") if !defined $args->{$_} or length ref $args->{$_}; } @@ -1873,7 +2426,7 @@ sub _resolve_relationship_condition { if $args->{self_alias} eq $args->{foreign_alias}; # TEMP - my $exception_rel_id = "relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}'"; + my $exception_rel_id = "relationship '$args->{rel_name}' on source '@{[ $self->source_name || $self->result_class ]}'"; my $rel_info = $self->relationship_info($args->{rel_name}) # TEMP @@ -1887,83 +2440,94 @@ sub _resolve_relationship_condition { $self->throw_exception("No practical way to resolve $exception_rel_id between two data structures") if exists $args->{self_result_object} and exists $args->{foreign_values}; - $self->throw_exception( "Argument to infer_values_based_on must be a hash" ) - if exists $args->{infer_values_based_on} and ref $args->{infer_values_based_on} ne 'HASH'; - - $args->{require_join_free_condition} ||= !!$args->{infer_values_based_on}; + $args->{require_join_free_condition} ||= !!$args->{require_join_free_values}; - $self->throw_exception( "Argument 'self_result_object' must be an object inheriting from DBIx::Class::Row" ) + $self->throw_exception( "Argument 'self_result_object' must be an object inheriting from '$__expected_result_class_isa'" ) if ( exists $args->{self_result_object} and - ( ! defined blessed $args->{self_result_object} or ! $args->{self_result_object}->isa('DBIx::Class::Row') ) + ( + ! defined blessed $args->{self_result_object} + or + ! $args->{self_result_object}->isa( $__expected_result_class_isa ) + ) ) ; my $rel_rsrc = $self->related_source($args->{rel_name}); - my $storage = $self->schema->storage; - - if (exists $args->{foreign_values}) { - - if (! defined $args->{foreign_values} ) { - # fallback: undef => {} - $args->{foreign_values} = {}; - } - elsif (defined blessed $args->{foreign_values}) { - - $self->throw_exception( "Objects supplied as 'foreign_values' ($args->{foreign_values}) must inherit from DBIx::Class::Row" ) - unless $args->{foreign_values}->isa('DBIx::Class::Row'); - carp_unique( - "Objects supplied as 'foreign_values' ($args->{foreign_values}) " - . "usually should inherit from the related ResultClass ('@{[ $rel_rsrc->result_class ]}'), " - . "perhaps you've made a mistake invoking the condition resolver?" - ) unless $args->{foreign_values}->isa($rel_rsrc->result_class); - - $args->{foreign_values} = { $args->{foreign_values}->get_columns }; - } - elsif ( ref $args->{foreign_values} eq 'HASH' ) { - - # re-build {foreign_values} excluding identically named rels - if( keys %{$args->{foreign_values}} ) { + if ( + exists $args->{foreign_values} + and + ( + ref $args->{foreign_values} eq 'HASH' + or + $self->throw_exception( + "Argument 'foreign_values' must be a hash reference" + ) + ) + and + keys %{$args->{foreign_values}} + ) { - my ($col_idx, $rel_idx) = map - { { map { $_ => 1 } $rel_rsrc->$_ } } - qw( columns relationships ) - ; + my ($col_idx, $rel_idx) = map + { { map { $_ => 1 } $rel_rsrc->$_ } } + qw( columns relationships ) + ; - my $equivalencies = $storage->_extract_fixed_condition_columns( - $args->{foreign_values}, - 'consider nulls', - ); + my $equivalencies; - $args->{foreign_values} = { map { - # skip if relationship *and* a non-literal ref - # this means a multicreate stub was passed in + # re-build {foreign_values} excluding refs as follows + # ( hot codepath: intentionally convoluted ) + # + $args->{foreign_values} = { map { + ( + $_ !~ /^-/ + or + $self->throw_exception( + "The key '$_' supplied as part of 'foreign_values' during " + . 'relationship resolution must be a column name, not a function' + ) + ) + and + ( + # skip if relationship ( means a multicreate stub was passed in ) + # skip if literal ( can't infer anything about it ) + # or plain throw if nonequiv yet not literal + ( + length ref $args->{foreign_values}{$_} + and ( $rel_idx->{$_} - and - length ref $args->{foreign_values}{$_} - and - ! is_literal_value($args->{foreign_values}{$_}) + or + is_literal_value($args->{foreign_values}{$_}) + or + ( + ( + ! exists( + ( $equivalencies ||= extract_equality_conditions( $args->{foreign_values}, 'consider nulls' ) ) + ->{$_} + ) + or + ($equivalencies->{$_}||'') eq UNRESOLVABLE_CONDITION + ) + and + $self->throw_exception( + "Resolution of relationship '$args->{rel_name}' failed: " + . "supplied value for foreign column '$_' is not a direct " + . 'equivalence expression' + ) + ) ) - ? () - : ( $_ => ( - ! $col_idx->{$_} - ? $self->throw_exception( "Key '$_' supplied as 'foreign_values' is not a column on related source '@{[ $rel_rsrc->source_name ]}'" ) - : ( !exists $equivalencies->{$_} or ($equivalencies->{$_}||'') eq UNRESOLVABLE_CONDITION ) - ? $self->throw_exception( "Value supplied for '...{foreign_values}{$_}' is not a direct equivalence expression" ) - : $args->{foreign_values}{$_} - )) - } keys %{$args->{foreign_values}} }; - } - } - else { - $self->throw_exception( - "Argument 'foreign_values' must be either an object inheriting from '@{[ $rel_rsrc->result_class ]}', " - . "or a hash reference, or undef" - ); - } + ) ? () + : $col_idx->{$_} ? ( $_ => $args->{foreign_values}{$_} ) + : $self->throw_exception( + "The key '$_' supplied as part of 'foreign_values' during " + . 'relationship resolution is not a column on related source ' + . "'@{[ $rel_rsrc->source_name ]}'" + ) + ) + } keys %{$args->{foreign_values}} }; } my $ret; @@ -1993,11 +2557,11 @@ sub _resolve_relationship_condition { $self->throw_exception("A custom condition coderef can return at most 2 conditions, but $exception_rel_id returned extra values: @extra") if @extra; - if (my $jfc = $ret->{join_free_condition}) { + if( $ret->{join_free_condition} ) { $self->throw_exception ( "The join-free condition returned for $exception_rel_id must be a hash reference" - ) unless ref $jfc eq 'HASH'; + ) unless ref $ret->{join_free_condition} eq 'HASH'; my ($joinfree_alias, $joinfree_source); if (defined $args->{self_result_object}) { @@ -2023,21 +2587,19 @@ sub _resolve_relationship_condition { "The join-free condition returned for $exception_rel_id may only " . 'contain keys that are fully qualified column names of the corresponding source ' . "'$joinfree_alias' (instead it returned '$_')" - ) for keys %$jfc; + ) for keys %{$ret->{join_free_condition}}; ( - length ref $_ - and defined blessed($_) and - $_->isa('DBIx::Class::Row') + $_->isa( $__expected_result_class_isa ) and $self->throw_exception ( "The join-free condition returned for $exception_rel_id may not " . 'contain result objects as values - perhaps instead of invoking ' . '->$something you meant to return ->get_column($something)' ) - ) for values %$jfc; + ) for values %{$ret->{join_free_condition}}; } } @@ -2064,61 +2626,76 @@ sub _resolve_relationship_condition { # construct the crosstable condition and the identity map for (0..$#f_cols) { $ret->{condition}{"$args->{foreign_alias}.$f_cols[$_]"} = { -ident => "$args->{self_alias}.$l_cols[$_]" }; - $ret->{identity_map}{$l_cols[$_]} = $f_cols[$_]; + + # explicit value stringification is deliberate - leave no room for + # interpretation when comparing sets of keys + $ret->{identity_map}{$l_cols[$_]} = "$f_cols[$_]"; }; if ($args->{foreign_values}) { - $ret->{join_free_condition}{"$args->{self_alias}.$l_cols[$_]"} = $args->{foreign_values}{$f_cols[$_]} + $ret->{join_free_condition}{"$args->{self_alias}.$l_cols[$_]"} + = $ret->{join_free_values}{$l_cols[$_]} + = $args->{foreign_values}{$f_cols[$_]} for 0..$#f_cols; } elsif (defined $args->{self_result_object}) { - for my $i (0..$#l_cols) { - if ( $args->{self_result_object}->has_column_loaded($l_cols[$i]) ) { - $ret->{join_free_condition}{"$args->{foreign_alias}.$f_cols[$i]"} = $args->{self_result_object}->get_column($l_cols[$i]); - } - else { - $self->throw_exception(sprintf - "Unable to resolve relationship '%s' from object '%s': column '%s' not " - . 'loaded from storage (or not passed to new() prior to insert()). You ' - . 'probably need to call ->discard_changes to get the server-side defaults ' - . 'from the database.', - $args->{rel_name}, - $args->{self_result_object}, - $l_cols[$i], - ) if $args->{self_result_object}->in_storage; - - # FIXME - temporarly force-override - delete $args->{require_join_free_condition}; - $ret->{join_free_condition} = UNRESOLVABLE_CONDITION; - last; - } - } + # FIXME - compat block due to inconsistency of get_columns() vs has_column_loaded() + # The former returns cached-in related single rels, while the latter is doing what + # it says on the tin. Thus the more logical "get all columns and barf if something + # is missing" is a non-starter, and we move through each column one by one :/ + + $args->{self_result_object}->has_column_loaded( $l_cols[$_] ) + + ? $ret->{join_free_condition}{"$args->{foreign_alias}.$f_cols[$_]"} + = $ret->{join_free_values}{$f_cols[$_]} + = $args->{self_result_object}->get_column( $l_cols[$_] ) + + : $args->{self_result_object}->in_storage + + ? $self->throw_exception(sprintf + "Unable to resolve relationship '%s' from object '%s': column '%s' not " + . 'loaded from storage (or not passed to new() prior to insert()). You ' + . 'probably need to call ->discard_changes to get the server-side defaults ' + . 'from the database', + $args->{rel_name}, + $args->{self_result_object}, + $l_cols[$_], + ) + + # non-resolvable yet not in storage - give it a pass + # FIXME - while this is what the code has done for ages, it doesn't seem right :( + : ( + delete $ret->{join_free_condition}, + delete $ret->{join_free_values}, + last + ) + + for 0 .. $#l_cols; } } elsif (ref $rel_info->{cond} eq 'ARRAY') { if (@{ $rel_info->{cond} } == 0) { $ret = { condition => UNRESOLVABLE_CONDITION, - join_free_condition => UNRESOLVABLE_CONDITION, }; } else { my @subconds = map { local $rel_info->{cond} = $_; - $self->_resolve_relationship_condition( $args ); + $self->resolve_relationship_condition( $args ); } @{ $rel_info->{cond} }; if( @{ $rel_info->{cond} } == 1 ) { $ret = $subconds[0]; } else { - # we are discarding inferred values here... likely incorrect... - # then again - the entire thing is an OR, so we *can't* use them anyway for my $subcond ( @subconds ) { $self->throw_exception('Either all or none of the OR-condition members must resolve to a join-free condition') if ( $ret and ( $ret->{join_free_condition} xor $subcond->{join_free_condition} ) ); + # we are discarding join_free_values from individual 'OR' branches here + # see @nonvalues checks below $subcond->{$_} and push @{$ret->{$_}}, $subcond->{$_} for (qw(condition join_free_condition)); } } @@ -2128,10 +2705,23 @@ sub _resolve_relationship_condition { $self->throw_exception ("Can't handle condition $rel_info->{cond} for $exception_rel_id yet :("); } + + # Explicit normalization pass + # ( nobody really knows what a CODE can return ) + # Explicitly leave U_C alone - it would be normalized + # to an { -and => [ U_C ] } + defined $ret->{$_} + and + $ret->{$_} ne UNRESOLVABLE_CONDITION + and + $ret->{$_} = normalize_sqla_condition($ret->{$_}) + for qw(condition join_free_condition); + + if ( $args->{require_join_free_condition} and - ( ! $ret->{join_free_condition} or $ret->{join_free_condition} eq UNRESOLVABLE_CONDITION ) + ! defined $ret->{join_free_condition} ) { $self->throw_exception( ucfirst sprintf "$exception_rel_id does not resolve to a %sjoin-free condition fragment", @@ -2141,84 +2731,133 @@ sub _resolve_relationship_condition { ); } - # we got something back - sanity check and infer values if we can + # we got something back (not from a static cond) - sanity check and infer values if we can + # ( in case of a static cond join_free_values is already pre-populated for us ) my @nonvalues; - if ( + if( $ret->{join_free_condition} and - $ret->{join_free_condition} ne UNRESOLVABLE_CONDITION - and - my $jfc = $storage->_collapse_cond( $ret->{join_free_condition} ) + ! $ret->{join_free_values} ) { - my $jfc_eqs = $storage->_extract_fixed_condition_columns($jfc, 'consider_nulls'); - - if (keys %$jfc_eqs) { + my $jfc_eqs = extract_equality_conditions( + $ret->{join_free_condition}, + 'consider_nulls' + ); - for (keys %$jfc) { - # $jfc is fully qualified by definition - my ($col) = $_ =~ /\.(.+)/; + for( keys %{ $ret->{join_free_condition} } ) { + if( $_ =~ /^-/ ) { + push @nonvalues, { $_ => $ret->{join_free_condition}{$_} }; + } + else { + # a join_free_condition is fully qualified by definition + my ($col) = $_ =~ /\.(.+)/ or carp_unique( + 'Internal error - extract_equality_conditions() returned a ' + . "non-fully-qualified key '$_'. *Please* file a bugreport " + . "including your definition of $exception_rel_id" + ); if (exists $jfc_eqs->{$_} and ($jfc_eqs->{$_}||'') ne UNRESOLVABLE_CONDITION) { - $ret->{inferred_values}{$col} = $jfc_eqs->{$_}; + $ret->{join_free_values}{$col} = $jfc_eqs->{$_}; } - elsif ( !$args->{infer_values_based_on} or ! exists $args->{infer_values_based_on}{$col} ) { - push @nonvalues, $col; + else { + push @nonvalues, { $_ => $ret->{join_free_condition}{$_} }; } } - - # all or nothing - delete $ret->{inferred_values} if @nonvalues; } - } - # did the user explicitly ask - if ($args->{infer_values_based_on}) { + # all or nothing + delete $ret->{join_free_values} if @nonvalues; + } - $self->throw_exception(sprintf ( - "Unable to complete value inferrence - custom $exception_rel_id returns conditions instead of values for column(s): %s", - map { "'$_'" } @nonvalues - )) if @nonvalues; + # throw only if the user explicitly asked + $args->{require_join_free_values} + and + @nonvalues + and + $self->throw_exception( + "Unable to complete value inferrence - $exception_rel_id results in expression(s) instead of definitive values: " + . do { + # FIXME - used for diag only, but still icky + my $sqlm = + dbic_internal_try { $self->schema->storage->sql_maker } + || + ( + require DBIx::Class::SQLMaker + and + DBIx::Class::SQLMaker->new + ) + ; + local $sqlm->{quote_char}; + local $sqlm->{_dequalify_idents} = 1; + ($sqlm->_recurse_where({ -and => \@nonvalues }))[0] + } + ); - $ret->{inferred_values} ||= {}; - $ret->{inferred_values}{$_} = $args->{infer_values_based_on}{$_} - for keys %{$args->{infer_values_based_on}}; - } + my $identity_map_incomplete; # add the identities based on the main condition # (may already be there, since easy to calculate on the fly in the HASH case) if ( ! $ret->{identity_map} ) { - my $col_eqs = $storage->_extract_fixed_condition_columns($ret->{condition}); + my $col_eqs = extract_equality_conditions($ret->{condition}); + + $identity_map_incomplete++ if ( + $ret->{condition} eq UNRESOLVABLE_CONDITION + or + ( + keys %{$ret->{condition}} + != + keys %$col_eqs + ) + ); my $colinfos; for my $lhs (keys %$col_eqs) { + # start with the assumption it won't work + $identity_map_incomplete++; + next if $col_eqs->{$lhs} eq UNRESOLVABLE_CONDITION; # there is no way to know who is right and who is left in a cref # therefore a full blown resolution call, and figure out the # direction a bit further below - $colinfos ||= $storage->_resolve_column_info([ + $colinfos ||= fromspec_columns_info([ { -alias => $args->{self_alias}, -rsrc => $self }, { -alias => $args->{foreign_alias}, -rsrc => $rel_rsrc }, ]); next unless $colinfos->{$lhs}; # someone is engaging in witchcraft - if ( my $rhs_ref = is_literal_value( $col_eqs->{$lhs} ) ) { - + if( my $rhs_ref = + ( + ref $col_eqs->{$lhs} eq 'HASH' + and + keys %{$col_eqs->{$lhs}} == 1 + and + exists $col_eqs->{$lhs}{-ident} + ) + ? [ $col_eqs->{$lhs}{-ident} ] # repack to match the RV of is_literal_value + : is_literal_value( $col_eqs->{$lhs} ) + ) { if ( $colinfos->{$rhs_ref->[0]} and $colinfos->{$lhs}{-source_alias} ne $colinfos->{$rhs_ref->[0]}{-source_alias} ) { ( $colinfos->{$lhs}{-source_alias} eq $args->{self_alias} ) - ? ( $ret->{identity_map}{$colinfos->{$lhs}{-colname}} = $colinfos->{$rhs_ref->[0]}{-colname} ) - : ( $ret->{identity_map}{$colinfos->{$rhs_ref->[0]}{-colname}} = $colinfos->{$lhs}{-colname} ) + + # explicit value stringification is deliberate - leave no room for + # interpretation when comparing sets of keys + ? ( $ret->{identity_map}{$colinfos->{$lhs}{-colname}} = "$colinfos->{$rhs_ref->[0]}{-colname}" ) + : ( $ret->{identity_map}{$colinfos->{$rhs_ref->[0]}{-colname}} = "$colinfos->{$lhs}{-colname}" ) ; + + # well, what do you know! + $identity_map_incomplete--; } } elsif ( @@ -2238,9 +2877,101 @@ sub _resolve_relationship_condition { } } + $ret->{identity_map_matches_condition} = ($identity_map_incomplete ? 0 : 1) + if $ret->{identity_map}; + + + # cleanup before final return, easier to eyeball + ! defined $ret->{$_} and delete $ret->{$_} + for keys %$ret; + + # FIXME - temporary, to fool the idiotic check in SQLMaker::_join_condition - $ret->{condition} = { -and => [ $ret->{condition} ] } - unless $ret->{condition} eq UNRESOLVABLE_CONDITION; + $ret->{condition} = { -and => [ $ret->{condition} ] } unless ( + $ret->{condition} eq UNRESOLVABLE_CONDITION + or + ( + ref $ret->{condition} eq 'HASH' + and + grep { $_ =~ /^-/ } keys %{$ret->{condition}} + ) + ); + + + if( DBIx::Class::_ENV_::ASSERT_NO_INCONSISTENT_RELATIONSHIP_RESOLUTION ) { + + my $sqlm = + dbic_internal_try { $self->schema->storage->sql_maker } + || + ( + require DBIx::Class::SQLMaker + and + DBIx::Class::SQLMaker->new + ) + ; + + local $sqlm->{_dequalify_idents} = 1; + + my ( $cond_as_sql, $jf_cond_as_sql, $jf_vals_as_sql, $identmap_as_sql ) = map + { join ' : ', map { + ref $_ eq 'ARRAY' ? $_->[1] + : defined $_ ? $_ + : '{UNDEF}' + } $sqlm->_recurse_where($_) } + ( + ( map { $ret->{$_} } qw( condition join_free_condition join_free_values ) ), + + { map { + # inverse because of how the idmap is declared + $ret->{identity_map}{$_} => { -ident => $_ } + } keys %{$ret->{identity_map}} }, + ) + ; + + + emit_loud_diag( + confess => 1, + msg => sprintf ( + "Resolution of %s produced inconsistent metadata:\n\n" + . "returned value of 'identity_map_matches_condition': %s\n" + . "returned 'condition' rendered as de-qualified SQL: %s\n" + . "returned 'identity_map' rendered as de-qualified SQL: %s\n\n" + . "The condition declared on the misclassified relationship is: %s ", + $exception_rel_id, + ( $ret->{identity_map_matches_condition} || 0 ), + $cond_as_sql, + $identmap_as_sql, + dump_value( $rel_info->{cond} ), + ), + ) if ( + $ret->{identity_map_matches_condition} + xor + ( $cond_as_sql eq $identmap_as_sql ) + ); + + + emit_loud_diag( + confess => 1, + msg => sprintf ( + "Resolution of %s produced inconsistent metadata:\n\n" + . "returned 'join_free_condition' rendered as de-qualified SQL: %s\n" + . "returned 'join_free_values' rendered as de-qualified SQL: %s\n\n" + . "The condition declared on the misclassified relationship is: %s ", + $exception_rel_id, + $jf_cond_as_sql, + $jf_vals_as_sql, + dump_value( $rel_info->{cond} ), + ), + ) if ( + exists $ret->{join_free_condition} + and + ( + exists $ret->{join_free_values} + xor + ( $jf_cond_as_sql eq $jf_vals_as_sql ) + ) + ); + } $ret; } @@ -2274,7 +3005,7 @@ sub related_source { else { my $class = $self->relationship_info($rel)->{class}; $self->ensure_class_loaded($class); - $class->result_source_instance; + $class->result_source; } } @@ -2318,6 +3049,7 @@ relationship definitions. =cut sub handle { + require DBIx::Class::ResultSourceHandle; return DBIx::Class::ResultSourceHandle->new({ source_moniker => $_[0]->source_name, @@ -2358,17 +3090,23 @@ 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 :((( - local $@; + local $SIG{__DIE__} if $SIG{__DIE__}; + local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT; eval { weaken $_[0]->{schema}; # if schema is still there reintroduce ourselves with strong refs back to us if ($_[0]->{schema}) { my $srcregs = $_[0]->{schema}->source_registrations; - for (keys %$srcregs) { - next unless $srcregs->{$_}; - $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0]; - } + + defined $srcregs->{$_} + and + $srcregs->{$_} == $_[0] + and + $srcregs->{$_} = $_[0] + and + last + for keys %$srcregs; } 1; diff --git a/lib/DBIx/Class/ResultSource/FromSpec/Util.pm b/lib/DBIx/Class/ResultSource/FromSpec/Util.pm new file mode 100644 index 000000000..47106d7ec --- /dev/null +++ b/lib/DBIx/Class/ResultSource/FromSpec/Util.pm @@ -0,0 +1,140 @@ +package #hide from PAUSE + DBIx::Class::ResultSource::FromSpec::Util; + +use strict; +use warnings; + +use base 'Exporter'; +our @EXPORT_OK = qw( + fromspec_columns_info + find_join_path_to_alias +); + +use Scalar::Util 'blessed'; + +# Takes $fromspec, \@column_names +# +# returns { $column_name => \%column_info, ... } for fully qualified and +# where possible also unqualified variants +# also note: this adds -result_source => $rsrc to the column info +# +# If no columns_names are supplied returns info about *all* columns +# for all sources +sub fromspec_columns_info { + my ($fromspec, $colnames) = @_; + + return {} if $colnames and ! @$colnames; + + my $sources = ( + # this is compat mode for insert/update/delete which do not deal with aliases + ( + blessed($fromspec) + and + $fromspec->isa('DBIx::Class::ResultSource') + ) ? +{ me => $fromspec } + + # not a known fromspec - no columns to resolve: return directly + : ref($fromspec) ne 'ARRAY' ? return +{} + + : +{ + # otherwise decompose into alias/rsrc pairs + map + { + ( $_->{-rsrc} and $_->{-alias} ) + ? ( @{$_}{qw( -alias -rsrc )} ) + : () + } + map + { + ( ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH' ) ? $_->[0] + : ( ref $_ eq 'HASH' ) ? $_ + : () + } + @$fromspec + } + ); + + $_ = { rsrc => $_, colinfos => $_->columns_info } + for values %$sources; + + my (%seen_cols, @auto_colnames); + + # compile a global list of column names, to be able to properly + # disambiguate unqualified column names (if at all possible) + for my $alias (keys %$sources) { + ( + ++$seen_cols{$_}{$alias} + and + ! $colnames + and + push @auto_colnames, "$alias.$_" + ) for keys %{ $sources->{$alias}{colinfos} }; + } + + $colnames ||= [ + @auto_colnames, + ( grep { keys %{$seen_cols{$_}} == 1 } keys %seen_cols ), + ]; + + my %return; + for (@$colnames) { + my ($colname, $source_alias) = reverse split /\./, $_; + + my $assumed_alias = + $source_alias + || + # if the column was seen exactly once - we know which rsrc it came from + ( + $seen_cols{$colname} + and + keys %{$seen_cols{$colname}} == 1 + and + ( %{$seen_cols{$colname}} )[0] + ) + || + next + ; + + DBIx::Class::Exception->throw( + "No such column '$colname' on source " . $sources->{$assumed_alias}{rsrc}->source_name + ) unless $seen_cols{$colname}{$assumed_alias}; + + $return{$_} = { + %{ $sources->{$assumed_alias}{colinfos}{$colname} }, + -result_source => $sources->{$assumed_alias}{rsrc}, + -source_alias => $assumed_alias, + -fq_colname => "$assumed_alias.$colname", + -colname => $colname, + }; + + $return{"$assumed_alias.$colname"} = $return{$_} + unless $source_alias; + } + + \%return; +} + +sub find_join_path_to_alias { + my ($fromspec, $target_alias) = @_; + + # subqueries and other oddness are naturally not supported + return undef if ( + ref $fromspec ne 'ARRAY' + || + ref $fromspec->[0] ne 'HASH' + || + ! defined $fromspec->[0]{-alias} + ); + + # no path - the head *is* the alias + return [] if $fromspec->[0]{-alias} eq $target_alias; + + for my $i (1 .. $#$fromspec) { + return $fromspec->[$i][0]{-join_path} if ( ($fromspec->[$i][0]{-alias}||'') eq $target_alias ); + } + + # something else went quite wrong + return undef; +} + +1; diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index 83be406fc..df3627acd 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -6,16 +6,19 @@ use warnings; use base 'DBIx::Class'; -use Try::Tiny; -use List::Util qw(first max); - use DBIx::Class::ResultSource::RowParser::Util qw( assemble_simple_parser assemble_collapsing_parser ); +use DBIx::Class::_Util qw( DUMMY_ALIASPAIR dbic_internal_try dbic_internal_catch ); use DBIx::Class::Carp; +# FIXME - this should go away +# instead Carp::Skip should export usable keywords or something like that +my $unique_carper; +BEGIN { $unique_carper = \&carp_unique } + use namespace::clean; # Accepts a prefetch map (one or more relationships for the current source), @@ -122,8 +125,6 @@ sub _mk_row_parser { }, ); - my $check_null_columns; - my $src = (! $args->{collapse} ) ? assemble_simple_parser(\%common) : do { my $collapse_map = $self->_resolve_collapse ({ # FIXME @@ -141,9 +142,6 @@ sub _mk_row_parser { premultiplied => $args->{premultiplied}, }); - $check_null_columns = $collapse_map->{-identifying_columns} - if @{$collapse_map->{-identifying_columns}}; - assemble_collapsing_parser({ %common, collapse_map => $collapse_map, @@ -153,10 +151,7 @@ sub _mk_row_parser { utf8::upgrade($src) if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE; - return ( - $args->{eval} ? ( eval "sub $src" || die $@ ) : $src, - $check_null_columns, - ); + $src; } @@ -178,13 +173,13 @@ sub _resolve_collapse { $args->{_is_top_level} = 1; }; - my ($my_cols, $rel_cols); + my ($my_cols, $rel_cols, $native_cols); for (keys %{$args->{as}}) { if ($_ =~ /^ ([^\.]+) \. (.+) /x) { $rel_cols->{$1}{$2} = 1; } else { - $my_cols->{$_} = {}; # important for ||='s below + $native_cols->{$_} = $my_cols->{$_} = {}; # important for ||='s below } } @@ -197,11 +192,28 @@ sub _resolve_collapse { is_single => ( $inf->{attrs}{accessor} && $inf->{attrs}{accessor} ne 'multi' ), is_inner => ( ( $inf->{attrs}{join_type} || '' ) !~ /^left/i), rsrc => $self->related_source($rel), - fk_map => $self->_resolve_relationship_condition( - rel_name => $rel, - self_alias => "\xFE", # irrelevant - foreign_alias => "\xFF", # irrelevant - )->{identity_map}, + fk_map => ( + dbic_internal_try { + $self->resolve_relationship_condition( + rel_name => $rel, + + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, + )->{identity_map}, + } + dbic_internal_catch { + + $unique_carper->( + "Resolution of relationship '$rel' failed unexpectedly, " + . 'please relay the following error and seek assistance via ' + . DBIx::Class::_ENV_::HELP_URL . ". Encountered error: $_" + ); + + # RV + +{} + } + ), }; } @@ -225,7 +237,7 @@ sub _resolve_collapse { if ( ! $args->{_parent_info}{underdefined} and ! $args->{_parent_info}{rev_rel_is_optional} ) { for my $col ( values %{$args->{_parent_info}{rel_condition} || {}} ) { next if exists $my_cols->{$col}; - $my_cols->{$col} = { via_collapse => $args->{_parent_info}{collapse_on_idcols} }; + $my_cols->{$col} = {}; $assumed_from_parent->{columns}{$col}++; } } @@ -240,9 +252,50 @@ sub _resolve_collapse { # first try to reuse the parent's collapser (i.e. reuse collapser over 1:1) # (makes for a leaner coderef later) - unless ($collapse_map->{-identifying_columns}) { + if( + ! $collapse_map->{-identifying_columns} + and + $args->{_parent_info}{collapser_reusable} + ) { $collapse_map->{-identifying_columns} = $args->{_parent_info}{collapse_on_idcols} - if $args->{_parent_info}{collapser_reusable}; + } + + # Still don't know how to collapse - in case we are a *single* relationship + # AND our parent is defined AND we have any *native* non-nullable pieces: then + # we are still good to go + # NOTE: it doesn't matter if the nonnullable set is unique or not - it will be + # made unique by the parents identifying cols + if( + ! $collapse_map->{-identifying_columns} + and + $args->{_parent_info}{is_single} + and + @{ $args->{_parent_info}{collapse_on_idcols} } + and + ( my @native_nonnull_cols = grep { + $native_cols->{$_}{colinfo} + and + ! $native_cols->{$_}{colinfo}{is_nullable} + } keys %$native_cols ) + ) { + + $collapse_map->{-identifying_columns} = [ __unique_numlist( + @{ $args->{_parent_info}{collapse_on_idcols}||[] }, + + # FIXME - we don't really need *all* of the columns, $our_nonnull_cols[0] + # is sufficient. However map the entire thing to engage the extra nonnull + # explicit checks, just to be on the safe side + # Remove some day in the future + (map + { + $common_args->{_as_fq_idx}{join ('.', + @{$args->{_rel_chain}}[1 .. $#{$args->{_rel_chain}}], + $_, + )} + } + @native_nonnull_cols + ), + )]; } # Still don't know how to collapse - try to resolve based on our columns (plus already inserted FK bridges) @@ -371,7 +424,14 @@ sub _resolve_collapse { # coderef later $collapse_map->{-identifying_columns} = []; $collapse_map->{-identifying_columns_variants} = [ sort { - (scalar @$a) <=> (scalar @$b) or max(@$a) <=> max(@$b) + (scalar @$a) <=> (scalar @$b) + or + ( + # Poor man's max() + ( sort { $b <=> $a } @$a )[0] + <=> + ( sort { $b <=> $a } @$b )[0] + ) } @collapse_sets ]; } } @@ -402,7 +462,6 @@ sub _resolve_collapse { @{ $collapse_map->{-identifying_columns} }, )]; - my @id_sets; for my $rel (sort keys %$relinfo) { $collapse_map->{$rel} = $relinfo->{$rel}{rsrc}->_resolve_collapse ({ @@ -416,12 +475,17 @@ sub _resolve_collapse { is_optional => ! $relinfo->{$rel}{is_inner}, - # if there is at least one *inner* reverse relationship which is HASH-based (equality only) + is_single => $relinfo->{$rel}{is_single}, + + # if there is at least one *inner* reverse relationship ( meaning identity-only ) # we can safely assume that the child can not exist without us - rev_rel_is_optional => ( first - { ref $_->{cond} eq 'HASH' and ($_->{attrs}{join_type}||'') !~ /^left/i } - values %{ $self->reverse_relationship_info($rel) }, - ) ? 0 : 1, + rev_rel_is_optional => ( + ( grep { + ($_->{attrs}{join_type}||'') !~ /^left/i + } values %{ $self->reverse_relationship_info($rel) } ) + ? 0 + : 1 + ), # if this is a 1:1 our own collapser can be used as a collapse-map # (regardless of left or not) diff --git a/lib/DBIx/Class/ResultSource/RowParser/Util.pm b/lib/DBIx/Class/ResultSource/RowParser/Util.pm index a20d07cb9..a64df955d 100644 --- a/lib/DBIx/Class/ResultSource/RowParser/Util.pm +++ b/lib/DBIx/Class/ResultSource/RowParser/Util.pm @@ -4,10 +4,9 @@ package # hide from the pauses use strict; use warnings; -use List::Util 'first'; -use DBIx::Class::_Util 'perlstring'; +use DBIx::Class::_Util qw( perlstring dump_value ); -use constant HAS_DOR => ( "$]" < 5.010 ? 0 : 1 ); +use constant HAS_DOR => ( ( DBIx::Class::_ENV_::PERL_VERSION < 5.010 ) ? 0 : 1 ); use base 'Exporter'; our @EXPORT_OK = qw( @@ -19,7 +18,7 @@ our @EXPORT_OK = qw( our $null_branch_class = 'DBIx::ResultParser::RelatedNullBranch'; sub __wrap_in_strictured_scope { - " { use strict; use warnings; use warnings FATAL => 'uninitialized';\n$_[0]\n }" + "sub { use strict; use warnings; use warnings FATAL => 'uninitialized';\n$_[0]\n }" } sub assemble_simple_parser { @@ -120,13 +119,15 @@ sub assemble_collapsing_parser { { "{ \$cur_row_ids{$_} }" } @{$args->{collapse_map}{-identifying_columns}} ); + + $top_node_key_assembler = ''; } elsif( my @variants = @{$args->{collapse_map}{-identifying_columns_variants}} ) { my @path_parts = map { sprintf "( ( defined \$cur_row_data->[%d] ) && (join qq(\xFF), '', %s, '') )", $_->[0], # checking just first is enough - one ID defined, all defined - ( join ', ', map { ++$variant_idcols->{$_} and " \$cur_row_ids{$_} " } @$_ ), + ( join ', ', map { $variant_idcols->{$_} = 1; " \$cur_row_ids{$_} " } @$_ ), } @variants; my $virtual_column_idx = (scalar keys %{$args->{val_index}} ) + 1; @@ -144,7 +145,10 @@ sub assemble_collapsing_parser { }; } else { - die('Unexpected collapse map contents'); + DBIx::Class::Exception->throw( + 'Unexpected collapse map contents: ' . dump_value $args->{collapse_map}, + 1, + ) } my ($data_assemblers, $stats) = __visit_infmap_collapse ($args); @@ -161,15 +165,77 @@ sub assemble_collapsing_parser { ( $args->{prune_null_branches} ? sprintf( '@{$cur_row_data}[( %s )]', join ', ', @row_ids ) : join (",\n", map { - my $quoted_null_val = qq("\0NULL\xFF\${rows_pos}\xFF${_}\0"); - HAS_DOR - ? qq!( \$cur_row_data->[$_] // $quoted_null_val )! - : qq!( defined(\$cur_row_data->[$_]) ? \$cur_row_data->[$_] : $quoted_null_val )! + $stats->{nullchecks}{mandatory}{$_} + ? qq!( \$cur_row_data->[$_] )! + : do { + my $quoted_null_val = qq("\0NULL\xFF\${rows_pos}\xFF${_}\0"); + HAS_DOR + ? qq!( \$cur_row_data->[$_] // $quoted_null_val )! + : qq!( defined(\$cur_row_data->[$_]) ? \$cur_row_data->[$_] : $quoted_null_val )! + } } @row_ids) ) ; - my $parser_src = sprintf (<<'EOS', $row_id_defs, $top_node_key_assembler||'', $top_node_key, join( "\n", @{$data_assemblers||[]} ) ); + my $null_checks = ''; + + for my $c ( sort { $a <=> $b } keys %{$stats->{nullchecks}{mandatory}} ) { + $null_checks .= sprintf <<'EOS', $c +( defined( $cur_row_data->[%1$s] ) or $_[3]->{%1$s} = 1 ), + +EOS + } + + for my $set ( @{ $stats->{nullchecks}{from_first_encounter} || [] } ) { + my @sub_checks; + + for my $i (0 .. $#$set - 1) { + + push @sub_checks, sprintf + '( not defined $cur_row_data->[%1$s] ) ? ( %2$s or ( $_[3]->{%1$s} = 1 ) )', + $set->[$i], + join( ' and ', map + { "( not defined \$cur_row_data->[$set->[$_]] )" } + ( $i+1 .. $#$set ) + ), + ; + } + + $null_checks .= "(\n @{[ join qq(\n: ), @sub_checks, '()' ]} \n),\n"; + } + + for my $set ( @{ $stats->{nullchecks}{all_or_nothing} || [] } ) { + + $null_checks .= sprintf "(\n( %s )\n or\n(\n%s\n)\n),\n", + join ( ' and ', map + { "( not defined \$cur_row_data->[$_] )" } + sort { $a <=> $b } keys %$set + ), + join ( ",\n", map + { "( defined(\$cur_row_data->[$_]) or \$_[3]->{$_} = 1 )" } + sort { $a <=> $b } keys %$set + ), + ; + } + + # If any of the above generators produced something, we need to add the + # final "if seen any violations - croak" part + # Do not throw from within the string eval itself as it does not have + # the necessary metadata to construct a nice exception text. As a bonus + # we get to entirely avoid https://github.com/Test-More/Test2/issues/16 + # and https://rt.perl.org/Public/Bug/Display.html?id=127774 + + $null_checks .= <<'EOS' if $null_checks; + +( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last +) ), +EOS + + + my $parser_src = sprintf (<<'EOS', $null_checks, $row_id_defs, $top_node_key_assembler, $top_node_key, join( "\n", @$data_assemblers ) ); ### BEGIN LITERAL STRING EVAL my $rows_pos = 0; my ($result_pos, @collapse_idx, $cur_row_data, %%cur_row_ids ); @@ -202,26 +268,37 @@ sub assemble_collapsing_parser { ( $_[1] and $_[1]->() ) ) ) { - # the undef checks may or may not be there - # depending on whether we prune or not + # column_info metadata historically hasn't been too reliable. + # We need to start fixing this somehow (the collapse resolver + # can't work without it). Add explicit checks for several cases + # of "unexpected NULL", based on the metadata returned by + # __visit_infmap_collapse # + # FIXME - this is a temporary kludge that reduces performance + # It is however necessary for the time being, until way into the + # future when the extra errors clear out all invalid metadata +%s + # due to left joins some of the ids may be NULL/undef, and # won't play well when used as hash lookups # we also need to differentiate NULLs on per-row/per-col basis # (otherwise folding of optional 1:1s will be greatly confused -%1$s + # + # the undef checks may or may not be there depending on whether + # we prune or not +%s # in the case of an underdefined root - calculate the virtual id (otherwise no code at all) -%2$s +%s # if we were supplied a coderef - we are collapsing lazily (the set # is ordered properly) # as long as we have a result already and the next result is new we # return the pre-read data and bail -( $_[1] and $result_pos and ! $collapse_idx[0]%3$s and (unshift @{$_[2]}, $cur_row_data) and last ), +( $_[1] and $result_pos and ! $collapse_idx[0]%s and (unshift @{$_[2]}, $cur_row_data) and last ), # the rel assemblers -%4$s +%s } @@ -239,6 +316,27 @@ sub __visit_infmap_collapse { my $cur_node_idx = ${ $args->{-node_idx_counter} ||= \do { my $x = 0} }++; + $args->{-mandatory_ids} ||= {}; + $args->{-seen_ids} ||= {}; + $args->{-all_or_nothing_sets} ||= []; + $args->{-null_from} ||= []; + + $args->{-seen_ids}{$_} = 1 + for @{$args->{collapse_map}->{-identifying_columns}}; + + my $node_specific_ids = { map { $_ => 1 } grep + { ! $args->{-parent_ids}{$_} } + @{$args->{collapse_map}->{-identifying_columns}} + }; + + if (not ( $args->{-chain_is_optional} ||= $args->{collapse_map}{-is_optional} ) ) { + $args->{-mandatory_ids}{$_} = 1 + for @{$args->{collapse_map}->{-identifying_columns}}; + } + elsif ( keys %$node_specific_ids > 1 ) { + push @{$args->{-all_or_nothing_sets}}, $node_specific_ids; + } + my ($my_cols, $rel_cols) = {}; for ( keys %{$args->{val_index}} ) { if ($_ =~ /^ ([^\.]+) \. (.+) /x) { @@ -285,35 +383,37 @@ sub __visit_infmap_collapse { ); if ($args->{collapse_map}->{-is_single}) { - push @src, sprintf ( '( %s %s %s%s ),', + push @src, sprintf ( '( %s %s %s = %s ),', $parent_attach_slot, (HAS_DOR ? '//=' : '||='), $node_idx_slot, - $me_struct ? " = $me_struct" : '', + $me_struct || '{}', ); } else { - push @src, sprintf('( (! %s) and push @{%s}, %s%s ),', + push @src, sprintf('( (! %s) and push @{%s}, %s = %s ),', $node_idx_slot, $parent_attach_slot, $node_idx_slot, - $me_struct ? " = $me_struct" : '', + $me_struct || '{}', ); } } my $known_present_ids = { map { $_ => 1 } @{$args->{collapse_map}{-identifying_columns}} }; - my ($stats, $rel_src); + my $rel_src; for my $rel (sort keys %$rel_cols) { my $relinfo = $args->{collapse_map}{$rel}; - ($rel_src, $stats->{$rel}) = __visit_infmap_collapse({ %$args, + ($rel_src) = __visit_infmap_collapse({ %$args, val_index => $rel_cols->{$rel}, collapse_map => $relinfo, -parent_node_idx => $cur_node_idx, -parent_node_key => $node_key, + -parent_id_path => [ @{$args->{-parent_id_path}||[]}, sort { $a <=> $b } keys %$node_specific_ids ], + -parent_ids => { map { %$_ } $node_specific_ids, $args->{-parent_ids}||{} }, -node_rel_name => $rel, }); @@ -322,12 +422,17 @@ sub __visit_infmap_collapse { if ( $relinfo->{-is_optional} - and - defined ( my $first_distinct_child_idcol = first + ) { + + my ($first_distinct_child_idcol) = grep { ! $known_present_ids->{$_} } @{$relinfo->{-identifying_columns}} - ) - ) { + ; + + DBIx::Class::Exception->throw( + "An optional node *without* a distinct identifying set shouldn't be possible: " . dump_value $args->{collapse_map}, + 1, + ) unless defined $first_distinct_child_idcol; if ($args->{prune_null_branches}) { @@ -355,14 +460,58 @@ sub __visit_infmap_collapse { } } + if ( + + # calculation only valid for leaf nodes + ! values %$rel_cols + + and + + # child of underdefined path doesn't leave us anything to test + @{$args->{-parent_id_path} || []} + + and + + (my @nullable_portion = grep + { ! $args->{-mandatory_ids}{$_} } + ( + @{$args->{-parent_id_path}}, + sort { $a <=> $b } keys %$node_specific_ids + ) + ) > 1 + ) { + # there may be 1:1 overlap with a specific all_or_nothing + push @{$args->{-null_from}}, \@nullable_portion unless grep + { + my $a_o_n_set = $_; + + keys %$a_o_n_set == @nullable_portion + and + ! grep { ! $a_o_n_set->{$_} } @nullable_portion + } + @{ $args->{-all_or_nothing_sets} || [] } + ; + } + return ( \@src, - { - idcols_seen => { - ( map { %{ $_->{idcols_seen} } } values %$stats ), - ( map { $_ => 1 } @{$args->{collapse_map}->{-identifying_columns}} ), - } - } + ( $cur_node_idx != 0 ) ? () : { + idcols_seen => $args->{-seen_ids}, + nullchecks => { + ( keys %{$args->{-mandatory_ids} } + ? ( mandatory => $args->{-mandatory_ids} ) + : () + ), + ( @{$args->{-all_or_nothing_sets}} + ? ( all_or_nothing => $args->{-all_or_nothing_sets} ) + : () + ), + ( @{$args->{-null_from}} + ? ( from_first_encounter => $args->{-null_from} ) + : () + ), + }, + }, ); } diff --git a/lib/DBIx/Class/ResultSource/Table.pm b/lib/DBIx/Class/ResultSource/Table.pm index ac7d30886..450be9a56 100644 --- a/lib/DBIx/Class/ResultSource/Table.pm +++ b/lib/DBIx/Class/ResultSource/Table.pm @@ -3,10 +3,7 @@ package DBIx::Class::ResultSource::Table; use strict; use warnings; -use DBIx::Class::ResultSet; - -use base qw/DBIx::Class/; -__PACKAGE__->load_components(qw/ResultSource/); +use base 'DBIx::Class::ResultSource'; =head1 NAME @@ -26,7 +23,10 @@ Returns the FROM entry for the table (i.e. the table name) =cut -sub from { shift->name; } +sub from { + $_[0]->throw_exception('from() is not a setter method') if @_ > 1; + $_[0]->name; +} =head1 FURTHER QUESTIONS? diff --git a/lib/DBIx/Class/ResultSource/View.pm b/lib/DBIx/Class/ResultSource/View.pm index 4694c8787..818295ec2 100644 --- a/lib/DBIx/Class/ResultSource/View.pm +++ b/lib/DBIx/Class/ResultSource/View.pm @@ -3,12 +3,11 @@ package DBIx::Class::ResultSource::View; use strict; use warnings; -use DBIx::Class::ResultSet; +use base 'DBIx::Class::ResultSource'; -use base qw/DBIx::Class/; -__PACKAGE__->load_components(qw/ResultSource/); -__PACKAGE__->mk_group_accessors( - 'simple' => qw(is_virtual view_definition deploy_depends_on) ); +__PACKAGE__->mk_group_accessors( rsrc_instance_specific_attribute => qw( + is_virtual view_definition deploy_depends_on +)); =head1 NAME @@ -23,8 +22,8 @@ DBIx::Class::ResultSource::View - ResultSource object representing a view __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year2000cds'); - __PACKAGE__->result_source_instance->is_virtual(1); - __PACKAGE__->result_source_instance->view_definition( + __PACKAGE__->result_source->is_virtual(1); + __PACKAGE__->result_source->view_definition( "SELECT cdid, artist, title FROM cd WHERE year ='2000'" ); __PACKAGE__->add_columns( @@ -75,13 +74,13 @@ above, you can then: If you modified the schema to include a placeholder - __PACKAGE__->result_source_instance->view_definition( + __PACKAGE__->result_source->view_definition( "SELECT cdid, artist, title FROM cd WHERE year = ?" ); and ensuring you have is_virtual set to true: - __PACKAGE__->result_source_instance->is_virtual(1); + __PACKAGE__->result_source->is_virtual(1); You could now say: @@ -115,14 +114,14 @@ You could now say: =head2 is_virtual - __PACKAGE__->result_source_instance->is_virtual(1); + __PACKAGE__->result_source->is_virtual(1); Set to true for a virtual view, false or unset for a real database-based view. =head2 view_definition - __PACKAGE__->result_source_instance->view_definition( + __PACKAGE__->result_source->view_definition( "SELECT cdid, artist, title FROM cd WHERE year ='2000'" ); @@ -131,7 +130,7 @@ syntaxes. =head2 deploy_depends_on - __PACKAGE__->result_source_instance->deploy_depends_on( + __PACKAGE__->result_source->deploy_depends_on( ["MyApp::Schema::Result::Year","MyApp::Schema::Result::CD"] ); @@ -148,9 +147,11 @@ or the SQL as a subselect if this is a virtual view. =cut sub from { - my $self = shift; - return \"(${\$self->view_definition})" if $self->is_virtual; - return $self->name; + $_[0]->throw_exception('from() is not a setter method') if @_ > 1; + $_[0]->is_virtual + ? \( '(' . $_[0]->view_definition .')' ) + : $_[0]->name + ; } =head1 OTHER METHODS diff --git a/lib/DBIx/Class/ResultSourceHandle.pm b/lib/DBIx/Class/ResultSourceHandle.pm index b9b54bf5c..169cb4a78 100644 --- a/lib/DBIx/Class/ResultSourceHandle.pm +++ b/lib/DBIx/Class/ResultSourceHandle.pm @@ -116,7 +116,12 @@ sub STORABLE_thaw { $self->schema( $s ); } else { - $rs->source_name( $self->source_moniker ); + # FIXME do not use accessor here - will trigger the divergent meta logic + # Ideally this should be investigated and fixed properly, but the + # codepath is so obscure, and the trigger point (t/52leaks.t) so bizarre + # that... meh. + $rs->{source_name} = $self->source_moniker; + $rs->{_detached_thaw} = 1; $self->_detached_source( $rs ); } diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm index 1e1f307d3..0032a0ae2 100644 --- a/lib/DBIx/Class/ResultSourceProxy.pm +++ b/lib/DBIx/Class/ResultSourceProxy.pm @@ -6,49 +6,85 @@ use warnings; use base 'DBIx::Class'; -use Scalar::Util 'blessed'; -use DBIx::Class::_Util 'quote_sub'; -use namespace::clean; - -__PACKAGE__->mk_group_accessors('inherited_ro_instance' => 'source_name'); +# ! LOAD ORDER SENSITIVE ! +# needs to be loaded early to query method attributes below +# and to do the around()s properly +use DBIx::Class::ResultSource; +my @wrap_rsrc_methods = qw( + add_columns + add_relationship +); -sub get_inherited_ro_instance { shift->get_inherited(@_) } - -sub set_inherited_ro_instance { - my $self = shift; +use DBIx::Class::_Util qw( + quote_sub perlstring fail_on_internal_call describe_class_methods +); +use namespace::clean; - $self->throw_exception ("Cannot set @{[shift]} on an instance") - if blessed $self; +# FIXME: this is truly bizarre, not sure why it is this way since 93405cf0 +# This value *IS* *DIFFERENT* from source_name in the underlying rsrc +# instance, and there is *ZERO EFFORT* made to synchronize them... +# FIXME: Due to the above marking this as a rsrc_proxy method is also out +# of the question... +# FIXME: this used to be a sub-type of inherited ( to see run: +# `git log -Sinherited_ro_instance lib/DBIx/Class/ResultSourceProxy.pm` ) +# however given the lack of any sync effort as described above *anyway*, +# it makes no sense to guard for erroneous use at a non-trivial cost in +# performance (and may end up in the way of future optimizations as per +# https://github.com/vovkasm/Class-Accessor-Inherited-XS/issues/2#issuecomment-243246924 ) +__PACKAGE__->mk_group_accessors( inherited => 'source_name'); - $self->set_inherited(@_); +# The marking with indirect_sugar will cause warnings to be issued in darkpan code +# (though extremely unlikely) +sub get_inherited_ro_instance :DBIC_method_is_indirect_sugar { + DBIx::Class::Exception->throw( + "The 'inherted_ro_instance' CAG group has been retired - use 'inherited' instead" + ); +} +sub set_inherited_ro_instance :DBIC_method_is_indirect_sugar { + DBIx::Class::Exception->throw( + "The 'inherted_ro_instance' CAG group has been retired - use 'inherited' instead" + ); } - -sub add_columns { +sub add_columns :DBIC_method_is_bypassable_resultsource_proxy { my ($class, @cols) = @_; - my $source = $class->result_source_instance; + my $source = $class->result_source; + local $source->{__callstack_includes_rsrc_proxy_method} = "add_columns"; + $source->add_columns(@cols); + + my $colinfos; foreach my $c (grep { !ref } @cols) { # If this is an augment definition get the real colname. $c =~ s/^\+//; - $class->register_column($c => $source->column_info($c)); + $class->register_column( + $c, + ( $colinfos ||= $source->columns_info )->{$c} + ); } } -sub add_column { shift->add_columns(@_) } - +sub add_column :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->add_columns(@_) +} -sub add_relationship { +sub add_relationship :DBIC_method_is_bypassable_resultsource_proxy { my ($class, $rel, @rest) = @_; - my $source = $class->result_source_instance; + my $source = $class->result_source; + local $source->{__callstack_includes_rsrc_proxy_method} = "add_relationship"; + $source->add_relationship($rel => @rest); $class->register_relationship($rel => $source->relationship_info($rel)); } # legacy resultset_class accessor, seems to be used by cdbi only -sub iterator_class { shift->result_source_instance->resultset_class(@_) } +sub iterator_class :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->result_source->resultset_class(@_) +} for my $method_to_proxy (qw/ source_info @@ -81,11 +117,274 @@ for my $method_to_proxy (qw/ relationship_info has_relationship /) { - quote_sub __PACKAGE__."::$method_to_proxy", sprintf( <<'EOC', $method_to_proxy ); + my $qsub_opts = { attributes => [ + do { + no strict 'refs'; + attributes::get( \&{"DBIx::Class::ResultSource::$method_to_proxy"} ); + } + ] }; + + # bypassable default for backcompat, except for indirect methods + # ( those will simply warn during the sanheck ) + if(! grep + { $_ eq 'DBIC_method_is_indirect_sugar' } + @{ $qsub_opts->{attributes} } + ) { + push @wrap_rsrc_methods, $method_to_proxy; + push @{ $qsub_opts->{atributes} }, 'DBIC_method_is_bypassable_resultsource_proxy'; + } + + quote_sub __PACKAGE__."::$method_to_proxy", sprintf( <<'EOC', $method_to_proxy ), {}, $qsub_opts; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; - shift->result_source_instance->%s (@_); + + my $rsrc = shift->result_source; + local $rsrc->{__callstack_includes_rsrc_proxy_method} = q(%1$s); + $rsrc->%1$s (@_); +EOC + +} + +# This is where the "magic" of detecting/invoking the proper overridden +# Result method takes place. It isn't implemented as a stateless out-of-band +# SanityCheck as invocation requires certain state in the $rsrc object itself +# in order not to loop over itself. It is not in ResultSource.pm either +# because of load order and because the entire stack is just terrible :/ +# +# The code is not easily readable, as it it optimized for execution time +# (this stuff will be run all the time across the entire install base :/ ) +# +{ + our %__rsrc_proxy_meta_cache; + + sub DBIx::Class::__RsrcProxy_iThreads_handler__::CLONE { + # recreating this cache is pretty cheap: just blow it away + %__rsrc_proxy_meta_cache = (); + } + + for my $method_to_wrap (@wrap_rsrc_methods) { + + my @src_args = ( + perlstring $method_to_wrap, + ); + + my $orig = do { + no strict 'refs'; + \&{"DBIx::Class::ResultSource::$method_to_wrap"} + }; + + my %unclassified_override_warn_emitted; + + my @qsub_args = ( + { + # ref to hashref, this is how S::Q works + '$rsrc_proxy_meta_cache' => \\%__rsrc_proxy_meta_cache, + '$unclassified_override_warn_emitted' => \\%unclassified_override_warn_emitted, + '$orig' => \$orig, + }, + { attributes => [ attributes::get($orig) ] } + ); + + quote_sub "DBIx::Class::ResultSource::$method_to_wrap", sprintf( <<'EOC', @src_args ), @qsub_args; + + my $overridden_proxy_cref; + + # fall through except when... + return &$orig unless ( + + # FIXME - this may be necessary some day, but skip the hit for now + # Scalar::Util::reftype $_[0] eq 'HASH' + # and + + # there is a class to check in the first place + defined $_[0]->{result_class} + + and + # we are not in a reinvoked callstack + ( + ( $_[0]->{__callstack_includes_rsrc_proxy_method} || '' ) + ne + %1$s + ) + + and + # there is a proxied method in the first place + ( + ( $rsrc_proxy_meta_cache->{address}{%1$s} ||= 0 + ( + DBIx::Class::ResultSourceProxy->can(%1$s) + || + -1 + ) ) + > + 0 + ) + + and + # the proxied method *is overridden* + ( + $rsrc_proxy_meta_cache->{address}{%1$s} + != + # the can() should not be able to fail in theory, but the + # result class may not inherit from ::Core *at all* + # hence we simply ||ourselves to paper over this eventuality + ( + ( $overridden_proxy_cref = $_[0]->{result_class}->can(%1$s) ) + || + $rsrc_proxy_meta_cache->{address}{%1$s} + ) + ) + + and + # no short-circuiting atributes + (! grep + { + # checking that: + # + # - Override is not something DBIC plastered on top of things + # One would think this is crazy, yet there it is... sigh: + # https://metacpan.org/source/KARMAN/DBIx-Class-RDBOHelpers-0.12/t/lib/MyDBIC/Schema/Cd.pm#L26-27 + # + # - And is not an m2m crapfest + # + # - And is not something marked as bypassable + + $_ =~ / ^ DBIC_method_is_ (?: + generated_from_resultsource_metadata + | + m2m_ (?: extra_)? sugar (?:_with_attrs)? + | + bypassable_resultsource_proxy + ) $ /x + } + keys %%{ $rsrc_proxy_meta_cache->{attrs}{$overridden_proxy_cref} ||= { + map { $_ => 1 } attributes::get($overridden_proxy_cref) + }} + ) + ); + + # Getting this far means that there *is* an override + # and it is *not* marked for a skip + + # we were asked to loop back through the Result override + if ( + $rsrc_proxy_meta_cache->{attrs} + {$overridden_proxy_cref} + {DBIC_method_is_mandatory_resultsource_proxy} + ) { + local $_[0]->{__callstack_includes_rsrc_proxy_method} = %1$s; + + # replace $self without compromising aliasing + splice @_, 0, 1, $_[0]->{result_class}; + + return &$overridden_proxy_cref; + } + # complain (sparsely) and carry on + else { + + # FIXME!!! - terrible, need to swap for something saner later + my ($cs) = DBIx::Class::Carp::__find_caller( __PACKAGE__ ); + + my $key = $cs . $overridden_proxy_cref; + + unless( $unclassified_override_warn_emitted->{$key} ) { + + # find the real origin + my @meth_stack = @{ DBIx::Class::_Util::describe_class_methods( + ref $_[0]->{result_class} || $_[0]->{result_class} + )->{methods}{%1$s} }; + + my $in_class = (shift @meth_stack)->{via_class}; + + my $possible_supers; + while ( + @meth_stack + and + $meth_stack[0]{via_class} ne __PACKAGE__ + ) { + push @$possible_supers, (shift @meth_stack)->{via_class}; + } + + $possible_supers = $possible_supers + ? sprintf( + ' ( and possible SUPERs: %%s )', + join ', ', map + { join '::', $_, %1$s } + @$possible_supers + ) + : '' + ; + + my $fqmeth = $in_class . '::' . %1$s . '()'; + + DBIx::Class::_Util::emit_loud_diag( + + # Repurpose the assertion envvar ( the override-check is independent + # from the schema san-checker, but the spirit is the same ) + confess => $ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS}, + + msg => + "The override method $fqmeth$possible_supers has been bypassed " + . "$cs\n" + . "In order to silence this warning you must tag the " + . "definition of $fqmeth with one of the attributes " + . "':DBIC_method_is_bypassable_resultsource_proxy' or " + . "':DBIC_method_is_mandatory_resultsource_proxy' ( see " + . "https://is.gd/dbic_rsrcproxy_methodattr for more info )\n" + ); + + # only set if we didn't throw + $unclassified_override_warn_emitted->{$key} = 1; + } + + return &$orig; + } EOC + } + + Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; +} + +# CI sanity check that all annotations make sense +if( + DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + and + # no point taxing 5.8 with this + ! DBIx::Class::_ENV_::OLD_MRO +) { + + my ( $rsrc_methods, $rsrc_proxy_methods, $base_methods ) = map { + describe_class_methods($_)->{methods} + } qw( + DBIx::Class::ResultSource + DBIx::Class::ResultSourceProxy + DBIx::Class + ); + + delete $rsrc_methods->{$_}, delete $rsrc_proxy_methods->{$_} + for keys %$base_methods; + + ( + $rsrc_methods->{$_} + and + ! $rsrc_proxy_methods->{$_}[0]{attributes}{DBIC_method_is_indirect_sugar} + ) + or + delete $rsrc_proxy_methods->{$_} + for keys %$rsrc_proxy_methods; + + # see fat FIXME at top of file + delete @{$rsrc_proxy_methods}{qw( source_name _source_name_accessor )}; + + if ( + ( my $proxied = join "\n", map "\t$_", sort keys %$rsrc_proxy_methods ) + ne + ( my $wrapped = join "\n", map "\t$_", sort @wrap_rsrc_methods ) + ) { + Carp::confess( + "Unexpected mismatch between the list of proxied methods:\n\n$proxied" + . "\n\nand the list of wrapped rsrc methods:\n\n$wrapped\n\n" + ); + } } 1; diff --git a/lib/DBIx/Class/ResultSourceProxy/Table.pm b/lib/DBIx/Class/ResultSourceProxy/Table.pm index 647a4089c..4cb733fae 100644 --- a/lib/DBIx/Class/ResultSourceProxy/Table.pm +++ b/lib/DBIx/Class/ResultSourceProxy/Table.pm @@ -9,43 +9,46 @@ use DBIx::Class::ResultSource::Table; use Scalar::Util 'blessed'; use namespace::clean; -__PACKAGE__->mk_classdata(table_class => 'DBIx::Class::ResultSource::Table'); - -__PACKAGE__->mk_classdata('table_alias'); # FIXME: Doesn't actually do - # anything yet! +__PACKAGE__->mk_classaccessor(table_class => 'DBIx::Class::ResultSource::Table'); +# FIXME: Doesn't actually do anything yet! +__PACKAGE__->mk_group_accessors( inherited => 'table_alias' ); sub _init_result_source_instance { my $class = shift; - $class->mk_classdata('result_source_instance') - unless $class->can('result_source_instance'); + $class->mk_group_accessors( inherited => [ result_source_instance => '_result_source' ] ) + unless $class->can('result_source_instance'); + + # might be pre-made for us courtesy of DBIC::DB::result_source_instance() + my $rsrc = $class->result_source_instance; - my $table = $class->result_source_instance; - my $class_has_table_instance = ($table and $table->result_class eq $class); - return $table if $class_has_table_instance; + return $rsrc + if $rsrc and $rsrc->result_class eq $class; my $table_class = $class->table_class; $class->ensure_class_loaded($table_class); - if( $table ) { - $table = $table_class->new({ - %$table, + if( $rsrc ) { + # + # NOTE! - not using clone() here and *NOT* marking source as derived + # from the one already existing on the class (if any) + # + $rsrc = $table_class->new({ + %$rsrc, result_class => $class, source_name => undef, schema => undef }); } else { - $table = $table_class->new({ + $rsrc = $table_class->new({ name => undef, result_class => $class, source_name => undef, }); } - $class->result_source_instance($table); - - return $table; + $class->result_source_instance($rsrc); } =head1 NAME @@ -78,30 +81,60 @@ Gets or sets the table name. =cut sub table { + return $_[0]->result_source->name unless @_ > 1; + my ($class, $table) = @_; - return $class->result_source_instance->name unless $table; unless (blessed $table && $table->isa($class->table_class)) { + my $ancestor = $class->can('result_source_instance') + ? $class->result_source_instance + : undef + ; + + # Folks calling ->table on a class *might* expect the name + # to shift everywhere, but that can't happen + # So what we do is mark the ancestor as "dirty" + # even though it will have no "derived" link to the one we + # will use afterwards + if( + defined $ancestor + and + $ancestor->name ne $table + and + scalar $ancestor->__derived_instances + ) { + # Trigger the "descendants are dirty" logic, without giving + # it an explicit externally-callable interface + # This is ugly as sin, but likely saner in the long run + local $ancestor->{__in_rsrc_setter_callstack} = 1 + unless $ancestor->{__in_rsrc_setter_callstack}; + my $old_name = $ancestor->name; + $ancestor->set_rsrc_instance_specific_attribute( name => "\0" ); + $ancestor->set_rsrc_instance_specific_attribute( name => $old_name ); + } + + my $table_class = $class->table_class; $class->ensure_class_loaded($table_class); + + # NOTE! - not using clone() here and *NOT* marking source as derived + # from the one already existing on the class (if any) + # This is logically sound as we are operating at class-level, and is + # in fact necessary, as otherwise any base-class with a "dummy" table + # will be marked as an ancestor of everything $table = $table_class->new({ - $class->can('result_source_instance') - ? %{$class->result_source_instance||{}} - : () - , + %{ $ancestor || {} }, name => $table, result_class => $class, }); } - $class->mk_classdata('result_source_instance') + $class->mk_group_accessors( inherited => [ result_source_instance => '_result_source' ] ) unless $class->can('result_source_instance'); - $class->result_source_instance($table); - - return $class->result_source_instance->name; + $class->result_source_instance($table)->name; } =head2 table_class diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index daf5885d3..8b8f5fb08 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -6,8 +6,10 @@ use warnings; use base qw/DBIx::Class/; use Scalar::Util 'blessed'; -use List::Util 'first'; -use DBIx::Class::_Util 'dbic_internal_try'; +use DBIx::Class::_Util qw( + dbic_internal_try fail_on_internal_call + DUMMY_ALIASPAIR +); use DBIx::Class::Carp; use SQL::Abstract qw( is_literal_value is_plain_value ); @@ -191,13 +193,13 @@ sub new { $rsrc ||= $h->resolve; } - $new->result_source($rsrc) if $rsrc; + $new->result_source_instance($rsrc) if $rsrc; if (my $col_from_rel = delete $attrs->{-cols_from_relations}) { @{$new->{_ignore_at_insert}={}}{@$col_from_rel} = (); } - my ($related,$inflated); + my( $related, $inflated, $colinfos ); foreach my $key (keys %$attrs) { if (ref $attrs->{$key} and ! is_literal_value($attrs->{$key}) ) { @@ -259,9 +261,8 @@ sub new { next; } elsif ( - $rsrc->has_column($key) - and - $rsrc->column_info($key)->{_inflate_info} + ( $colinfos ||= $rsrc->columns_info ) + ->{$key}{_inflate_info} ) { $inflated->{$key} = $attrs->{$key}; next; @@ -344,7 +345,7 @@ sub insert { $self->throw_exception("No result_source set on this object; can't insert") unless $rsrc; - my $storage = $rsrc->storage; + my $storage = $rsrc->schema->storage; my $rollback_guard; @@ -358,7 +359,7 @@ sub insert { my $rel_obj = $related_stuff{$rel_name}; if (! $self->{_rel_in_storage}{$rel_name}) { - next unless (blessed $rel_obj && $rel_obj->isa('DBIx::Class::Row')); + next unless (blessed $rel_obj && $rel_obj->isa(__PACKAGE__)); next unless $rsrc->_pk_depends_on( $rel_name, { $rel_obj->get_columns } @@ -373,8 +374,7 @@ sub insert { my $existing; # if there are no keys - nothing to search for - if (keys %$them and $existing = $self->result_source - ->related_source($rel_name) + if (keys %$them and $existing = $rsrc->related_source($rel_name) ->resultset ->find($them) ) { @@ -419,7 +419,14 @@ sub insert { or (defined $current_rowdata{$_} xor defined $returned_cols->{$_}) or - (defined $current_rowdata{$_} and $current_rowdata{$_} ne $returned_cols->{$_}) + ( + defined $current_rowdata{$_} + and + # one of the few spots doing forced-stringification + # needed to work around objects with defined stringification + # but *without* overloaded comparison (ugh!) + "$current_rowdata{$_}" ne "$returned_cols->{$_}" + ) ); } @@ -437,7 +444,7 @@ sub insert { : $related_stuff{$rel_name} ; - if (@cands && blessed $cands[0] && $cands[0]->isa('DBIx::Class::Row') + if (@cands && blessed $cands[0] && $cands[0]->isa(__PACKAGE__) ) { my $reverse = $rsrc->reverse_relationship_info($rel_name); foreach my $obj (@cands) { @@ -549,9 +556,11 @@ sub update { my %to_update = $self->get_dirty_columns or return $self; - $self->throw_exception( "Not in database" ) unless $self->in_storage; + $self->throw_exception( + 'Result object not marked in_storage: an update() operation is not possible' + ) unless $self->in_storage; - my $rows = $self->result_source->storage->update( + my $rows = $self->result_source->schema->storage->update( $self->result_source, \%to_update, $self->_storage_ident_condition ); if ($rows == 0) { @@ -611,9 +620,11 @@ See also L. sub delete { my $self = shift; if (ref $self) { - $self->throw_exception( "Not in database" ) unless $self->in_storage; + $self->throw_exception( + 'Result object not marked in_storage: a delete() operation is not possible' + ) unless $self->in_storage; - $self->result_source->storage->delete( + $self->result_source->schema->storage->delete( $self->result_source, $self->_storage_ident_condition ); @@ -621,12 +632,9 @@ sub delete { $self->in_storage(0); } else { - my $rsrc = dbic_internal_try { $self->result_source_instance } - or $self->throw_exception("Can't do class delete without a ResultSource instance"); - - my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {}; + my $attrs = @_ > 1 && ref $_[-1] eq 'HASH' ? { %{pop(@_)} } : {}; my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_}; - $rsrc->resultset->search(@_)->delete; + $self->result_source->resultset->search_rs(@_)->delete; } return $self; } @@ -892,15 +900,18 @@ sub get_inflated_columns { sub _is_column_numeric { my ($self, $column) = @_; - return undef unless $self->result_source->has_column($column); + my $rsrc; + + return undef + unless ( $rsrc = $self->result_source )->has_column($column); - my $colinfo = $self->result_source->column_info ($column); + my $colinfo = $rsrc->columns_info->{$column}; # cache for speed (the object may *not* have a resultsource instance) if ( ! defined $colinfo->{is_numeric} and - my $storage = dbic_internal_try { $self->result_source->schema->storage } + my $storage = dbic_internal_try { $rsrc->schema->storage } ) { $colinfo->{is_numeric} = $storage->is_datatype_numeric ($colinfo->{data_type}) @@ -1026,7 +1037,10 @@ sub _eq_column_values { # value tracked between column changes and commitment to storage sub _track_storage_value { my ($self, $col) = @_; - return defined first { $col eq $_ } ($self->result_source->primary_columns); + return scalar grep + { $col eq $_ } + $self->result_source->primary_columns + ; } =head2 set_columns @@ -1088,7 +1102,9 @@ See also L. sub set_inflated_columns { my ( $self, $upd ) = @_; - my $rsrc; + + my ($rsrc, $colinfos); + foreach my $key (keys %$upd) { if (ref $upd->{$key}) { $rsrc ||= $self->result_source; @@ -1106,9 +1122,11 @@ sub set_inflated_columns { ); } elsif ( - $rsrc->has_column($key) - and - exists $rsrc->column_info($key)->{_inflate_info} + exists( ( + ( $colinfos ||= $rsrc->columns_info )->{$key} + || + {} + )->{_inflate_info} ) ) { $self->set_inflated_column($key, delete $upd->{$key}); } @@ -1160,7 +1178,7 @@ sub copy { my $new = { _column_data => $col_data }; bless $new, ref $self; - $new->result_source($rsrc); + $new->result_source_instance($rsrc); $new->set_inflated_columns($changes); $new->insert; @@ -1179,16 +1197,17 @@ sub copy { $copied->{$_->ID}++ or $_->copy( - $foreign_vals ||= $rsrc->_resolve_relationship_condition( - infer_values_based_on => {}, + $foreign_vals ||= $rsrc->resolve_relationship_condition( + require_join_free_values => 1, rel_name => $rel_name, self_result_object => $new, - self_alias => "\xFE", # irrelevant - foreign_alias => "\xFF", # irrelevant, - )->{inferred_values} + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, + )->{join_free_values} - ) for $self->search_related($rel_name)->all; + ) for $self->related_resultset($rel_name)->all; } return $new; } @@ -1221,17 +1240,13 @@ sub store_column { $self->throw_exception( "set_column called for ${column} without value" ) if @_ < 3; - return $self->{_column_data}{$column} = $value - unless length ref $value and my $vref = is_plain_value( $value ); - - # if we are dealing with a value/ref - there are a couple possibilities - # unpack the underlying piece of data and stringify all objects explicitly - # ( to accomodate { -value => ... } and guard against overloaded objects - # with defined stringification AND fallback => 0 (ugh!) - $self->{_column_data}{$column} = defined blessed $$vref - ? "$$vref" - : $$vref - ; + my $vref; + $self->{_column_data}{$column} = ( + # unpack potential { -value => "foo" } + ( length ref $value and $vref = is_plain_value( $value ) ) + ? $$vref + : $value + ); } =head2 inflate_result @@ -1352,7 +1367,10 @@ Alias for L =cut -sub insert_or_update { shift->update_or_insert(@_) } +sub insert_or_update :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->update_or_insert(@_); +} sub update_or_insert { my $self = shift; @@ -1419,22 +1437,23 @@ Accessor to the L this object was created from. =cut -sub result_source { - $_[0]->throw_exception( 'result_source can be called on instances only' ) - unless ref $_[0]; - +sub result_source :DBIC_method_is_indirect_sugar { + # While getter calls are routed through here for sensible exception text + # it makes no sense to have setters do the same thing + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and @_ > 1 - ? $_[0]->{_result_source} = $_[1] - - # note this is a || not a ||=, the difference is important - : $_[0]->{_result_source} || do { - $_[0]->can('result_source_instance') - ? $_[0]->result_source_instance - : $_[0]->throw_exception( - "No result source instance registered for @{[ ref $_[0] ]}, did you forget to call @{[ ref $_[0] ]}->table(...) ?" - ) - } - ; + and + fail_on_internal_call; + + # this is essentially a `shift->result_source_instance(@_)` with handholding + &{ + $_[0]->can('result_source_instance') + || + $_[0]->throw_exception( + "No ResultSource instance registered for '@{[ $_[0] ]}', did you forget to call @{[ ref $_[0] || $_[0] ]}->table(...) ?" + ) + }; } =head2 register_column @@ -1502,15 +1521,16 @@ L. =cut sub get_from_storage { - my $self = shift @_; - my $attrs = shift @_; - my $resultset = $self->result_source->resultset; - - if(defined $attrs) { - $resultset = $resultset->search(undef, $attrs); - } + my $self = shift; - return $resultset->find($self->_storage_ident_condition); + # with or without attrs? + ( + defined( $_[0] ) + ? $self->result_source->resultset->search_rs( undef, $_[0] ) + : $self->result_source->resultset + )->find( + $self->_storage_ident_condition + ); } =head2 discard_changes @@ -1581,8 +1601,9 @@ sub throw_exception { my $self=shift; if ( - ref $self + ! DBIx::Class::_Util::in_internal_try and + # FIXME - the try is 99% superfluous, but just in case my $rsrc = dbic_internal_try { $self->result_source_instance } ) { $rsrc->throw_exception(@_) diff --git a/lib/DBIx/Class/SQLMaker.pm b/lib/DBIx/Class/SQLMaker.pm index 245847b5b..9b140c172 100644 --- a/lib/DBIx/Class/SQLMaker.pm +++ b/lib/DBIx/Class/SQLMaker.pm @@ -90,7 +90,7 @@ of the internals is simply not worth the performance cost. =head2 Relationship to L When initial work on DQ was taking place, the tools in L<::Storage::DBIHacks -|http://github.com/dbsrgits/dbix-class/blob/current/blead/lib/DBIx/Class/Storage/DBIHacks.pm> +|http://github.com/dbsrgits/dbix-class/blob/master/lib/DBIx/Class/Storage/DBIHacks.pm> were only beginning to take shape, and it wasn't clear how important they will become further down the road. In fact the I was considered an ugly stop-gap, and even a couple of highly entertaining talks @@ -130,8 +130,9 @@ use base qw/ /; use mro 'c3'; -use Sub::Name 'subname'; use DBIx::Class::Carp; +use DBIx::Class::_Util 'set_subname'; +use SQL::Abstract 'is_literal_value'; use namespace::clean; __PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/); @@ -161,12 +162,12 @@ BEGIN { # that use DBIx::Class::Carp/DBIx::Class::Exception instead of plain Carp no warnings qw/redefine/; - *SQL::Abstract::belch = subname 'SQL::Abstract::belch' => sub (@) { + *SQL::Abstract::belch = set_subname 'SQL::Abstract::belch' => sub (@) { my($func) = (caller(1))[3]; carp "[$func] Warning: ", @_; }; - *SQL::Abstract::puke = subname 'SQL::Abstract::puke' => sub (@) { + *SQL::Abstract::puke = set_subname 'SQL::Abstract::puke' => sub (@) { my($func) = (caller(1))[3]; __PACKAGE__->throw_exception("[$func] Fatal: " . join ('', @_)); }; @@ -191,7 +192,7 @@ sub _assert_bindval_matches_bindtype () { 1 }; # poor man's de-qualifier sub _quote { - $_[0]->next::method( ( $_[0]{_dequalify_idents} and ! ref $_[1] ) + $_[0]->next::method( ( $_[0]{_dequalify_idents} and defined $_[1] and ! ref $_[1] ) ? $_[1] =~ / ([^\.]+) $ /x : $_[1] ); @@ -209,8 +210,28 @@ sub _where_op_NEST { sub select { my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_; + ($fields, @{$self->{select_bind}}) = length ref $fields + ? $self->_recurse_fields( $fields ) + : $self->_quote( $fields ) + ; - ($fields, @{$self->{select_bind}}) = $self->_recurse_fields($fields); + # Override the default behavior of SQL::Abstract - SELECT * makes + # no sense in the context of DBIC (and has resulted in several + # tricky debugging sessions in the past) + not length $fields + and +# FIXME - some day we need to enable this, but too many things break +# ( notably S::L ) +# # Random value selected by a fair roll of dice +# # In seriousness - this has to be a number, as it is much more +# # palatable to random engines in a SELECT list +# $fields = 42 +# and + carp_unique ( + "ResultSets with an empty selection are deprecated (you almost certainly " + . "did not mean to do that): if this is indeed your intent you must " + . "explicitly supply \\'*' to your search()" + ); if (defined $offset) { $self->throw_exception('A supplied offset must be a non-negative integer') @@ -327,20 +348,31 @@ sub insert { sub _recurse_fields { my ($self, $fields) = @_; - my $ref = ref $fields; - return $self->_quote($fields) unless $ref; - return $$fields if $ref eq 'SCALAR'; - - if ($ref eq 'ARRAY') { - my (@select, @bind); - for my $field (@$fields) { - my ($select, @new_bind) = $self->_recurse_fields($field); - push @select, $select; - push @bind, @new_bind; - } + + if( not length ref $fields ) { + return $self->_quote( $fields ); + } + + elsif( my $lit = is_literal_value( $fields ) ) { + return @$lit + } + + elsif( ref $fields eq 'ARRAY' ) { + my (@select, @bind, @bind_fragment); + + ( + ( $select[ $#select + 1 ], @bind_fragment ) = length ref $_ + ? $self->_recurse_fields( $_ ) + : $self->_quote( $_ ) + ), + ( push @bind, @bind_fragment ) + for @$fields; + return (join(', ', @select), @bind); } - elsif ($ref eq 'HASH') { + + # FIXME - really crappy handling of functions + elsif ( ref $fields eq 'HASH') { my %hash = %$fields; # shallow copy my $as = delete $hash{-as}; # if supplied @@ -348,34 +380,41 @@ sub _recurse_fields { my ($func, $rhs, @toomany) = %hash; # there should be only one pair - if (@toomany) { - $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) ); - } - - if (lc ($func) eq 'distinct' && ref $rhs eq 'ARRAY' && @$rhs > 1) { - $self->throw_exception ( - 'The select => { distinct => ... } syntax is not supported for multiple columns.' - .' Instead please use { group_by => [ qw/' . (join ' ', @$rhs) . '/ ] }' - .' or { select => [ qw/' . (join ' ', @$rhs) . '/ ], distinct => 1 }' - ); - } - - my ($rhs_sql, @rhs_bind) = $self->_recurse_fields($rhs); - my $select = sprintf ('%s( %s )%s', - $self->_sqlcase($func), - $rhs_sql, - $as - ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) ) - : '' + $self->throw_exception( + "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) + ) if @toomany; + + $self->throw_exception ( + 'The select => { distinct => ... } syntax is not supported for multiple columns.' + .' Instead please use { group_by => [ qw/' . (join ' ', @$rhs) . '/ ] }' + .' or { select => [ qw/' . (join ' ', @$rhs) . '/ ], distinct => 1 }' + ) if ( + lc ($func) eq 'distinct' + and + ref $rhs eq 'ARRAY' + and + @$rhs > 1 ); - return ($select, @rhs_bind); - } - elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) { - return @{$$fields}; + my ($rhs_sql, @rhs_bind) = length ref $rhs + ? $self->_recurse_fields($rhs) + : $self->_quote($rhs) + ; + + return( + sprintf( '%s( %s )%s', + $self->_sqlcase($func), + $rhs_sql, + $as + ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) ) + : '' + ), + @rhs_bind + ); } + else { - $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} ); + $self->throw_exception( ref($fields) . ' unexpected in _recurse_fields()' ); } } diff --git a/lib/DBIx/Class/SQLMaker/LimitDialects.pm b/lib/DBIx/Class/SQLMaker/LimitDialects.pm index 0cfcd2b55..0e6eb7e99 100644 --- a/lib/DBIx/Class/SQLMaker/LimitDialects.pm +++ b/lib/DBIx/Class/SQLMaker/LimitDialects.pm @@ -3,9 +3,6 @@ package DBIx::Class::SQLMaker::LimitDialects; use warnings; use strict; -use List::Util 'first'; -use namespace::clean; - # constants are used not only here, but also in comparison tests sub __rows_bindtype () { +{ sqlt_datatype => 'integer' } @@ -278,7 +275,7 @@ EOS if ( $rs_attrs->{order_by} and - $rs_attrs->{result_source}->storage->_order_by_is_stable( + $rs_attrs->{result_source}->schema->storage->_order_by_is_stable( @{$rs_attrs}{qw/from order_by where/} ) ) { @@ -543,7 +540,7 @@ sub _GenericSubQ { . 'main-table-based order criteria.' ) unless $rs_attrs->{order_by}; - my $usable_order_colinfo = $main_rsrc->storage->_extract_colinfo_of_stable_main_source_order_by_portion( + my $usable_order_colinfo = $main_rsrc->schema->storage->_extract_colinfo_of_stable_main_source_order_by_portion( $rs_attrs ); @@ -740,16 +737,22 @@ sub _subqueried_limit_attrs { my $s = $rs_attrs->{select}[$i]; my $sql_alias = (ref $s) eq 'HASH' ? $s->{-as} : undef; - # we throw away the @bind here deliberately - my ($sql_sel) = $self->_recurse_fields ($s); + my ($sql_sel) = length ref $s + # we throw away the @bind here deliberately + ? $self->_recurse_fields( $s ) + : $self->_quote( $s ) + ; push @sel, { arg => $s, sql => $sql_sel, - unquoted_sql => do { - local $self->{quote_char}; - ($self->_recurse_fields ($s))[0]; # ignore binds again - }, + unquoted_sql => ( length ref $s + ? do { + local $self->{quote_char}; + ($self->_recurse_fields ($s))[0]; # ignore binds again + } + : $s + ), as => $sql_alias || diff --git a/lib/DBIx/Class/SQLMaker/OracleJoins.pm b/lib/DBIx/Class/SQLMaker/OracleJoins.pm index 0f50467ed..00e58fb05 100644 --- a/lib/DBIx/Class/SQLMaker/OracleJoins.pm +++ b/lib/DBIx/Class/SQLMaker/OracleJoins.pm @@ -81,8 +81,8 @@ sub _recurse_oracle_joins { } # FIXME - the code below *UTTERLY* doesn't work with custom conds... sigh - # for the time being do not do any processing with the likes of _collapse_cond - # instead only unroll the -and hack if present + # for the time being do not do any processing with the likes of + # normalize_sqla_condition(), instead only unroll the -and hack if present $on = $on->{-and}[0] if ( ref $on eq 'HASH' and diff --git a/lib/DBIx/Class/SQLMaker/Util.pm b/lib/DBIx/Class/SQLMaker/Util.pm new file mode 100644 index 000000000..430cc2b5b --- /dev/null +++ b/lib/DBIx/Class/SQLMaker/Util.pm @@ -0,0 +1,526 @@ +package #hide from PAUSE + DBIx::Class::SQLMaker::Util; + +use strict; +use warnings; + +use base 'Exporter'; +our @EXPORT_OK = qw( + normalize_sqla_condition + extract_equality_conditions +); + +use DBIx::Class::Carp; +use Carp 'croak'; +use SQL::Abstract qw( is_literal_value is_plain_value ); +use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dump_value modver_gt_or_eq ); + +# Can not use DBIx::Class::_Util::serialize as it is based on +# Storable and leaks through differences between PVIV and an identical IV +# Since SQLA itself is lossy in this regard (it does not make proper copies +# for efficiency) one could end up in a situation where semantically +# identical values aren't treated as such +my $dd_obj; +sub lax_serialize ($) { + my $dump_str = ( + $dd_obj + ||= + do { + require Data::Dumper; + + # Warnings without this on early loads under -w + # Why? Because fuck me, that's why :/ + local $Data::Dumper::Indent = 0 + unless defined $Data::Dumper::Indent; + + # Make sure each option is spelled out with a value, so that + # global environment changes can not override any of these + # between two serialization calls + # + my $d = Data::Dumper->new([]) + ->Indent('0') + ->Purity(0) + ->Pad('') + ->Useqq(0) + ->Terse(1) + ->Freezer('') + ->Toaster('') + ->Deepcopy(0) + ->Quotekeys(0) + ->Bless('bless') + ->Pair(' => ') + ->Maxdepth(0) + ->Useperl(0) + ->Sortkeys(1) + ->Deparse(0) + ; + + # FIXME - this is kinda ridiculous - there ought to be a + # Data::Dumper->new_with_defaults or somesuch... + # + if( modver_gt_or_eq ( 'Data::Dumper', '2.136' ) ) { + $d->Sparseseen(1); + + if( modver_gt_or_eq ( 'Data::Dumper', '2.153' ) ) { + $d->Maxrecurse(1000); + + if( modver_gt_or_eq ( 'Data::Dumper', '2.160' ) ) { + $d->Trailingcomma(0); + } + } + } + + $d; + } + )->Values([$_[0]])->Dump; + + $dd_obj->Reset->Values([]); + + $dump_str; +} + + +# Attempts to flatten a passed in SQLA condition as much as possible towards +# a plain hashref, *without* altering its semantics. +# +# FIXME - while relatively robust, this is still imperfect, one of the first +# things to tackle when we get access to a formalized AST. Note that this code +# is covered by a *ridiculous* amount of tests, so starting with porting this +# code would be a rather good exercise +sub normalize_sqla_condition { + my ($where, $where_is_anded_array) = @_; + + my $fin; + + if (! $where) { + return; + } + elsif ($where_is_anded_array or ref $where eq 'HASH') { + + my @pairs; + + my @pieces = $where_is_anded_array ? @$where : $where; + while (@pieces) { + my $chunk = shift @pieces; + + if (ref $chunk eq 'HASH') { + for (sort keys %$chunk) { + + # Match SQLA 1.79 behavior + unless( length $_ ) { + is_literal_value($chunk->{$_}) + ? carp 'Hash-pairs consisting of an empty string with a literal are deprecated, use -and => [ $literal ] instead' + : croak 'Supplying an empty left hand side argument is not supported in hash-pairs' + ; + } + + push @pairs, $_ => $chunk->{$_}; + } + } + elsif (ref $chunk eq 'ARRAY') { + push @pairs, -or => $chunk + if @$chunk; + } + elsif ( ! length ref $chunk) { + + # Match SQLA 1.79 behavior + croak("Supplying an empty left hand side argument is not supported in array-pairs") + if $where_is_anded_array and (! defined $chunk or ! length $chunk); + + push @pairs, $chunk, shift @pieces; + } + else { + push @pairs, '', $chunk; + } + } + + return unless @pairs; + + my @conds = _normalize_cond_unroll_pairs(\@pairs) + or return; + + # Consolidate various @conds back into something more compact + for my $c (@conds) { + if (ref $c ne 'HASH') { + push @{$fin->{-and}}, $c; + } + else { + for my $col (keys %$c) { + + # consolidate all -and nodes + if ($col =~ /^\-and$/i) { + push @{$fin->{-and}}, + ref $c->{$col} eq 'ARRAY' ? @{$c->{$col}} + : ref $c->{$col} eq 'HASH' ? %{$c->{$col}} + : { $col => $c->{$col} } + ; + } + elsif ($col =~ /^\-/) { + push @{$fin->{-and}}, { $col => $c->{$col} }; + } + elsif (exists $fin->{$col}) { + $fin->{$col} = [ -and => map { + (ref $_ eq 'ARRAY' and ($_->[0]||'') =~ /^\-and$/i ) + ? @{$_}[1..$#$_] + : $_ + ; + } ($fin->{$col}, $c->{$col}) ]; + } + else { + $fin->{$col} = $c->{$col}; + } + } + } + } + + # a deduplication (and sort) pass on all individual -and/-or members + for my $op (qw( -and -or )) { + if( @{ $fin->{$op} || [] } > 1 ) { + my $seen_chunks = { map { + lax_serialize($_) => $_ + } @{$fin->{$op}} }; + + $fin->{$op} = [ @{$seen_chunks}{ sort keys %$seen_chunks } ]; + } + } + } + elsif (ref $where eq 'ARRAY') { + # we are always at top-level here, it is safe to dump empty *standalone* pieces + my $fin_idx; + + for (my $i = 0; $i <= $#$where; $i++ ) { + + # Match SQLA 1.79 behavior + croak( + "Supplying an empty left hand side argument is not supported in array-pairs" + ) if (! defined $where->[$i] or ! length $where->[$i]); + + my $logic_mod = lc ( ($where->[$i] =~ /^(\-(?:and|or))$/i)[0] || '' ); + + if ($logic_mod) { + $i++; + croak("Unsupported top-level op/arg pair: [ $logic_mod => $where->[$i] ]") + unless ref $where->[$i] eq 'HASH' or ref $where->[$i] eq 'ARRAY'; + + my $sub_elt = normalize_sqla_condition({ $logic_mod => $where->[$i] }) + or next; + + my @keys = keys %$sub_elt; + if ( @keys == 1 and $keys[0] !~ /^\-/ ) { + $fin_idx->{ "COL_$keys[0]_" . lax_serialize $sub_elt } = $sub_elt; + } + else { + $fin_idx->{ "SER_" . lax_serialize $sub_elt } = $sub_elt; + } + } + elsif (! length ref $where->[$i] ) { + my $sub_elt = normalize_sqla_condition({ @{$where}[$i, $i+1] }) + or next; + + $fin_idx->{ "COL_$where->[$i]_" . lax_serialize $sub_elt } = $sub_elt; + $i++; + } + else { + $fin_idx->{ "SER_" . lax_serialize $where->[$i] } = normalize_sqla_condition( $where->[$i] ) || next; + } + } + + if (! $fin_idx) { + return; + } + elsif ( keys %$fin_idx == 1 ) { + $fin = (values %$fin_idx)[0]; + } + else { + my @or; + + # at this point everything is at most one level deep - unroll if needed + for (sort keys %$fin_idx) { + if ( ref $fin_idx->{$_} eq 'HASH' and keys %{$fin_idx->{$_}} == 1 ) { + my ($l, $r) = %{$fin_idx->{$_}}; + + if ( + ref $r eq 'ARRAY' + and + ( + ( @$r == 1 and $l =~ /^\-and$/i ) + or + $l =~ /^\-or$/i + ) + ) { + push @or, @$r + } + + elsif ( + ref $r eq 'HASH' + and + keys %$r == 1 + and + $l =~ /^\-(?:and|or)$/i + ) { + push @or, %$r; + } + + else { + push @or, $l, $r; + } + } + else { + push @or, $fin_idx->{$_}; + } + } + + $fin->{-or} = \@or; + } + } + else { + # not a hash not an array + $fin = { -and => [ $where ] }; + } + + # unroll single-element -and's + while ( + $fin->{-and} + and + @{$fin->{-and}} < 2 + ) { + my $and = delete $fin->{-and}; + last if @$and == 0; + + # at this point we have @$and == 1 + if ( + ref $and->[0] eq 'HASH' + and + ! grep { exists $fin->{$_} } keys %{$and->[0]} + ) { + $fin = { + %$fin, %{$and->[0]} + }; + } + else { + $fin->{-and} = $and; + last; + } + } + + # compress same-column conds found in $fin + for my $col ( grep { $_ !~ /^\-/ } keys %$fin ) { + next unless ref $fin->{$col} eq 'ARRAY' and ($fin->{$col}[0]||'') =~ /^\-and$/i; + my $val_bag = { map { + (! defined $_ ) ? ( UNDEF => undef ) + : ( ! length ref $_ or is_plain_value $_ ) ? ( "VAL_$_" => $_ ) + : ( ( 'SER_' . lax_serialize $_ ) => $_ ) + } @{$fin->{$col}}[1 .. $#{$fin->{$col}}] }; + + if (keys %$val_bag == 1 ) { + ($fin->{$col}) = values %$val_bag; + } + else { + $fin->{$col} = [ -and => map { $val_bag->{$_} } sort keys %$val_bag ]; + } + } + + return keys %$fin ? $fin : (); +} + +sub _normalize_cond_unroll_pairs { + my $pairs = shift; + + my @conds; + + while (@$pairs) { + my ($lhs, $rhs) = splice @$pairs, 0, 2; + + if (! length $lhs) { + push @conds, normalize_sqla_condition($rhs); + } + elsif ( $lhs =~ /^\-and$/i ) { + push @conds, normalize_sqla_condition($rhs, (ref $rhs eq 'ARRAY')); + } + elsif ( $lhs =~ /^\-or$/i ) { + push @conds, normalize_sqla_condition( + (ref $rhs eq 'HASH') ? [ map { $_ => $rhs->{$_} } sort keys %$rhs ] : $rhs + ); + } + else { + if (ref $rhs eq 'HASH' and ! keys %$rhs) { + # FIXME - SQLA seems to be doing... nothing...? + } + # normalize top level -ident, for saner extract_equality_conditions() code + elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-ident}) { + push @conds, { $lhs => { '=', $rhs } }; + } + elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-value} and is_plain_value $rhs->{-value}) { + push @conds, { $lhs => $rhs->{-value} }; + } + elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='}) { + if ( length ref $rhs->{'='} and is_literal_value $rhs->{'='} ) { + push @conds, { $lhs => $rhs }; + } + else { + for my $p (_normalize_cond_unroll_pairs([ $lhs => $rhs->{'='} ])) { + + # extra sanity check + if (keys %$p > 1) { + local $Data::Dumper::Deepcopy = 1; + croak( + "Internal error: unexpected collapse unroll:" + . dump_value { in => { $lhs => $rhs }, out => $p } + ); + } + + my ($l, $r) = %$p; + + push @conds, ( + ! length ref $r + or + # the unroller recursion may return a '=' prepended value already + ref $r eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='} + or + is_plain_value($r) + ) + ? { $l => $r } + : { $l => { '=' => $r } } + ; + } + } + } + elsif (ref $rhs eq 'ARRAY') { + # some of these conditionals encounter multi-values - roll them out using + # an unshift, which will cause extra looping in the while{} above + if (! @$rhs ) { + push @conds, { $lhs => [] }; + } + elsif ( ($rhs->[0]||'') =~ /^\-(?:and|or)$/i ) { + croak("Value modifier not followed by any values: $lhs => [ $rhs->[0] ] ") + if @$rhs == 1; + + if( $rhs->[0] =~ /^\-and$/i ) { + unshift @$pairs, map { $lhs => $_ } @{$rhs}[1..$#$rhs]; + } + # if not an AND then it's an OR + elsif(@$rhs == 2) { + unshift @$pairs, $lhs => $rhs->[1]; + } + else { + push @conds, { $lhs => [ @{$rhs}[1..$#$rhs] ] }; + } + } + elsif (@$rhs == 1) { + unshift @$pairs, $lhs => $rhs->[0]; + } + else { + push @conds, { $lhs => $rhs }; + } + } + # unroll func + { -value => ... } + elsif ( + ref $rhs eq 'HASH' + and + ( my ($subop) = keys %$rhs ) == 1 + and + length ref ((values %$rhs)[0]) + and + my $vref = is_plain_value( (values %$rhs)[0] ) + ) { + push @conds, ( + (length ref $$vref) + ? { $lhs => $rhs } + : { $lhs => { $subop => $$vref } } + ); + } + else { + push @conds, { $lhs => $rhs }; + } + } + } + + return @conds; +} + +# Analyzes a given condition and attempts to extract all columns +# with a definitive fixed-condition criteria. Returns a hashref +# of k/v pairs suitable to be passed to set_columns(), with a +# MAJOR CAVEAT - multi-value (contradictory) equalities are still +# represented as a reference to the UNRESOVABLE_CONDITION constant +# The reason we do this is that some codepaths only care about the +# codition being stable, as opposed to actually making sense +# +# The normal mode is used to figure out if a resultset is constrained +# to a column which is part of a unique constraint, which in turn +# allows us to better predict how ordering will behave etc. +# +# With the optional "consider_nulls" boolean argument, the function +# is instead used to infer inambiguous values from conditions +# (e.g. the inheritance of resultset conditions on new_result) +# +sub extract_equality_conditions { + my ($where, $consider_nulls) = @_; + my $where_hash = normalize_sqla_condition($where); + + my $res = {}; + my ($c, $v); + for $c (keys %$where_hash) { + my $vals; + + if (!defined ($v = $where_hash->{$c}) ) { + $vals->{UNDEF} = $v if $consider_nulls + } + elsif ( + ref $v eq 'HASH' + and + keys %$v == 1 + ) { + if (exists $v->{-value}) { + if (defined $v->{-value}) { + $vals->{"VAL_$v->{-value}"} = $v->{-value} + } + elsif( $consider_nulls ) { + $vals->{UNDEF} = $v->{-value}; + } + } + # do not need to check for plain values - normalize_sqla_condition did it for us + elsif( + length ref $v->{'='} + and + ( + ( ref $v->{'='} eq 'HASH' and keys %{$v->{'='}} == 1 and exists $v->{'='}{-ident} ) + or + is_literal_value($v->{'='}) + ) + ) { + $vals->{ 'SER_' . lax_serialize $v->{'='} } = $v->{'='}; + } + } + elsif ( + ! length ref $v + or + is_plain_value ($v) + ) { + $vals->{"VAL_$v"} = $v; + } + elsif (ref $v eq 'ARRAY' and ($v->[0]||'') eq '-and') { + for ( @{$v}[1..$#$v] ) { + my $subval = extract_equality_conditions({ $c => $_ }, 'consider nulls'); # always fish nulls out on recursion + next unless exists $subval->{$c}; # didn't find anything + $vals->{ + ! defined $subval->{$c} ? 'UNDEF' + : ( ! length ref $subval->{$c} or is_plain_value $subval->{$c} ) ? "VAL_$subval->{$c}" + : ( 'SER_' . lax_serialize $subval->{$c} ) + } = $subval->{$c}; + } + } + + if (keys %$vals == 1) { + ($res->{$c}) = (values %$vals) + unless !$consider_nulls and exists $vals->{UNDEF}; + } + elsif (keys %$vals > 1) { + $res->{$c} = UNRESOLVABLE_CONDITION; + } + } + + $res; +} + +1; diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 0be8919f9..1bf19653e 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -6,22 +6,30 @@ use warnings; use base 'DBIx::Class'; use DBIx::Class::Carp; -use Try::Tiny; -use Scalar::Util qw/weaken blessed/; +use Scalar::Util qw( weaken blessed refaddr ); use DBIx::Class::_Util qw( - refcount quote_sub scope_guard - is_exception dbic_internal_try + refdesc refcount quote_sub scope_guard + is_exception dbic_internal_try dbic_internal_catch + fail_on_internal_call emit_loud_diag ); use Devel::GlobalDestruction; use namespace::clean; -__PACKAGE__->mk_classdata('class_mappings' => {}); -__PACKAGE__->mk_classdata('source_registrations' => {}); -__PACKAGE__->mk_classdata('storage_type' => '::DBI'); -__PACKAGE__->mk_classdata('storage'); -__PACKAGE__->mk_classdata('exception_action'); -__PACKAGE__->mk_classdata('stacktrace' => $ENV{DBIC_TRACE} || 0); -__PACKAGE__->mk_classdata('default_resultset_attributes' => {}); +__PACKAGE__->mk_group_accessors( inherited => qw( storage exception_action ) ); +__PACKAGE__->mk_classaccessor('storage_type' => '::DBI'); +__PACKAGE__->mk_classaccessor('stacktrace' => $ENV{DBIC_TRACE} || 0); +__PACKAGE__->mk_classaccessor('default_resultset_attributes' => {}); + +# These two should have been private from the start but too late now +# Undocumented on purpose, hopefully it won't ever be necessary to +# screw with them +__PACKAGE__->mk_classaccessor('class_mappings' => {}); +__PACKAGE__->mk_classaccessor('source_registrations' => {}); + +__PACKAGE__->mk_group_accessors( component_class => 'schema_sanity_checker' ); +__PACKAGE__->schema_sanity_checker( + 'DBIx::Class::Schema::SanityChecker' +); =head1 NAME @@ -195,8 +203,8 @@ sub _ns_get_rsrc_instance { my $rs_class = ref ($_[0]) || $_[0]; return dbic_internal_try { - $rs_class->result_source_instance - } catch { + $rs_class->result_source + } dbic_internal_catch { $me->throw_exception ( "Attempt to load_namespaces() class $rs_class failed - are you sure this is a real Result Class?: $_" ); @@ -233,10 +241,6 @@ sub load_namespaces { my @to_register; { - no warnings qw/redefine/; - local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; - use warnings qw/redefine/; - # ensure classes are loaded and attached in inheritance order for my $result_class (values %$results_by_source_name) { $class->ensure_class_loaded($result_class); @@ -290,8 +294,6 @@ sub load_namespaces { .'with no corresponding Result class'; } - Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; - $class->register_class(@$_) for (@to_register); return; @@ -373,10 +375,6 @@ sub load_classes { my @to_register; { - no warnings qw/redefine/; - local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; - use warnings qw/redefine/; - foreach my $prefix (keys %comps_for) { foreach my $comp (@{$comps_for{$prefix}||[]}) { my $comp_class = "${prefix}::${comp}"; @@ -393,7 +391,6 @@ sub load_classes { } } } - Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; foreach my $to (@to_register) { $class->register_class(@$to); @@ -426,6 +423,66 @@ both types of refs here in order to play nice with your Config::[class] or your choice. See L for an example of this. +=head2 default_resultset_attributes + +=over 4 + +=item Arguments: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES> + +=item Return Value: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES> + +=item Default value: None + +=back + +Like L stores a collection +of resultset attributes, to be used as defaults for B ResultSet +instance schema-wide. The same list of CAVEATS and WARNINGS applies, with +the extra downside of these defaults being practically inescapable: you will +B be able to derive a ResultSet instance with these attributes unset. + +Example: + + package My::Schema; + use base qw/DBIx::Class::Schema/; + __PACKAGE__->default_resultset_attributes( { software_limit => 1 } ); + +=head2 schema_sanity_checker + +=over 4 + +=item Arguments: L provider + +=item Return Value: L provider + +=item Default value: L + +=back + +On every call to L if the value of this attribute evaluates to +true, DBIC will invoke +C<< L<$schema_sanity_checker|/schema_sanity_checker>->L($schema) >> +before returning. The return value of this invocation is ignored. + +B to +L this +feature was introduced. Blindly disabling the checker on existing projects +B after upgrade to C<< DBIC >= v0.082900 >>. + +Example: + + package My::Schema; + use base qw/DBIx::Class::Schema/; + __PACKAGE__->schema_sanity_checker('My::Schema::SanityChecker'); + + # or to disable all checks: + __PACKAGE__->schema_sanity_checker(''); + +Note: setting the value to C B have the desired effect, +due to an implementation detail of L inherited +accessors. In order to disable any and all checks you must set this +attribute to an empty string as shown in the second example above. + =head2 exception_action =over 4 @@ -524,7 +581,10 @@ version, overload L instead. =cut -sub connect { shift->clone->connection(@_) } +sub connect :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->clone->connection(@_); +} =head2 resultset @@ -584,21 +644,58 @@ source name. =cut sub source { - my $self = shift; + my ($self, $source_name) = @_; $self->throw_exception("source() expects a source name") - unless @_; + unless $source_name; + + my $source_registrations; + + my $rsrc = + ( $source_registrations = $self->source_registrations )->{$source_name} + || + # if we got here, they probably passed a full class name + $source_registrations->{ $self->class_mappings->{$source_name} || '' } + || + $self->throw_exception( "Can't find source for ${source_name}" ) + ; - my $source_name = shift; + # DO NOT REMOVE: + # We need to prevent alterations of pre-existing $@ due to where this call + # sits in the overall stack ( *unless* of course there is an actual error + # to report ). set_mro does alter $@ (and yes - it *can* throw an exception) + # We do not use local because set_mro *can* throw an actual exception + # We do not use a try/catch either, as on one hand it would slow things + # down for no reason (we would always rethrow), but also because adding *any* + # try/catch block below will segfault various threading tests on older perls + # ( which in itself is a FIXME but ENOTIMETODIG ) + my $old_dollarat = $@; + + no strict 'refs'; + mro::set_mro($_, 'c3') for + grep + { + # some pseudo-sources do not have a result/resultset yet + defined $_ + and + ( + ( + ${"${_}::__INITIAL_MRO_UPON_DBIC_LOAD__"} + ||= mro::get_mro($_) + ) + ne + 'c3' + ) + } + map + { length ref $_ ? ref $_ : $_ } + ( $rsrc, $rsrc->result_class, $rsrc->resultset_class ) + ; - my $sreg = $self->source_registrations; - return $sreg->{$source_name} if exists $sreg->{$source_name}; + # DO NOT REMOVE - see comment above + $@ = $old_dollarat; - # if we got here, they probably passed a full class name - 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}; + $rsrc; } =head2 class @@ -767,7 +864,9 @@ those values. =cut -sub populate { +sub populate :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + my ($self, $name, $data) = @_; my $rs = $self->resultset($name) or $self->throw_exception("'$name' is not a resultset"); @@ -781,13 +880,17 @@ sub populate { =item Arguments: @args -=item Return Value: $new_schema +=item Return Value: $self =back Similar to L except sets the storage object and connection -data in-place on the Schema class. You should probably be calling -L to get a proper Schema object instead. +data B on C<$self>. You should probably be calling +L to get a properly L Schema object instead. + +If the accessor L returns a true value C<$checker>, +the following call will take place before return: +C<< L<$checker|/schema_sanity_checker>->L)|DBIx::Class::Schema::SanityChecker/perform_schema_sanity_checks> >> =head3 Overloading @@ -795,6 +898,7 @@ Overload C to change the behaviour of C. =cut +my $default_off_stderr_blurb_emitted; sub connection { my ($self, @info) = @_; return $self if !@info && $self->storage; @@ -809,7 +913,7 @@ sub connection { dbic_internal_try { $self->ensure_class_loaded ($storage_class); } - catch { + dbic_internal_catch { $self->throw_exception( "Unable to load storage class ${storage_class}: $_" ); @@ -818,7 +922,12 @@ sub connection { my $storage = $storage_class->new( $self => $args||{} ); $storage->connect_info(\@info); $self->storage($storage); - return $self; + + if( my $checker = $self->schema_sanity_checker ) { + $checker->perform_schema_sanity_checks($self); + } + + $self; } sub _normalize_storage_type { @@ -865,25 +974,6 @@ will produce the output =cut -# this might be oversimplified -# sub compose_namespace { -# my ($self, $target, $base) = @_; - -# my $schema = $self->clone; -# 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($source_name, $source); -# } -# return $schema; -# } - sub compose_namespace { my ($self, $target, $base) = @_; @@ -896,40 +986,52 @@ sub compose_namespace { #$schema->class_mappings({}); { - no warnings qw/redefine/; - local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; - use warnings qw/redefine/; - foreach my $source_name ($self->sources) { my $orig_source = $self->source($source_name); 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($source_name, bless - { %$orig_source, result_class => $target_class }, - ref $orig_source, + $schema->register_source( + $source_name, + $orig_source->clone( + result_class => $target_class + ), ); - - if ($target_class->can('result_source_instance')) { - # give the class a schema-less source copy - $target_class->result_source_instance( bless - { %$new_source, schema => ref $new_source->{schema} || $new_source->{schema} }, - ref $new_source, - ); - } } + # Legacy stuff, not inserting INDIRECT assertions quote_sub "${target}::${_}" => "shift->schema->$_(\@_)" for qw(class source resultset); } - Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; + # needed to cover the newly installed stuff via quote_sub above + Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; + + # Give each composed class yet another *schema-less* source copy + # this is used for the freeze/thaw cycle + # + # This is not covered by any tests directly, but is indirectly exercised + # in t/cdbi/sweet/08pager by re-setting the schema on an existing object + # FIXME - there is likely a much cheaper way to take care of this + for my $source_name ($self->sources) { + + my $target_class = "${target}::${source_name}"; + + $target_class->result_source_instance( + $self->source($source_name)->clone( + result_class => $target_class, + schema => ( ref $schema || $schema ), + ) + ); + } return $schema; } +# LEGACY: The intra-call to this was removed in 66d9ef6b and then +# the sub was de-documented way later in 249963d4. No way to be sure +# nothing on darkpan is calling it directly, so keeping as-is sub setup_connection_class { my ($class, $target, @info) = @_; $class->inject_base($target => 'DBIx::Class::DB'); @@ -1028,13 +1130,10 @@ sub _copy_state_from { $self->class_mappings({ %{$from->class_mappings} }); $self->source_registrations({ %{$from->source_registrations} }); - 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($source_name => $new); - } + # 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( $_ => $from->source($_) ) + for $from->sources; if ($from->storage) { $self->storage($from->storage); @@ -1070,8 +1169,8 @@ sub throw_exception { my $guard = scope_guard { return if $guard_disarmed; - local $SIG{__WARN__}; - Carp::cluck(" + emit_loud_diag( emit_dups => 1, msg => " + !!! DBIx::Class INTERNAL PANIC !!! The exception_action() handler installed on '$self' @@ -1084,11 +1183,11 @@ anything for other software that might be affected by a similar problem. !!! FIX YOUR ERROR HANDLING !!! -This guard was activated beginning" +This guard was activated starting", ); }; - eval { + dbic_internal_try { # if it throws - good, we'll assign to @args in the end # if it doesn't - do different things depending on RV truthiness if( $act->(@args) ) { @@ -1109,14 +1208,13 @@ This guard was activated beginning" 1; } - - or - - # We call this to get the necessary warnings emitted and disregard the RV - # as it's definitely an exception if we got as far as this do{} block - is_exception( - $args[0] = $@ - ); + dbic_internal_catch { + # We call this to get the necessary warnings emitted and disregard the RV + # as it's definitely an exception if we got as far as this catch{} block + is_exception( + $args[0] = $_ + ); + }; # Done guarding against https://github.com/PerlDancer/Dancer2/issues/1125 $guard_disarmed = 1; @@ -1240,14 +1338,12 @@ format. sub ddl_filename { my ($self, $type, $version, $dir, $preversion) = @_; - require File::Spec; - $version = "$preversion-$version" if $preversion; my $class = blessed($self) || $self; $class =~ s/::/-/g; - return File::Spec->catfile($dir, "$class-$version-$type.sql"); + return "$dir/$class-$version-$type.sql"; } =head2 thaw @@ -1338,13 +1434,13 @@ 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($source_name, $component_class->result_source_instance); + $schema->register_source($source_name, $component_class->result_source); =cut sub register_class { my ($self, $source_name, $to_register) = @_; - $self->register_source($source_name => $to_register->result_source_instance); + $self->register_source($source_name => $to_register->result_source); } =head2 register_source @@ -1394,41 +1490,91 @@ 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, $source_name, $source, $params) = @_; + my ($self, $source_name, $supplied_rsrc, $params) = @_; - $source = $source->new({ %$source, source_name => $source_name }); + my $derived_rsrc = $supplied_rsrc->clone({ + source_name => $source_name, + }); + + # Do not move into the clone-hashref above: there are things + # on CPAN that do hook 'sub schema' + # https://metacpan.org/source/LSAUNDERS/DBIx-Class-Preview-1.000003/lib/DBIx/Class/ResultSource/Table/Previewed.pm#L9-38 + $derived_rsrc->schema($self); - $source->schema($self); - weaken $source->{schema} if ref($self); + weaken $derived_rsrc->{schema} + if length( my $schema_class = ref($self) ); my %reg = %{$self->source_registrations}; - $reg{$source_name} = $source; + $reg{$source_name} = $derived_rsrc; $self->source_registrations(\%reg); - return $source if $params->{extra}; + return $derived_rsrc if $params->{extra}; - my $rs_class = $source->result_class; - if ($rs_class and my $rsrc = dbic_internal_try { $rs_class->result_source_instance } ) { + my( $result_class, $result_class_level_rsrc ); + if ( + $result_class = $derived_rsrc->result_class + and + # There are known cases where $rs_class is *ONLY* an inflator, without + # any hint of a rsrc (e.g. DBIx::Class::KiokuDB::EntryProxy) + $result_class_level_rsrc = dbic_internal_try { $result_class->result_source_instance } + ) { my %map = %{$self->class_mappings}; + + carp ( + "$result_class already had a registered source which was replaced by " + . 'this call. Perhaps you wanted register_extra_source(), though it is ' + . 'more likely you did something wrong.' + ) if ( + exists $map{$result_class} + and + $map{$result_class} ne $source_name + and + $result_class_level_rsrc != $supplied_rsrc + ); + + $map{$result_class} = $source_name; + $self->class_mappings(\%map); + + + my $schema_class_level_rsrc; if ( - exists $map{$rs_class} + # we are called on a schema instance, not on the class + length $schema_class + and - $map{$rs_class} ne $source_name + + # the schema class also has a registration with the same name + $schema_class_level_rsrc = dbic_internal_try { $schema_class->source($source_name) } + and - $rsrc ne $_[2] # orig_source + + # what we are registering on the schema instance *IS* derived + # from the class-level (top) rsrc... + ( grep { $_ == $derived_rsrc } $result_class_level_rsrc->__derived_instances ) + + and + + # ... while the schema-class-level has stale-markers + keys %{ $schema_class_level_rsrc->{__metadata_divergencies} || {} } ) { - carp - "$rs_class already had a registered source which was replaced by this call. " - . 'Perhaps you wanted register_extra_source(), though it is more likely you did ' - . 'something wrong.' + my $msg = + "The ResultSource instance you just registered on '$self' as " + . "'$source_name' seems to have no relation to $schema_class->" + . "source('$source_name') which in turn is marked stale (likely due " + . "to recent $result_class->... direct class calls). This is almost " + . "always a mistake: perhaps you forgot a cycle of " + . "$schema_class->unregister_source( '$source_name' ) / " + . "$schema_class->register_class( '$source_name' => '$result_class' )" ; - } - $map{$rs_class} = $source_name; - $self->class_mappings(\%map); + DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + ? emit_loud_diag( msg => $msg, confess => 1 ) + : carp_unique($msg) + ; + } } - return $source; + $derived_rsrc; } my $global_phase_destroy; @@ -1450,7 +1596,8 @@ sub DESTROY { # however beware - on older perls the exception seems randomly untrappable # due to some weird race condition during thread joining :((( if (length ref $srcs->{$source_name} and refcount($srcs->{$source_name}) > 1) { - local $@; + local $SIG{__DIE__} if $SIG{__DIE__}; + local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT; eval { $srcs->{$source_name}->schema($self); weaken $srcs->{$source_name}; @@ -1526,7 +1673,7 @@ sub compose_connection { dbic_internal_try { require DBIx::Class::ResultSetProxy; } - catch { + dbic_internal_catch { $self->throw_exception ("No arguments to load_classes and couldn't load DBIx::Class::ResultSetProxy ($_)") }; @@ -1537,8 +1684,8 @@ sub compose_connection { my $source = $self->source($source_name); my $class = $source->result_class; $self->inject_base($class, 'DBIx::Class::ResultSetProxy'); - $class->mk_classdata(resultset_instance => $source->resultset); - $class->mk_classdata(class_resolver => $self); + $class->mk_classaccessor(resultset_instance => $source->resultset); + $class->mk_classaccessor(class_resolver => $self); } $self->connection(@info); return $self; @@ -1547,14 +1694,21 @@ sub compose_connection { my $schema = $self->compose_namespace($target, 'DBIx::Class::ResultSetProxy'); quote_sub "${target}::schema", '$s', { '$s' => \$schema }; + # needed to cover the newly installed stuff via quote_sub above + Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; + $schema->connection(@info); foreach my $source_name ($schema->sources) { my $source = $schema->source($source_name); my $class = $source->result_class; #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); + + $class->mk_group_accessors( inherited => [ result_source_instance => '_result_source' ] ); + # explicit set-call, avoid mro update lag + $class->set_inherited( result_source_instance => $source ); + + $class->mk_classaccessor(resultset_instance => $source->resultset); + $class->mk_classaccessor(class_resolver => $schema); } return $schema; } diff --git a/lib/DBIx/Class/Schema/SanityChecker.pm b/lib/DBIx/Class/Schema/SanityChecker.pm new file mode 100644 index 000000000..ccfc0f3be --- /dev/null +++ b/lib/DBIx/Class/Schema/SanityChecker.pm @@ -0,0 +1,594 @@ +package DBIx::Class::Schema::SanityChecker; + +use strict; +use warnings; + +use DBIx::Class::_Util qw( + dbic_internal_try refdesc uniq serialize + describe_class_methods emit_loud_diag +); +use DBIx::Class (); +use Scalar::Util qw( blessed refaddr ); +use namespace::clean; + +=head1 NAME + +DBIx::Class::Schema::SanityChecker - Extensible "critic" for your Schema class hierarchy + +=head1 SYNOPSIS + + package MyApp::Schema; + use base 'DBIx::Class::Schema'; + + # this is the default setting + __PACKAGE__->schema_sanity_checker('DBIx::Class::Schema::SanityChecker'); + ... + +=head1 DESCRIPTION + +This is the default implementation of the Schema and related classes +L. + +The validator is B. See L +for discussion of the runtime effects. + +Use of this class begins by invoking L +(usually via L), which in turn starts +invoking validators I> in the order listed in +L. For each set of returned errors (if any) +I> is called and the resulting strings are +passed to L, where final headers are prepended and the entire +thing is printed on C. + +The class does not provide a constructor, due to the lack of state to be +passed around: object orientation was chosen purely for the ease of +overriding parts of the chain of events as described above. The general +pattern of communicating errors between the individual methods (both +before and after formatting) is an arrayref of hash references. + +=head2 WHY + +DBIC existed for more than a decade without any such setup validation +fanciness, let alone something that is enabled by default (which in turn +L). The reason for this relatively +drastic change is a set of revamps within the metadata handling framework, +in order to resolve once and for all problems like +L, +L, etc. While +DBIC internals are now way more robust than they were before, this comes at +a price: some non-issues in code that has been working for a while, will +now become hard to explain, or if you are unlucky: B. + +Thus, in order to protect existing codebases to the fullest extent possible, +the executive decision (and substantial effort) was made to introduce this +on-by-default setup validation framework. A massive amount of work has been +invested ensuring that none of the builtin checks emit a false-positive: +each and every complaint made by these checks B. + +=head2 Performance considerations + +First of all - after your connection has been established - there is B whenever the checks are enabled. + +By default the checks are triggered every time +L is called. Thus there is a +noticeable startup slowdown, most notably during testing (each test is +effectively a standalone program connecting anew). As an example the test +execution phase of the L C distribution +suffers a consistent slowdown of about C<16%>. This is considered a relatively +small price to pay for the benefits provided. + +Nevertheless, there are valid cases for disabling the checks during +day-to-day development, and having them run only during CI builds. In fact +the test suite of DBIC does exactly this as can be seen in +F: + + ~/dbic_repo$ git show 39636786 | perl -ne "print if 16..61" + +Whatever you do, B: it is not +worth the risk. + +=head3 Perl5.8 + +The situation with perl interpreters before C is sadly more +complicated: due to lack of built-in L, the +mechanism used to interrogate various classes is +L<< B slower|https://github.com/dbsrgits/dbix-class/commit/296248c3 >>. +As a result the very same version of L +L takes a C> hit on its +test execution time (these numbers are observed with the speedups of +L available, without them the slowdown reaches the whopping +C<350%>). + +It is the author's B recommendation to find a way to run the +checks on your codebase continuously, even if it takes much longer. Refer to +the last paragraph of L above for an example how +to do this during CI builds only. + +=head2 Validations provided by this module + +=head3 no_indirect_method_overrides + +There are many methods within DBIC which are +L<"strictly sugar"|DBIx::Class::MethodAttributes/DBIC_method_is_indirect_sugar> +and should never be overridden by your application (e.g. see warnings at the +end of L and L). +Starting with C DBIC is much more aggressive in calling the +underlying non-sugar methods directly, which in turn means that almost all +user-side overrides of sugar methods are never going to be invoked. These +situations are now reliably detected and reported individually (you may +end up with a lot of output on C due to this). + +Note: B reported by this check B<*MUST*> be resolved +before upgrading DBIC in production. Malfunctioning business logic and/or +B may result otherwise. + +=head3 valid_c3_composition + +Looks through everything returned by L, and +for any class that B already utilize L a +L is calculated and then +compared to the shadowing map as if C was requested in the first place. +Any discrepancies are reported in order to clearly identify L especially when +encountered within complex inheritance hierarchies. + +=head3 no_inheritance_crosscontamination + +Checks that every individual L, +L, L, +L +and L class does not inherit from +an unexpected DBIC base class: e.g. an error will be raised if your +C inherits from both C and +C. + +=head1 METHODS + +=head2 perform_schema_sanity_checks + +=over + +=item Arguments: L<$schema|DBIx::Class::Schema> + +=item Return Value: unspecified (ignored by caller) + +=back + +The entry point expected by the +L. See +L for details. + +=cut + +sub perform_schema_sanity_checks { + my ($self, $schema) = @_; + + local $DBIx::Class::_Util::describe_class_query_cache->{'!internal!'} = {} + if + # does not make a measurable difference on 5.10+ + DBIx::Class::_ENV_::OLD_MRO + and + # the callstack shouldn't really be recursive, but for completeness... + ! $DBIx::Class::_Util::describe_class_query_cache->{'!internal!'} + ; + + my (@errors_found, $schema_desc); + for my $ch ( @{ $self->available_checks } ) { + + my $err = $self->${\"check_$ch"} ( $schema ); + + push @errors_found, map + { + { + check_name => $ch, + formatted_error => $_, + schema_desc => ( $schema_desc ||= + ( length ref $schema ) + ? refdesc $schema + : "'$schema'" + ), + } + } + @{ + $self->${\"format_${ch}_errors"} ( $err ) + || + [] + } + if @$err; + } + + $self->emit_errors(\@errors_found) + if @errors_found; +} + +=head2 available_checks + +=over + +=item Arguments: none + +=item Return Value: \@list_of_check_names + +=back + +The list of checks L will perform on the +provided L<$schema|DBIx::Class::Schema> object. For every entry returned +by this method, there must be a pair of I> and +I> methods available. + +Override this method to add checks to the +L. + +=cut + +sub available_checks { [qw( + valid_c3_composition + no_inheritance_crosscontamination + no_indirect_method_overrides +)] } + +=head2 emit_errors + +=over + +=item Arguments: \@list_of_formatted_errors + +=item Return Value: unspecified (ignored by caller) + +=back + +Takes an array reference of individual errors returned by various +I> formatters, and outputs them on C. + +This method is the most convenient integration point for a 3rd party logging +framework. + +Each individual error is expected to be a hash reference with all values being +plain strings as follows: + + { + schema_desc => $human_readable_description_of_the_passed_in_schema + check_name => $name_of_the_check_as_listed_in_available_checks() + formatted_error => $error_text_as_returned_by_format_$checkname_errors() + } + +If the environment variable C is set to +a true value this method will throw an exception with the same text. Those who +prefer to take no chances could set this variable permanently as part of their +deployment scripts. + +=cut + +# *NOT* using carp_unique and the warn framework - make +# it harder to accidentaly silence problems via $SIG{__WARN__} +sub emit_errors { + #my ($self, $errs) = @_; + + my @final_error_texts = map { + sprintf( "Schema %s failed the '%s' sanity check: %s\n", + @{$_}{qw( schema_desc check_name formatted_error )} + ); + } @{$_[1]}; + + emit_loud_diag( + msg => $_ + ) for @final_error_texts; + + # Do not use the constant - but instead check the env every time + # This will allow people to start auditing their apps piecemeal + DBIx::Class::Exception->throw( join "\n", @final_error_texts, ' ' ) + if $ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS}; +} + +=head2 all_schema_related_classes + +=over + +=item Arguments: L<$schema|DBIx::Class::Schema> + +=item Return Value: @sorted_list_of_unique_class_names + +=back + +This is a convenience method providing a list (not an arrayref) of +"interesting classes" related to the supplied schema. The returned list +currently contains the following class names: + +=over + +=item * The L class itself + +=item * The associated L class if any + +=item * The classes of all L if any + +=item * All L classes for all registered ResultSource instances + +=item * All L classes for all registered ResultSource instances + +=back + +=cut + +sub all_schema_related_classes { + my ($self, $schema) = @_; + + sort( uniq( map { + ( not defined $_ ) ? () + : ( defined blessed $_ ) ? ref $_ + : $_ + } ( + $schema, + $schema->storage, + ( map { + $_, + $_->result_class, + $_->resultset_class, + } map { $schema->source($_) } $schema->sources ), + ))); +} + + +sub format_no_indirect_method_overrides_errors { + # my ($self, $errors) = @_; + + [ map { sprintf( + "Method(s) %s override the convenience shortcut %s::%s(): " + . 'it is almost certain these overrides *MAY BE COMPLETELY IGNORED* at ' + . 'runtime. You MUST reimplement each override to hook a method from the ' + . "chain of calls within the convenience shortcut as seen when running:\n " + . '~$ perl -M%2$s -MDevel::Dwarn -e "Ddie { %3$s => %2$s->can(q(%3$s)) }"', + join (', ', map { "$_()" } sort @{ $_->{by} } ), + $_->{overridden}{via_class}, + $_->{overridden}{name}, + )} @{ $_[1] } ] +} + +sub check_no_indirect_method_overrides { + my ($self, $schema) = @_; + + my( @err, $seen_shadowing_configurations ); + + METHOD_STACK: + for my $method_stack ( map { + values %{ describe_class_methods($_)->{methods_with_supers} || {} } + } $self->all_schema_related_classes($schema) ) { + + my $nonsugar_methods; + + for (@$method_stack) { + + push @$nonsugar_methods, $_ and next + unless( + $_->{attributes}{DBIC_method_is_indirect_sugar} + or + $_->{attributes}{DBIC_method_is_generated_from_resultsource_metadata} + ); + + push @err, { + overridden => { + name => $_->{name}, + via_class => ( + # this way we report a much better Dwarn oneliner in the error + $_->{attributes}{DBIC_method_is_bypassable_resultsource_proxy} + ? 'DBIx::Class::ResultSource' + : $_->{via_class} + ), + }, + by => [ map { "$_->{via_class}::$_->{name}" } @$nonsugar_methods ], + } if ( + $nonsugar_methods + and + ! $seen_shadowing_configurations->{ + join "\0", + map + { refaddr $_ } + ( + $_, + @$nonsugar_methods, + ) + }++ + ) + ; + + next METHOD_STACK; + } + } + + \@err +} + + +sub format_valid_c3_composition_errors { + # my ($self, $errors) = @_; + + [ map { sprintf( + "Class '%s' %s using the '%s' MRO affecting the lookup order of the " + . "following method(s): %s. You MUST add the following line to '%1\$s' " + . "right after strict/warnings:\n use mro 'c3';", + $_->{class}, + ( ($_->{initial_mro} eq $_->{current_mro}) ? 'is' : 'was originally' ), + $_->{initial_mro}, + join (', ', map { "$_()" } sort keys %{$_->{affected_methods}} ), + )} @{ $_[1] } ] +} + + +my $base_ISA = { + map { $_ => 1 } @{mro::get_linear_isa("DBIx::Class")} +}; + +sub check_valid_c3_composition { + my ($self, $schema) = @_; + + my @err; + + # + # A *very* involved check, to absolutely minimize false positives + # If this check returns an issue - it *better be* a real one + # + for my $class ( $self->all_schema_related_classes($schema) ) { + + my $desc = do { + no strict 'refs'; + describe_class_methods({ + class => $class, + ( ${"${class}::__INITIAL_MRO_UPON_DBIC_LOAD__"} + ? ( use_mro => ${"${class}::__INITIAL_MRO_UPON_DBIC_LOAD__"} ) + : () + ), + }) + }; + + # is there anything to check? + next unless ( + ! $desc->{mro}{is_c3} + and + $desc->{methods_with_supers} + and + my @potentially_problematic_method_stacks = + grep + { + # at least 2 variants came via inheritance (not ours) + ( + (grep { $_->{via_class} ne $class } @$_) + > + 1 + ) + and + # + # last ditch effort to skip examining an alternative mro + # IFF the entire "foreign" stack is located in the "base isa" + # + # This allows for extra efficiency (as there are several + # with_supers methods that would always be there), but more + # importantly saves one from tripping on the nonsensical yet + # begrudgingly functional (as in - no adverse effects): + # + # use base 'DBIx::Class'; + # use base 'DBIx::Class::Schema'; + # + ( + grep { + # not ours + $_->{via_class} ne $class + and + # not from the base stack either + ! $base_ISA->{$_->{via_class}} + } @$_ + ) + } + values %{ $desc->{methods_with_supers} } + ); + + my $affected_methods; + + for my $stack (@potentially_problematic_method_stacks) { + + # If we got so far - we need to see what the class would look + # like under c3 and compare, sigh + # + # Note that if the hierarchy is *really* fucked (like the above + # double-base e.g.) then recalc under 'c3' WILL FAIL, hence the + # extra eval: if we fail we report things as "jumbled up" + # + $affected_methods->{$stack->[0]{name}} = [ + map { $_->{via_class} } @$stack + ] unless dbic_internal_try { + + serialize($stack) + eq + serialize( + describe_class_methods({ class => $class, use_mro => 'c3' }) + ->{methods} + ->{$stack->[0]{name}} + ) + }; + } + + push @err, { + class => $class, + initial_linear_isa => $desc->{linear_isa}, + current_linear_isa => do { (undef, my @isa) = @{ mro::get_linear_isa($class) }; \@isa }, + initial_mro => $desc->{mro}{type}, + current_mro => mro::get_mro($class), + affected_methods => $affected_methods, + } if $affected_methods; + } + + \@err; +} + + +sub format_no_inheritance_crosscontamination_errors { + # my ($self, $errors) = @_; + + [ map { sprintf( + "Class '%s' registered in the role of '%s' unexpectedly inherits '%s': " + . 'you must resolve this by either removing an erroneous `use base` call ' + . "or switching to Moo(se)-style delegation (i.e. the 'handles' keyword)", + $_->{class}, + $_->{type}, + $_->{unexpectedly_inherits}, + )} @{ $_[1] } ] +} + +sub check_no_inheritance_crosscontamination { + my ($self, $schema) = @_; + + my @err; + + my $to_check = { + Schema => [ $schema ], + Storage => [ $schema->storage ], + ResultSource => [ map { $schema->source($_) } $schema->sources ], + }; + + $to_check->{ResultSet} = [ + map { $_->resultset_class } @{$to_check->{ResultSource}} + ]; + + $to_check->{Core} = [ + map { $_->result_class } @{$to_check->{ResultSource}} + ]; + + # Reduce everything to a unique sorted list of class names + $_ = [ sort( uniq( map { + ( not defined $_ ) ? () + : ( defined blessed $_ ) ? ref $_ + : $_ + } @$_ ) ) ] for values %$to_check; + + for my $group ( sort keys %$to_check ) { + for my $class ( @{ $to_check->{$group} } ) { + for my $foreign_base ( + map { "DBIx::Class::$_" } sort grep { $_ ne $group } keys %$to_check + ) { + + push @err, { + class => $class, + type => ( $group eq 'Core' ? 'ResultClass' : $group ), + unexpectedly_inherits => $foreign_base + } if $class->isa($foreign_base); + } + } + } + + \@err; +} + +1; + +__END__ + +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Schema/Versioned.pm b/lib/DBIx/Class/Schema/Versioned.pm index d59961fec..b75288eea 100644 --- a/lib/DBIx/Class/Schema/Versioned.pm +++ b/lib/DBIx/Class/Schema/Versioned.pm @@ -26,7 +26,7 @@ __PACKAGE__->add_columns 'size' => '20' }, ); -__PACKAGE__->set_primary_key('version'); +__PACKAGE__->result_source_instance->set_primary_key('version'); package # Hide from PAUSE DBIx::Class::Version::TableCompat; @@ -41,7 +41,7 @@ __PACKAGE__->add_columns 'data_type' => 'VARCHAR', }, ); -__PACKAGE__->set_primary_key('Version'); +__PACKAGE__->result_source_instance->set_primary_key('Version'); package # Hide from PAUSE DBIx::Class::Version; @@ -49,6 +49,13 @@ use base 'DBIx::Class::Schema'; use strict; use warnings; +# no point sanity checking, unless we are running asserts +__PACKAGE__->schema_sanity_checker( + DBIx::Class::_ENV_::ASSERT_NO_FAILING_SANITY_CHECKS + ? 'DBIx::Class::Schema::SanityChecker' + : '' +); + __PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table'); package # Hide from PAUSE @@ -57,6 +64,13 @@ use base 'DBIx::Class::Schema'; use strict; use warnings; +# no point sanity checking, unless we are running asserts +__PACKAGE__->schema_sanity_checker( + DBIx::Class::_ENV_::ASSERT_NO_FAILING_SANITY_CHECKS + ? 'DBIx::Class::Schema::SanityChecker' + : '' +); + __PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat'); @@ -202,16 +216,17 @@ use warnings; use base 'DBIx::Class::Schema'; use DBIx::Class::Carp; -use DBIx::Class::_Util 'dbic_internal_try'; -use Time::HiRes qw/gettimeofday/; +use DBIx::Class::_Util qw( dbic_internal_try UNRESOLVABLE_CONDITION ); use Scalar::Util 'weaken'; use namespace::clean; -__PACKAGE__->mk_classdata('_filedata'); -__PACKAGE__->mk_classdata('upgrade_directory'); -__PACKAGE__->mk_classdata('backup_directory'); -__PACKAGE__->mk_classdata('do_backup'); -__PACKAGE__->mk_classdata('do_diff_on_init'); +__PACKAGE__->mk_group_accessors( inherited => qw( + _filedata + upgrade_directory + backup_directory + do_backup + do_diff_on_init +) ); =head1 METHODS @@ -528,7 +543,7 @@ sub get_db_version my $vtable = $self->{vschema}->resultset('Table'); my $version = dbic_internal_try { - $vtable->search({}, { order_by => { -desc => 'installed' }, rows => 1 } ) + $vtable->search_rs({}, { order_by => { -desc => 'installed' }, rows => 1 } ) ->get_column ('version') ->next; }; @@ -590,10 +605,15 @@ sub _on_connect { my ($self) = @_; - weaken (my $w_self = $self ); + weaken (my $w_storage = $self->storage ); - $self->{vschema} = DBIx::Class::Version->connect(sub { $w_self->storage->dbh }); - my $conn_attrs = $self->storage->_dbic_connect_attributes || {}; + $self->{vschema} = DBIx::Class::Version->clone->connection( + sub { $w_storage->dbh }, + + # proxy some flags from the main storage + { map { $_ => $w_storage->$_ } qw( unsafe ) }, + ); + my $conn_attrs = $w_storage->_dbic_connect_attributes || {}; my $vtable = $self->{vschema}->resultset('Table'); @@ -602,11 +622,11 @@ sub _on_connect # check for legacy versions table and move to new if exists unless ($self->_source_exists($vtable)) { - my $vtable_compat = DBIx::Class::VersionCompat->connect(sub { $w_self->storage->dbh })->resultset('TableCompat'); + my $vtable_compat = DBIx::Class::VersionCompat->clone->connection(sub { $w_storage->dbh })->resultset('TableCompat'); if ($self->_source_exists($vtable_compat)) { $self->{vschema}->deploy; map { $vtable->new_result({ installed => $_->Installed, version => $_->Version })->insert } $vtable_compat->all; - $self->storage->_get_dbh->do("DROP TABLE " . $vtable_compat->result_source->from); + $w_storage->_get_dbh->do("DROP TABLE " . $vtable_compat->result_source->from); } } @@ -642,6 +662,7 @@ sub _create_db_to_schema_diff { return; } + require DBIx::Class::Optional::Dependencies; if ( my $missing = DBIx::Class::Optional::Dependencies->req_missing_for('deploy') ) { $self->throw_exception("Unable to proceed without $missing"); } @@ -710,7 +731,8 @@ sub _set_db_version { # not possible to format the string sanely, as the column is a varchar(20). # The 'v' character is added to the front of the string, so that any version # formatted by this new function will sort _after_ any existing 200... strings. - my @tm = gettimeofday(); + require Time::HiRes; + my @tm = Time::HiRes::gettimeofday(); my @dt = gmtime ($tm[0]); my $o = $vtable->new_result({ version => $version, @@ -749,7 +771,7 @@ sub _source_exists my ($self, $rs) = @_; ( dbic_internal_try { - $rs->search(\'1=0')->cursor->next; + $rs->search_rs( UNRESOLVABLE_CONDITION )->cursor->next; 1; } ) ? 1 diff --git a/lib/DBIx/Class/StartupCheck.pm b/lib/DBIx/Class/StartupCheck.pm index dff403bc3..17ca65f79 100644 --- a/lib/DBIx/Class/StartupCheck.pm +++ b/lib/DBIx/Class/StartupCheck.pm @@ -1,7 +1,7 @@ package DBIx::Class::StartupCheck; -use strict; use warnings; +use strict; 1; diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm index 47aef3699..dfff9a1a4 100644 --- a/lib/DBIx/Class/Storage.pm +++ b/lib/DBIx/Class/Storage.pm @@ -6,18 +6,17 @@ use warnings; use base qw/DBIx::Class/; use mro 'c3'; -{ - package # Hide from PAUSE - DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION; - use base 'DBIx::Class::Exception'; +BEGIN { + no warnings 'once'; + @DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION::ISA + = 'DBIx::Class::Exception'; } use DBIx::Class::Carp; use DBIx::Class::Storage::BlockRunner; use Scalar::Util qw/blessed weaken/; use DBIx::Class::Storage::TxnScopeGuard; -use DBIx::Class::_Util 'dbic_internal_try'; -use Try::Tiny; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch fail_on_internal_call ); use namespace::clean; __PACKAGE__->mk_group_accessors(simple => qw/debug schema transaction_depth auto_savepoint savepoints/); @@ -25,7 +24,10 @@ __PACKAGE__->mk_group_accessors(component_class => 'cursor_class'); __PACKAGE__->cursor_class('DBIx::Class::Cursor'); -sub cursor { shift->cursor_class(@_); } +sub cursor :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->cursor_class(@_); +} =head1 NAME @@ -149,7 +151,7 @@ For example, my $rs; try { $rs = $schema->txn_do($coderef); - } catch { + } dbic_internal_catch { my $error = shift; # Transaction failed die "something terrible has happened!" @@ -317,7 +319,7 @@ sub __delicate_rollback { dbic_internal_try { $self->txn_rollback; 1 } - catch { + dbic_internal_catch { $rbe = $_; @@ -431,12 +433,15 @@ sub svp_release { if (defined $name) { my @stack = @{ $self->savepoints }; - my $svp; + my $svp = ''; - do { $svp = pop @stack } until $svp eq $name; + while( $svp ne $name ) { - $self->throw_exception ("Savepoint '$name' does not exist") - unless $svp; + $self->throw_exception ("Savepoint '$name' does not exist") + unless @stack; + + $svp = pop @stack; + } $self->savepoints(\@stack); # put back what's left } @@ -577,13 +582,14 @@ sub debugobj { if ($profile =~ /^\.?\//) { + require DBIx::Class::Optional::Dependencies; if ( my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('config_file_reader') ) { $self->throw_exception("Unable to parse TRACE_PROFILE config file '$profile' without $missing"); } my $cfg = dbic_internal_try { Config::Any->load_files({ files => [$profile], use_ext => 1 }); - } catch { + } dbic_internal_catch { # sanitize the error message a bit $_ =~ s/at \s+ .+ Storage\.pm \s line \s \d+ $//x; $self->throw_exception("Failure processing \$ENV{DBIC_TRACE_PROFILE}: $_"); @@ -609,7 +615,7 @@ sub debugobj { # a better fix. This is another yak to shave... :( dbic_internal_try { DBIx::Class::Storage::Debug::PrettyPrint->new(@pp_args); - } catch { + } dbic_internal_catch { $self->throw_exception($_); } } diff --git a/lib/DBIx/Class/Storage/BlockRunner.pm b/lib/DBIx/Class/Storage/BlockRunner.pm index 0f884daac..64d5164cd 100644 --- a/lib/DBIx/Class/Storage/BlockRunner.pm +++ b/lib/DBIx/Class/Storage/BlockRunner.pm @@ -4,12 +4,10 @@ package # hide from pause until we figure it all out use warnings; use strict; -use DBIx::Class::Exception; use DBIx::Class::Carp; use Context::Preserve 'preserve_context'; -use DBIx::Class::_Util qw( is_exception qsub dbic_internal_try ); +use DBIx::Class::_Util qw( is_exception qsub dbic_internal_try dbic_internal_catch ); use Scalar::Util qw(weaken blessed reftype); -use Try::Tiny; use Moo; use namespace::clean; @@ -128,7 +126,7 @@ sub _run { $txn_begin_ok = 1; } $cref->( @$args ); - } catch { + } dbic_internal_catch { $run_err = $_; (); # important, affects @_ below }; @@ -160,7 +158,7 @@ sub _run { $storage->txn_commit; 1; } - catch { + dbic_internal_catch { $run_err = $_; }; } @@ -187,7 +185,13 @@ sub _run { # FIXME - we assume that $storage->{_dbh_autocommit} is there if # txn_init_depth is there, but this is a DBI-ism $txn_init_depth > ( $storage->{_dbh_autocommit} ? 0 : 1 ) - ) or ! $self->retry_handler->($self) + ) + or + ! do { + local $self->storage->{_in_do_block_retry_handler} = 1 + unless $self->storage->{_in_do_block_retry_handler}; + $self->retry_handler->($self) + } ); # we got that far - let's retry diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 54dff8165..16d68e52c 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -9,14 +9,14 @@ use mro 'c3'; use DBIx::Class::Carp; use Scalar::Util qw/refaddr weaken reftype blessed/; -use List::Util qw/first/; use Context::Preserve 'preserve_context'; -use Try::Tiny; use SQL::Abstract qw(is_plain_value is_literal_value); +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; use DBIx::Class::_Util qw( - quote_sub perlstring serialize - dbic_internal_try + quote_sub perlstring serialize dump_value + dbic_internal_try dbic_internal_catch detected_reinvoked_destructor scope_guard + mkdir_p UNRESOLVABLE_CONDITION ); use namespace::clean; @@ -251,7 +251,7 @@ sub new { undef; } - sub CLONE { + sub DBIx::Class::__DBI_Storage_iThreads_handler__::CLONE { # As per DBI's recommendation, DBIC disconnects all handles as # soon as possible (DBIC will reconnect only on demand from within # the thread) @@ -903,10 +903,8 @@ sub disconnect { my $g = scope_guard { - { - local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT; - eval { $self->_dbh->disconnect }; - } + defined( $self->_dbh ) + and dbic_internal_try { $self->_dbh->disconnect }; $self->_dbh(undef); $self->_dbh_details({}); @@ -1176,7 +1174,7 @@ sub _server_info { my $server_version = dbic_internal_try { $self->_get_server_version - } catch { + } dbic_internal_catch { # driver determination *may* use this codepath # in which case we must rethrow $self->throw_exception($_) if $self->{_in_determine_driver}; @@ -1306,7 +1304,9 @@ sub _determine_driver { if ((not $self->_driver_determined) && (not $self->{_in_determine_driver})) { my $started_connected = 0; - local $self->{_in_determine_driver} = 1; + + local $self->{_in_determine_driver} = 1 + unless $self->{_in_determine_driver}; if (ref($self) eq __PACKAGE__) { my $driver; @@ -1321,7 +1321,17 @@ sub _determine_driver { if ($driver) { my $storage_class = "DBIx::Class::Storage::DBI::${driver}"; if ($self->load_optional_class($storage_class)) { - mro::set_mro($storage_class, 'c3'); + + no strict 'refs'; + mro::set_mro($storage_class, 'c3') if + ( + ${"${storage_class}::__INITIAL_MRO_UPON_DBIC_LOAD__"} + ||= mro::get_mro($storage_class) + ) + ne + 'c3' + ; + bless $self, $storage_class; $self->_rebless(); } @@ -1378,7 +1388,16 @@ sub _extract_driver_from_connect_info { # try to use dsn to not require being connected, the driver may still # force a connection later in _rebless to determine version # (dsn may not be supplied at all if all we do is make a mock-schema) - ($drv) = ($self->_dbi_connect_info->[0] || '') =~ /^dbi:([^:]+):/i; + # + # Use the same regex as the one used by DBI itself (even if the use of + # \w is odd given unicode): + # https://metacpan.org/source/TIMB/DBI-1.634/DBI.pm#L621 + # + # DO NOT use https://metacpan.org/source/TIMB/DBI-1.634/DBI.pm#L559-566 + # as there is a long-standing precedent of not loading DBI.pm until the + # very moment we are actually connecting + # + ($drv) = ($self->_dbi_connect_info->[0] || '') =~ /^dbi:(\w*)/i; $drv ||= $ENV{DBI_DRIVER}; } @@ -1420,12 +1439,10 @@ sub _get_rdbms_name { shift->_dbh_get_info('SQL_DBMS_NAME') } 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) + . dump_value $self->_describe_connection ); } @@ -1452,7 +1469,7 @@ sub _do_connection_actions { $self->throw_exception (sprintf ("Don't know how to process conection actions of type '%s'", ref($call)) ); } } - catch { + dbic_internal_catch { if ( $method_prefix =~ /^connect/ ) { # this is an on_connect cycle - we can't just throw while leaving # a handle in an undefined state in our storage object @@ -1602,7 +1619,7 @@ sub _connect { $dbh_error_handler_installer->($self, $dbh); } } - catch { + dbic_internal_catch { $self->throw_exception("DBI Connection failed: $_") }; @@ -1737,10 +1754,8 @@ sub _gen_sql_bind { and $op eq 'select' and - first { - length ref $_->[1] - and - blessed($_->[1]) + grep { + defined blessed($_->[1]) and $_->[1]->isa('DateTime') } @$bind @@ -1761,7 +1776,8 @@ sub _resolve_bindattrs { my $resolve_bindinfo = sub { #my $infohash = shift; - $colinfos ||= { %{ $self->_resolve_column_info($ident) } }; + # shallow copy to preempt autoviv + $colinfos ||= { %{ fromspec_columns_info($ident) } }; my $ret; if (my $col = $_[0]->{dbic_colname}) { @@ -1807,7 +1823,7 @@ sub _format_for_trace { map { defined( $_ && $_->[1] ) - ? qq{'$_->[1]'} + ? sprintf( "'%s'", "$_->[1]" ) # because overload : q{NULL} } @{$_[1] || []}; } @@ -1984,19 +2000,43 @@ sub insert { # they can be fused once again with the final return $to_insert = { %$to_insert, %$prefetched_values }; - # FIXME - we seem to assume undef values as non-supplied. This is wrong. - # Investigate what does it take to s/defined/exists/ my %pcols = map { $_ => 1 } $source->primary_columns; + my (%retrieve_cols, $autoinc_supplied, $retrieve_autoinc_col); + for my $col ($source->columns) { + + # first autoinc wins - this is why ->columns() in-order iteration is important + # + # FIXME - there ought to be a sanity-check for multiple is_auto_increment settings + # or something... + # if ($col_infos->{$col}{is_auto_increment}) { + + # FIXME - we seem to assume undef values as non-supplied. + # This is wrong. + # Investigate what does it take to s/defined/exists/ + # ( fails t/cdbi/copy.t amoong other things ) $autoinc_supplied ||= 1 if defined $to_insert->{$col}; + $retrieve_autoinc_col ||= $col unless $autoinc_supplied; } # nothing to retrieve when explicit values are supplied next if ( - defined $to_insert->{$col} and ! is_literal_value($to_insert->{$col}) + # FIXME - we seem to assume undef values as non-supplied. + # This is wrong. + # Investigate what does it take to s/defined/exists/ + # ( fails t/cdbi/copy.t amoong other things ) + defined $to_insert->{$col} + and + ( + # not a ref - cheaper to check before a call to is_literal_value() + ! length ref $to_insert->{$col} + or + # not a literal we *MAY* need to pull out ( see check below ) + ! is_literal_value( $to_insert->{$col} ) + ) ); # the 'scalar keys' is a trick to preserve the ->columns declaration order @@ -2007,6 +2047,35 @@ sub insert { ); }; + # corner case of a non-supplied PK which is *not* declared as autoinc + if ( + ! $autoinc_supplied + and + ! defined $retrieve_autoinc_col + and + # FIXME - first come-first serve, suboptimal... + ($retrieve_autoinc_col) = ( grep + { + $pcols{$_} + and + ! $col_infos->{$_}{retrieve_on_insert} + and + ! defined $col_infos->{$_}{is_auto_increment} + } + sort + { $retrieve_cols{$a} <=> $retrieve_cols{$b} } + keys %retrieve_cols + ) + ) { + carp_unique( + "Missing value for primary key column '$retrieve_autoinc_col' on " + . "@{[ $source->source_name ]} - perhaps you forgot to set its " + . "'is_auto_increment' attribute during add_columns()? Treating " + . "'$retrieve_autoinc_col' implicitly as an autoinc, and attempting " + . 'value retrieval' + ); + } + local $self->{_autoinc_supplied_for_op} = $autoinc_supplied; local $self->{_perform_autoinc_retrieval} = $retrieve_autoinc_col; @@ -2034,7 +2103,7 @@ sub insert { @ir_container = $sth->fetchrow_array; $sth->finish; - } catch { + } dbic_internal_catch { # Evict the $sth from the cache in case we got here, since the finish() # is crucial, at least on older Firebirds, possibly on other engines too # @@ -2201,13 +2270,12 @@ sub _insert_bulk { $msg, $cols->[$c_idx], do { - require Data::Dumper::Concise; local $Data::Dumper::Maxdepth = 5; - Data::Dumper::Concise::Dumper ({ + dump_value { map { $cols->[$_] => $data->[$r_idx][$_] } 0..$#$cols - }), + }; } ); }; @@ -2377,7 +2445,7 @@ sub _dbh_execute_for_fetch { $tuple_status, ); } - catch { + dbic_internal_catch { $err = shift; }; @@ -2393,7 +2461,7 @@ sub _dbh_execute_for_fetch { dbic_internal_try { $sth->finish } - catch { + dbic_internal_catch { $err = shift unless defined $err }; @@ -2404,10 +2472,9 @@ sub _dbh_execute_for_fetch { $self->throw_exception("Unexpected populate error: $err") if ($i > $#$tuple_status); - require Data::Dumper::Concise; $self->throw_exception(sprintf "execute_for_fetch() aborted with '%s' at populate slice:\n%s", ($tuple_status->[$i][1] || $err), - Data::Dumper::Concise::Dumper( { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) } ), + dump_value { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) }, ); } @@ -2425,7 +2492,7 @@ sub _dbh_execute_inserts_with_no_binds { $sth->execute foreach 1..$count; } - catch { + dbic_internal_catch { $err = shift; }; @@ -2433,7 +2500,7 @@ sub _dbh_execute_inserts_with_no_binds { dbic_internal_try { $sth->finish } - catch { + dbic_internal_catch { $err = shift unless defined $err; }; @@ -2577,8 +2644,6 @@ sub _select_args { $orig_attrs->{_last_sqlmaker_alias_map} = $attrs->{_aliastypes}; ### - # my $alias2source = $self->_resolve_ident_sources ($ident); - # # This would be the point to deflate anything found in $attrs->{where} # (and leave $attrs->{bind} intact). Problem is - inflators historically # expect a result object. And all we have is a resultsource (it is trivial @@ -2661,14 +2726,16 @@ sub _dbh_columns_info_for { $result{$col_name} = \%column_info; } - } catch { + } dbic_internal_catch { %result = (); }; return \%result if keys %result; } - my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0')); + my $sth = $dbh->prepare( + $self->sql_maker->select( $table, \'*', UNRESOLVABLE_CONDITION ) + ); $sth->execute; ### The acrobatics with lc names is necessary to support both the legacy @@ -2937,20 +3004,18 @@ them. sub create_ddl_dir { my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_; - unless ($dir) { + require DBIx::Class::Optional::Dependencies; + if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')) { + $self->throw_exception("Can't create a ddl file without $missing"); + } + + if (!$dir) { carp "No directory given, using ./\n"; $dir = './'; - } else { - -d $dir - or - (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') - ); } - - $self->throw_exception ("Directory '$dir' does not exist\n") unless(-d $dir); + else { + mkdir_p( $dir ) unless -d $dir; + } $databases ||= ['MySQL', 'SQLite', 'PostgreSQL']; $databases = [ $databases ] if(ref($databases) ne 'ARRAY'); @@ -2966,10 +3031,6 @@ sub create_ddl_dir { %{$sqltargs || {}} }; - if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')) { - $self->throw_exception("Can't create a ddl file without $missing"); - } - my $sqlt = SQL::Translator->new( $sqltargs ); $sqlt->parser('SQL::Translator::Parser::DBIx::Class'); @@ -3108,6 +3169,11 @@ See L for a list of values for C<$sqlt_args>. sub deployment_statements { my ($self, $schema, $type, $version, $dir, $sqltargs) = @_; + + $self->throw_exception( + 'Calling deployment_statements() in void context makes no sense' + ) unless defined wantarray; + $type ||= $self->sqlt_type; $version ||= $schema->schema_version || '1.x'; $dir ||= './'; @@ -3123,6 +3189,7 @@ sub deployment_statements { return join('', @rows); } + require DBIx::Class::Optional::Dependencies; if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') ) { $self->throw_exception("Can't deploy without a pregenerated 'ddl_dir' directory or $missing"); } @@ -3167,7 +3234,7 @@ sub deploy { # do a dbh_do cycle here, as we need some error checking in # place (even though we will ignore errors) $self->dbh_do (sub { $_[1]->do($line) }); - } catch { + } dbic_internal_catch { carp qq{$_ (running "${line}")}; }; $self->_query_end($line); diff --git a/lib/DBIx/Class/Storage/DBI/ACCESS.pm b/lib/DBIx/Class/Storage/DBI/ACCESS.pm index 7490d8951..2e00210b6 100644 --- a/lib/DBIx/Class/Storage/DBI/ACCESS.pm +++ b/lib/DBIx/Class/Storage/DBI/ACCESS.pm @@ -6,8 +6,6 @@ use base 'DBIx::Class::Storage::DBI::UniqueIdentifier'; use mro 'c3'; use DBI (); -use List::Util 'first'; -use namespace::clean; __PACKAGE__->sql_limit_dialect ('Top'); __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::ACCESS'); @@ -66,7 +64,7 @@ sub insert { my $columns_info = $source->columns_info; if (keys %$to_insert == 0) { - my $autoinc_col = first { + my ($autoinc_col) = grep { $columns_info->{$_}{is_auto_increment} } keys %$columns_info; diff --git a/lib/DBIx/Class/Storage/DBI/ADO.pm b/lib/DBIx/Class/Storage/DBI/ADO.pm index cfabc731f..c7c0621fd 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO.pm @@ -6,8 +6,7 @@ use strict; use base 'DBIx::Class::Storage::DBI'; use mro 'c3'; -use Sub::Name; -use DBIx::Class::_Util qw( sigwarn_silencer modver_gt_or_eq ); +use DBIx::Class::_Util qw( sigwarn_silencer modver_gt_or_eq set_subname ); use namespace::clean; =head1 NAME @@ -48,7 +47,7 @@ sub _init { no warnings 'redefine'; my $disconnect = *DBD::ADO::db::disconnect{CODE}; - *DBD::ADO::db::disconnect = subname 'DBD::ADO::db::disconnect' => sub { + *DBD::ADO::db::disconnect = set_subname 'DBD::ADO::db::disconnect' => sub { local $SIG{__WARN__} = sigwarn_silencer( qr/Not a Win32::OLE object|uninitialized value/ ); diff --git a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm index c7cb5c3fe..fbcd0eadc 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm @@ -2,12 +2,15 @@ package DBIx::Class::Storage::DBI::ADO::MS_Jet; use strict; use warnings; + use base qw/ DBIx::Class::Storage::DBI::ADO DBIx::Class::Storage::DBI::ACCESS /; use mro 'c3'; + use DBIx::Class::Storage::DBI::ADO::CursorUtils '_normalize_guids'; +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; use namespace::clean; __PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor'); @@ -104,7 +107,7 @@ sub select_single { return @row unless $self->cursor_class->isa('DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor'); - my $col_infos = $self->_resolve_column_info($ident); + my $col_infos = fromspec_columns_info($ident); _normalize_guids($select, $col_infos, \@row, $self); diff --git a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm index 8b1a78290..89ab579f4 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm @@ -4,7 +4,9 @@ use strict; use warnings; use base 'DBIx::Class::Storage::DBI::Cursor'; use mro 'c3'; + use DBIx::Class::Storage::DBI::ADO::CursorUtils '_normalize_guids'; +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; use namespace::clean; =head1 NAME @@ -41,7 +43,7 @@ sub next { _normalize_guids( $self->args->[1], - $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]), + $self->{_colinfos} ||= fromspec_columns_info($self->args->[0]), \@row, $self->storage ); @@ -56,7 +58,7 @@ sub all { _normalize_guids( $self->args->[1], - $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]), + $self->{_colinfos} ||= fromspec_columns_info($self->args->[0]), $_, $self->storage ) for @rows; 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 ac42a1eeb..33a3e1306 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm @@ -8,8 +8,10 @@ use base qw/ DBIx::Class::Storage::DBI::MSSQL /; use mro 'c3'; + use DBIx::Class::Carp; use DBIx::Class::Storage::DBI::ADO::CursorUtils qw/_normalize_guids _strip_trailing_binary_nulls/; +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; use namespace::clean; __PACKAGE__->cursor_class( @@ -140,7 +142,7 @@ sub select_single { 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor' ); - my $col_infos = $self->_resolve_column_info($ident); + my $col_infos = fromspec_columns_info($ident); _normalize_guids($select, $col_infos, \@row, $self); 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 6253ee6a5..525526bea 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 @@ -2,9 +2,12 @@ package DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor; use strict; use warnings; + use base 'DBIx::Class::Storage::DBI::Cursor'; use mro 'c3'; + use DBIx::Class::Storage::DBI::ADO::CursorUtils qw/_normalize_guids _strip_trailing_binary_nulls/; +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; use namespace::clean; =head1 NAME @@ -42,7 +45,7 @@ sub next { my @row = $self->next::method(@_); - $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]); + $self->{_colinfos} ||= fromspec_columns_info($self->args->[0]); _normalize_guids( $self->args->[1], @@ -66,7 +69,7 @@ sub all { my @rows = $self->next::method(@_); - $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]); + $self->{_colinfos} ||= fromspec_columns_info($self->args->[0]); for (@rows) { _normalize_guids( diff --git a/lib/DBIx/Class/Storage/DBI/Cursor.pm b/lib/DBIx/Class/Storage/DBI/Cursor.pm index cac152926..155855979 100644 --- a/lib/DBIx/Class/Storage/DBI/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/Cursor.pm @@ -6,7 +6,6 @@ use warnings; use base 'DBIx::Class::Cursor'; use Scalar::Util qw(refaddr weaken); -use List::Util 'shuffle'; use DBIx::Class::_Util qw( detected_reinvoked_destructor dbic_internal_try ); use namespace::clean; @@ -73,7 +72,7 @@ Returns a new L object. return $self; } - sub CLONE { + sub DBIx::Class::__DBI_Cursor_iThreads_handler__::CLONE { for (keys %cursor_registry) { # once marked we no longer care about them, hence no # need to keep in the registry, left alone renumber the @@ -183,12 +182,14 @@ sub all { (undef, $sth) = $self->storage->_select( @{$self->{args}} ); - return ( + ( DBIx::Class::_ENV_::SHUFFLE_UNORDERED_RESULTSETS and ! $self->{attrs}{order_by} + and + require List::Util ) - ? shuffle @{$sth->fetchall_arrayref} + ? List::Util::shuffle( @{$sth->fetchall_arrayref} ) : @{$sth->fetchall_arrayref} ; } diff --git a/lib/DBIx/Class/Storage/DBI/DB2.pm b/lib/DBIx/Class/Storage/DBI/DB2.pm index c34e641cb..2154c4565 100644 --- a/lib/DBIx/Class/Storage/DBI/DB2.pm +++ b/lib/DBIx/Class/Storage/DBI/DB2.pm @@ -5,8 +5,6 @@ use warnings; use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; -use Try::Tiny; -use namespace::clean; __PACKAGE__->datetime_parser_type('DateTime::Format::DB2'); __PACKAGE__->sql_quote_char ('"'); diff --git a/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm b/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm index 6e61ca5cb..e5e36ab00 100644 --- a/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm +++ b/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm @@ -4,8 +4,6 @@ use strict; use warnings; use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; -use List::Util 'first'; -use namespace::clean; =head1 NAME @@ -56,6 +54,8 @@ sub _dbh_get_autoinc_seq { $table_name = $self->sql_maker->quote_char ? $table_name : uc($table_name); local $dbh->{LongReadLen} = 100000; + + # FIXME - this is likely *WRONG* local $dbh->{LongTruncOk} = 1; my $sth = $dbh->prepare(<<'EOF'); @@ -80,7 +80,7 @@ EOF $generator = uc $generator unless $quoted; return $generator - if first { + if grep { $self->sql_maker->quote_char ? ($_ eq $col) : (uc($_) eq uc($col)) } @trig_cols; } diff --git a/lib/DBIx/Class/Storage/DBI/IdentityInsert.pm b/lib/DBIx/Class/Storage/DBI/IdentityInsert.pm index 8485e86fc..c66508d1a 100644 --- a/lib/DBIx/Class/Storage/DBI/IdentityInsert.pm +++ b/lib/DBIx/Class/Storage/DBI/IdentityInsert.pm @@ -5,8 +5,6 @@ use warnings; use base 'DBIx::Class::Storage::DBI'; use mro 'c3'; -use namespace::clean; - =head1 NAME DBIx::Class::Storage::DBI::IdentityInsert - Storage Component for Sybase ASE and diff --git a/lib/DBIx/Class/Storage/DBI/MSSQL.pm b/lib/DBIx/Class/Storage/DBI/MSSQL.pm index 4eb090a71..9a49a42db 100644 --- a/lib/DBIx/Class/Storage/DBI/MSSQL.pm +++ b/lib/DBIx/Class/Storage/DBI/MSSQL.pm @@ -9,8 +9,7 @@ use base qw/ /; use mro 'c3'; -use DBIx::Class::_Util 'dbic_internal_try'; -use List::Util 'first'; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch sigwarn_silencer ); use namespace::clean; __PACKAGE__->mk_group_accessors(simple => qw/ @@ -175,16 +174,34 @@ sub _ping { my $dbh = $self->_dbh or return 0; - local $dbh->{RaiseError} = 1; - local $dbh->{PrintError} = 0; + dbic_internal_try { + local $dbh->{RaiseError} = 1; + local $dbh->{PrintError} = 0; - (dbic_internal_try { $dbh->do('select 1'); 1; - }) - ? 1 - : 0 - ; + } + dbic_internal_catch { + # MSSQL is *really* annoying wrt multiple active resultsets, + # and this may very well be the reason why the _ping failed + # + # Proactively disconnect, while hiding annoying warnings if the case + # + # The callchain is: + # < check basic retryability prerequisites (e.g. no txn) > + # ->retry_handler + # ->storage->connected() + # ->ping + # So if we got here with the in_handler bit set - we won't break + # anything by a disconnect + if( $self->{_in_do_block_retry_handler} ) { + local $SIG{__WARN__} = sigwarn_silencer qr/disconnect invalidates .+? active statement/; + $self->disconnect; + } + + # RV of _ping itself + 0; + }; } package # hide from PAUSE diff --git a/lib/DBIx/Class/Storage/DBI/NoBindVars.pm b/lib/DBIx/Class/Storage/DBI/NoBindVars.pm index 2ca9939bd..495b3c85d 100644 --- a/lib/DBIx/Class/Storage/DBI/NoBindVars.pm +++ b/lib/DBIx/Class/Storage/DBI/NoBindVars.pm @@ -7,9 +7,6 @@ use base 'DBIx::Class::Storage::DBI'; use mro 'c3'; use DBIx::Class::SQLMaker::LimitDialects; -use List::Util qw/first/; - -use namespace::clean; =head1 NAME diff --git a/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm b/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm index 91f729222..1d549e856 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm @@ -7,8 +7,7 @@ use base qw/ DBIx::Class::Storage::DBI::Firebird::Common /; use mro 'c3'; -use Try::Tiny; -use DBIx::Class::_Util 'dbic_internal_try'; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); use namespace::clean; =head1 NAME @@ -52,7 +51,7 @@ sub _exec_svp_rollback { dbic_internal_try { $self->_dbh->do("ROLLBACK TO SAVEPOINT $name") } - catch { + dbic_internal_catch { # Firebird ODBC driver bug, ignore if (not /Unable to fetch information about the error/) { $self->throw_exception($_); 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 4ee00eb8e..8e2564410 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm @@ -8,8 +8,7 @@ use base qw/ /; use mro 'c3'; use Scalar::Util 'reftype'; -use Try::Tiny; -use DBIx::Class::_Util 'dbic_internal_try'; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); use DBIx::Class::Carp; use namespace::clean; @@ -233,7 +232,8 @@ sub _run_connection_actions { local $dbh->{RaiseError} = 1; local $dbh->{PrintError} = 0; $dbh->do('SELECT @@IDENTITY'); - } catch { + } + dbic_internal_catch { $self->throw_exception ( 'Your drivers do not seem to support dynamic cursors (odbc_cursortype => 2).' . ( diff --git a/lib/DBIx/Class/Storage/DBI/Oracle.pm b/lib/DBIx/Class/Storage/DBI/Oracle.pm index 6dd8b724e..a0961086f 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle.pm @@ -5,8 +5,6 @@ use warnings; use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; -use Try::Tiny; -use namespace::clean; sub _rebless { my ($self) = @_; diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm index 30a9f54f3..336070a0d 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm @@ -7,8 +7,7 @@ use mro 'c3'; use DBIx::Class::Carp; use Scope::Guard (); use Context::Preserve 'preserve_context'; -use List::Util 'first'; -use DBIx::Class::_Util qw( modver_gt_or_eq_and_lt dbic_internal_try ); +use DBIx::Class::_Util qw( modver_gt_or_eq modver_gt_or_eq_and_lt dbic_internal_try ); use namespace::clean; __PACKAGE__->sql_limit_dialect ('RowNum'); @@ -118,8 +117,9 @@ sub deployment_statements { sub _dbh_last_insert_id { my ($self, $dbh, $source, @columns) = @_; my @ids = (); + my $ci = $source->columns_info(\@columns); foreach my $col (@columns) { - my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col)); + my $seq = ( $ci->{$col}{sequence} ||= $self->get_autoinc_seq($source,$col)); my $id = $self->_sequence_fetch( 'CURRVAL', $seq ); push @ids, $id; } @@ -286,7 +286,7 @@ sub _dbh_execute { my ($self, $sql, $bind) = @_[0,2,3]; # Turn off sth caching for multi-part LOBs. See _prep_for_execute below - local $self->{disable_sth_caching} = 1 if first { + local $self->{disable_sth_caching} = 1 if grep { ($_->[0]{_ora_lob_autosplit_part}||0) > (__cache_queries_with_max_lob_parts - 1) @@ -298,11 +298,12 @@ sub _dbh_execute { return shift->$next(@_) if $self->transaction_depth; - # cheat the blockrunner we are just about to create - # we do want to rerun things regardless of outer state - local $self->{_in_do_block}; + # Cheat the blockrunner we are just about to create: + # We *do* want to rerun things regardless of outer state + local $self->{_in_do_block} + if $self->{_in_do_block}; - return DBIx::Class::Storage::BlockRunner->new( + DBIx::Class::Storage::BlockRunner->new( storage => $self, wrap_txn => 0, retry_handler => sub { @@ -326,10 +327,12 @@ sub _dbh_execute { } sub _dbh_execute_for_fetch { - #my ($self, $sth, $tuple_status, @extra) = @_; + #my ($self, $source, $sth, $proto_bind, $cols, $data) = @_; - # DBD::Oracle warns loudly on partial execute_for_fetch failures - local $_[1]->{PrintWarn} = 0; + # Older DBD::Oracle warns loudly on partial execute_for_fetch failures + # before https://metacpan.org/source/PYTHIAN/DBD-Oracle-1.28/Changes#L7-9 + local $_[2]->{PrintWarn} = 0 + unless modver_gt_or_eq( 'DBD::Oracle', '1.28' ); shift->next::method(@_); } diff --git a/lib/DBIx/Class/Storage/DBI/Pg.pm b/lib/DBIx/Class/Storage/DBI/Pg.pm index ded6d0698..a8fd85bc2 100644 --- a/lib/DBIx/Class/Storage/DBI/Pg.pm +++ b/lib/DBIx/Class/Storage/DBI/Pg.pm @@ -157,11 +157,40 @@ EOS return $seq_expr; } +sub _dbh_execute_for_fetch { + #my ($self, $source, $sth, $tuple_status, @extra) = @_; + + # This is used for bulk insert, so make sure we use a server-side + # prepared statement from the start, unless it's disabled + local $_[2]->{pg_switch_prepared} = 1 if + modver_gt_or_eq( 'DBD::Pg', '3.0.0' ) + and + $_[2]->FETCH('pg_switch_prepared') > 0 + ; + + shift->next::method(@_); +} sub sqlt_type { return 'PostgreSQL'; } +# Pg is not able to MAX(boolean_column), sigh... +# +# Generally it would make more sense to have this in the SQLMaker hierarchy, +# so that eventually { -max => ... } DTRT, but plans going forward are +# murky at best +# --ribasushi +# +sub _minmax_operator_for_datatype { + #my ($self, $datatype, $want_max) = @_; + + return ($_[2] ? 'BOOL_OR' : 'BOOL_AND') + if ($_[1] || '') =~ /\Abool(?:ean)?\z/i; + + shift->next::method(@_); +} + sub bind_attribute_by_data_type { my ($self,$data_type) = @_; @@ -181,6 +210,8 @@ sub bind_attribute_by_data_type { ); } elsif ( + require DBIx::Class::Optional::Dependencies + and my $missing = DBIx::Class::Optional::Dependencies->req_missing_for([qw( rdbms_pg binary_data )]) ) { # FIXME - perhaps this needs to be an exception too...? diff --git a/lib/DBIx/Class/Storage/DBI/Replicated.pm b/lib/DBIx/Class/Storage/DBI/Replicated.pm index 7d6111890..48642ece6 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated.pm @@ -18,10 +18,8 @@ use DBIx::Class::Storage::DBI::Replicated::Types qw/BalancerClassNamePart DBICSc use MooseX::Types::Moose qw/ClassName HashRef Object/; use Scalar::Util 'reftype'; use Hash::Merge; -use List::Util qw/min max reduce/; +use List::Util qw( min max ); use Context::Preserve 'preserve_context'; -use Try::Tiny; -use DBIx::Class::_Util 'dbic_internal_try'; use namespace::clean -except => 'meta'; @@ -343,6 +341,8 @@ my $method_dispatch = { _dbh_details _dbh_get_info _get_rdbms_name + _get_server_version + _server_info _determine_connector_driver _extract_driver_from_connect_info @@ -376,7 +376,8 @@ my $method_dispatch = { )], }; -if (DBIx::Class::_ENV_::DBICTEST) { +# this only happens during DBIC-internal testing +if ( $INC{"t/lib/ANFANG.pm"} ) { my $seen; for my $type (keys %$method_dispatch) { @@ -405,7 +406,10 @@ 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() may not be called on '@{[ blessed $self ]}' objects, " + . 'call it on a specific pool instance instead' + ); }); } @@ -692,19 +696,13 @@ sub execute_reliably { my $self = shift; my $coderef = shift; - unless( ref $coderef eq 'CODE') { - $self->throw_exception('Second argument must be a coderef'); - } + $self->throw_exception('Second argument must be a coderef') + unless( ref $coderef eq 'CODE'); ## replace the current read handler for the remainder of the scope local $self->{read_handler} = $self->master; - my $args = \@_; - return dbic_internal_try { - $coderef->(@$args); - } catch { - $self->throw_exception("coderef returned an error: $_"); - }; + &$coderef; } =head2 set_reliable_storage @@ -1054,35 +1052,6 @@ sub _ping { return min map $_->_ping, $self->all_storages; } -# not using the normalized_version, because we want to preserve -# version numbers much longer than the conventional xxx.yyyzzz -my $numify_ver = sub { - my $ver = shift; - my @numparts = split /\D+/, $ver; - my $format = '%d.' . (join '', ('%06d') x (@numparts - 1)); - - return sprintf $format, @numparts; -}; -sub _server_info { - my $self = shift; - - if (not $self->_dbh_details->{info}) { - $self->_dbh_details->{info} = ( - reduce { $a->[0] < $b->[0] ? $a : $b } - map [ $numify_ver->($_->{dbms_version}), $_ ], - map $_->_server_info, $self->all_storages - )->[1]; - } - - return $self->next::method; -} - -sub _get_server_version { - my $self = shift; - - return $self->_server_info->{dbms_version}; -} - =head1 GOTCHAS Due to the fact that replicants can lag behind a master, you must take care to diff --git a/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm b/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm index 6b430f466..f06875e16 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm @@ -20,10 +20,6 @@ Given a pool (L) of replicated database's (L), defines a method by which query load can be spread out across each replicant in the pool. -This Balancer uses L keyword 'shuffle' to randomly pick an active -replicant from the associated pool. This may or may not be random enough for -you, patches welcome. - =head1 ATTRIBUTES This class defines the following attributes. diff --git a/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm b/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm index 7c82d28c1..cea37884c 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm @@ -2,13 +2,11 @@ package DBIx::Class::Storage::DBI::Replicated::Pool; use Moose; use DBIx::Class::Storage::DBI::Replicated::Replicant; -use List::Util 'sum'; use Scalar::Util 'reftype'; use DBI (); use MooseX::Types::Moose qw/Num Int ClassName HashRef/; use DBIx::Class::Storage::DBI::Replicated::Types 'DBICStorageDBI'; -use DBIx::Class::_Util 'dbic_internal_try'; -use Try::Tiny; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); use namespace::clean -except => 'meta'; @@ -294,14 +292,17 @@ Returns 1 on success and undef on failure. sub _safely { my ($self, $replicant, $name, $code) = @_; - return dbic_internal_try { + dbic_internal_try { $code->(); 1; - } catch { + } + dbic_internal_catch { $replicant->debugobj->print(sprintf( "Exception trying to $name for replicant %s, error is %s", $replicant->_dbi_connect_info->[0], $_) ); + + # rv undef; }; } @@ -323,10 +324,10 @@ is actually connected, try not to hit this 10 times a second. =cut sub connected_replicants { - my $self = shift @_; - return sum( map { - $_->connected ? 1:0 - } $self->all_replicants ); + return scalar grep + { $_->connected } + shift->all_replicants + ; } =head2 active_replicants diff --git a/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm b/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm index 3d054bb19..9cb830663 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm @@ -4,9 +4,8 @@ use strict; use warnings; use base qw/DBIx::Class::Storage::DBI::UniqueIdentifier/; use mro 'c3'; -use List::Util 'first'; use DBIx::Class::_Util 'dbic_internal_try'; -use Try::Tiny; +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; use namespace::clean; __PACKAGE__->mk_group_accessors(simple => qw/_identity/); @@ -50,8 +49,8 @@ sub _prefetch_autovalues { my $values = $self->next::method(@_); - my $identity_col = - first { $colinfo->{$_}{is_auto_increment} } keys %$colinfo; + my ($identity_col) = + grep { $colinfo->{$_}{is_auto_increment} } keys %$colinfo; # user might have an identity PK without is_auto_increment # @@ -114,7 +113,7 @@ sub select_single { my ($ident, $select) = @_; - my $col_info = $self->_resolve_column_info($ident); + my $col_info = fromspec_columns_info($ident); for my $select_idx (0..$#$select) { my $selected = $select->[$select_idx]; @@ -136,18 +135,11 @@ sub select_single { return @row; } -# this sub stolen from MSSQL - sub build_datetime_parser { - my $self = shift; - dbic_internal_try { - require DateTime::Format::Strptime; - } - catch { - $self->throw_exception("Couldn't load DateTime::Format::Strptime: $_"); - }; - return DateTime::Format::Strptime->new( pattern => '%Y-%m-%d %H:%M:%S.%6N' ); + require DateTime::Format::Strptime; + + DateTime::Format::Strptime->new( pattern => '%Y-%m-%d %H:%M:%S.%6N' ); } =head2 connect_call_datetime_setup diff --git a/lib/DBIx/Class/Storage/DBI/SQLAnywhere/Cursor.pm b/lib/DBIx/Class/Storage/DBI/SQLAnywhere/Cursor.pm index a341b20f4..8fb08a956 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLAnywhere/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLAnywhere/Cursor.pm @@ -5,6 +5,9 @@ use warnings; use base 'DBIx::Class::Storage::DBI::Cursor'; use mro 'c3'; +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; +use namespace::clean; + =head1 NAME DBIx::Class::Storage::DBI::SQLAnywhere::Cursor - GUID Support for SQL Anywhere @@ -61,7 +64,7 @@ sub next { $unpack_guids->( $self->args->[1], - $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]), + $self->{_colinfos} ||= fromspec_columns_info($self->args->[0]), \@row, $self->storage ); @@ -76,7 +79,7 @@ sub all { $unpack_guids->( $self->args->[1], - $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]), + $self->{_colinfos} ||= fromspec_columns_info($self->args->[0]), $_, $self->storage ) for @rows; diff --git a/lib/DBIx/Class/Storage/DBI/SQLite.pm b/lib/DBIx/Class/Storage/DBI/SQLite.pm index 28e9a087e..714b1073b 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLite.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLite.pm @@ -7,9 +7,11 @@ use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; use SQL::Abstract 'is_plain_value'; -use DBIx::Class::_Util qw(modver_gt_or_eq sigwarn_silencer dbic_internal_try); +use DBIx::Class::_Util qw( + modver_gt_or_eq sigwarn_silencer + dbic_internal_try dbic_internal_catch +); use DBIx::Class::Carp; -use Try::Tiny; use namespace::clean; __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::SQLite'); @@ -63,7 +65,7 @@ Even if you upgrade DBIx::Class (which works around the bug starting from version 0.08210) you may still have corrupted/incorrect data in your database. DBIx::Class warned about this condition for several years, hoping to give anyone affected sufficient notice of the potential issues. The warning was -removed in version 0.082900. +removed in 2015/v0.082820. =back @@ -123,22 +125,17 @@ sub _exec_svp_rollback { my ($self, $name) = @_; $self->_dbh->do("ROLLBACK TO SAVEPOINT $name"); -} - -# older SQLite has issues here too - both of these are in fact -# completely benign warnings (or at least so say the tests) -sub _exec_txn_rollback { - local $SIG{__WARN__} = sigwarn_silencer( qr/rollback ineffective/ ) - unless $DBD::SQLite::__DBIC_TXN_SYNC_SANE__; - - shift->next::method(@_); -} - -sub _exec_txn_commit { - local $SIG{__WARN__} = sigwarn_silencer( qr/commit ineffective/ ) - unless $DBD::SQLite::__DBIC_TXN_SYNC_SANE__; - shift->next::method(@_); + # resync state for older DBD::SQLite (RT#67843) + # https://github.com/DBD-SQLite/DBD-SQLite/commit/9b3cdbf + if ( + ! modver_gt_or_eq('DBD::SQLite', '1.33') + and + $self->_dbh->FETCH('AutoCommit') + ) { + $self->_dbh->STORE('AutoCommit', 0); + $self->_dbh->STORE('BegunWork', 1); + } } sub _ping { @@ -186,7 +183,7 @@ sub _ping { $really_not_in_txn = 1; } - catch { + dbic_internal_catch { $really_not_in_txn = ( $_[0] =~ qr/transaction within a transaction/ ? 0 : undef diff --git a/lib/DBIx/Class/Storage/DBI/Sybase.pm b/lib/DBIx/Class/Storage/DBI/Sybase.pm index 9072b3869..a71426813 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase.pm @@ -2,8 +2,7 @@ package DBIx::Class::Storage::DBI::Sybase; use strict; use warnings; -use DBIx::Class::_Util 'dbic_internal_try'; -use Try::Tiny; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); use namespace::clean; use base qw/DBIx::Class::Storage::DBI/; @@ -38,7 +37,8 @@ sub _get_rdbms_name { } $name; # RV - } catch { + } + dbic_internal_catch { $self->throw_exception("Unable to establish connection to determine database type: $_") }; } @@ -76,27 +76,10 @@ sub _ping { local $dbh->{RaiseError} = 1; local $dbh->{PrintError} = 0; -# FIXME if the main connection goes stale, does opening another for this statement -# really determine anything? -# FIXME (2) THIS MAKES 0 SENSE!!! Need to test later - if ($dbh->{syb_no_child_con}) { - return dbic_internal_try { - $self->_connect->do('select 1'); - 1; - } - catch { - 0; - }; - } - - return ( - (dbic_internal_try { - $dbh->do('select 1'); - 1; - }) - ? 1 - : 0 - ); + ( dbic_internal_try { $dbh->do('select 1'); 1 } ) + ? 1 + : 0 + ; } sub _set_max_connect { diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm index 3479ff34e..fde0b7301 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm @@ -11,12 +11,11 @@ use base qw/ use mro 'c3'; use DBIx::Class::Carp; use Scalar::Util qw/blessed weaken/; -use List::Util 'first'; -use Sub::Name(); -use Data::Dumper::Concise 'Dumper'; -use Try::Tiny; use Context::Preserve 'preserve_context'; -use DBIx::Class::_Util qw( sigwarn_silencer dbic_internal_try ); +use DBIx::Class::_Util qw( + sigwarn_silencer dbic_internal_try dbic_internal_catch + dump_value scope_guard set_subname +); use namespace::clean; __PACKAGE__->sql_limit_dialect ('GenericSubQ'); @@ -166,7 +165,7 @@ for my $method (@also_proxy_to_extra_storages) { my $replaced = __PACKAGE__->can($method); - *{$method} = Sub::Name::subname $method => sub { + *{$method} = set_subname $method => sub { my $self = shift; $self->_writer_storage->$replaced(@_) if $self->_writer_storage; $self->_bulk_storage->$replaced(@_) if $self->_bulk_storage; @@ -250,7 +249,9 @@ sub connect_call_blob_setup { sub _is_lob_column { my ($self, $source, $column) = @_; - return $self->_is_lob_type($source->column_info($column)->{data_type}); + return $self->_is_lob_type( + $source->columns_info([$column])->{$column}{data_type} + ); } sub _prep_for_execute { @@ -360,15 +361,28 @@ sub insert { # try to insert explicit 'DEFAULT's instead (except for identity, timestamp # and computed columns) if (not %$to_insert) { + + my $ci; + # same order as add_columns for my $col ($source->columns) { next if $col eq $identity_col; - my $info = $source->column_info($col); - - next if ref $info->{default_value} eq 'SCALAR' - || (exists $info->{data_type} && (not defined $info->{data_type})); - - next if $info->{data_type} && $info->{data_type} =~ /^timestamp\z/i; + my $info = ( $ci ||= $source->columns_info )->{$col}; + + next if ( + ref $info->{default_value} eq 'SCALAR' + or + ( + exists $info->{data_type} + and + ! defined $info->{data_type} + ) + or + ( + ( $info->{data_type} || '' ) + =~ /^timestamp\z/i + ) + ); $to_insert->{$col} = \'DEFAULT'; } @@ -448,10 +462,10 @@ sub update { if (keys %$fields) { # Now set the identity update flags for the actual update - local $self->{_autoinc_supplied_for_op} = (first + local $self->{_autoinc_supplied_for_op} = grep { $_->{is_auto_increment} } values %{ $source->columns_info([ keys %$fields ]) } - ) ? 1 : 0; + ; my $next = $self->next::can; my $args = \@_; @@ -466,10 +480,10 @@ sub update { } else { # Set the identity update flags for the actual update - local $self->{_autoinc_supplied_for_op} = (first + local $self->{_autoinc_supplied_for_op} = grep { $_->{is_auto_increment} } values %{ $source->columns_info([ keys %$fields ]) } - ) ? 1 : 0; + ; return $self->next::method(@_); } @@ -481,17 +495,14 @@ sub _insert_bulk { my $columns_info = $source->columns_info; - my $identity_col = - first { $columns_info->{$_}{is_auto_increment} } + my ($identity_col) = + grep { $columns_info->{$_}{is_auto_increment} } keys %$columns_info; # FIXME - this is duplication from DBI.pm. When refactored towards # the LobWriter this can be folded back where it belongs. - local $self->{_autoinc_supplied_for_op} = - (first { $_ eq $identity_col } @$cols) - ? 1 - : 0 - ; + local $self->{_autoinc_supplied_for_op} + = grep { $_ eq $identity_col } @$cols; my $use_bulk_api = $self->_bulk_storage && @@ -554,7 +565,7 @@ sub _insert_bulk { my @source_columns = $source->columns; # bcp identity index is 1-based - my $identity_idx = first { $source_columns[$_] eq $identity_col } (0..$#source_columns); + my ($identity_idx) = grep { $source_columns[$_] eq $identity_col } (0..$#source_columns); $identity_idx = defined $identity_idx ? $identity_idx + 1 : 0; my @new_data; @@ -581,7 +592,7 @@ sub _insert_bulk { # This ignores any data conversion errors detected by the client side libs, as # they are usually harmless. my $orig_cslib_cb = DBD::Sybase::set_cslib_cb( - Sub::Name::subname _insert_bulk_cslib_errhandler => sub { + set_subname _insert_bulk_cslib_errhandler => sub { my ($layer, $origin, $severity, $errno, $errmsg, $osmsg, $blkmsg) = @_; return 1 if $errno == 36; @@ -644,8 +655,9 @@ sub _insert_bulk { $guard->commit; $bulk->_query_end($sql); - } catch { - $exception = shift; + } + dbic_internal_catch { + $exception = $_; }; DBD::Sybase::set_cslib_cb($orig_cslib_cb); @@ -722,11 +734,14 @@ sub _remove_blob_cols_array { sub _update_blobs { my ($self, $source, $blob_cols, $where) = @_; - my @primary_cols = dbic_internal_try - { $source->_pri_cols_or_die } - catch { + my @primary_cols = + dbic_internal_try { + $source->_pri_cols_or_die + } + dbic_internal_catch { $self->throw_exception("Cannot update TEXT/IMAGE column(s): $_") - }; + } + ; my @pks_to_update; if ( @@ -757,7 +772,7 @@ sub _insert_blobs { my @primary_cols = dbic_internal_try { $source->_pri_cols_or_die } - catch { + dbic_internal_catch { $self->throw_exception("Cannot update TEXT/IMAGE column(s): $_") }; @@ -781,10 +796,16 @@ sub _insert_blobs { if (not $sth) { $self->throw_exception( "Could not find row in table '$table' for blob update:\n" - . (Dumper \%where) + . dump_value \%where ); } + # FIXME - it is not clear if this is needed at all. But it's been + # there since 2009 ( d867eedaa ), might as well let sleeping dogs + # lie... sigh. + weaken( my $wsth = $sth ); + my $g = scope_guard { $wsth->finish if $wsth }; + dbic_internal_try { do { $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr; @@ -804,7 +825,7 @@ sub _insert_blobs { $sth->func('ct_finish_send') or die $sth->errstr; } - catch { + dbic_internal_catch { if ($self->_using_freetds) { $self->throw_exception ( "TEXT/IMAGE operation failed, probably because you are using FreeTDS: $_" @@ -813,9 +834,6 @@ sub _insert_blobs { else { $self->throw_exception($_); } - } - finally { - $sth->finish if $sth; }; } } diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm index ffd72c4be..3ee6cdbef 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm @@ -8,7 +8,6 @@ use base qw/ DBIx::Class::Storage::DBI::Sybase::ASE /; use mro 'c3'; -use List::Util 'first'; use Scalar::Util 'looks_like_number'; use namespace::clean; @@ -42,7 +41,7 @@ sub interpolate_unquoted { return $self->next::method(@_) if not defined $value or not defined $type; - if (my $key = first { $type =~ /$_/i } keys %noquote) { + if (my ($key) = grep { $type =~ /$_/i } keys %noquote) { return 1 if $noquote{$key}->($value); } elsif ($self->is_datatype_numeric($type) && $number->($value)) { diff --git a/lib/DBIx/Class/Storage/DBI/mysql.pm b/lib/DBIx/Class/Storage/DBI/mysql.pm index 1e76d6bcb..7d0ad04f9 100644 --- a/lib/DBIx/Class/Storage/DBI/mysql.pm +++ b/lib/DBIx/Class/Storage/DBI/mysql.pm @@ -5,8 +5,6 @@ use warnings; use base qw/DBIx::Class::Storage::DBI/; -use namespace::clean; - __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::MySQL'); __PACKAGE__->sql_limit_dialect ('LimitXY'); __PACKAGE__->sql_quote_char ('`'); diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm index 14410b700..75438d042 100644 --- a/lib/DBIx/Class/Storage/DBIHacks.pm +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -5,7 +5,7 @@ package #hide from PAUSE # This module contains code supporting a battery of special cases and tests for # many corner cases pushing the envelope of what DBIC can do. When work on # these utilities began in mid 2009 (51a296b402c) it wasn't immediately obvious -# that these pieces, despite their misleading on-first-sighe-flakiness, will +# that these pieces, despite their misleading on-first-sight-flakiness, will # become part of the generic query rewriting machinery of DBIC, allowing it to # both generate and process queries representing incredibly complex sets with # reasonable efficiency. @@ -28,10 +28,15 @@ use warnings; use base 'DBIx::Class::Storage'; use mro 'c3'; -use List::Util 'first'; use Scalar::Util 'blessed'; -use DBIx::Class::_Util qw(UNRESOLVABLE_CONDITION serialize); -use SQL::Abstract qw(is_plain_value is_literal_value); +use DBIx::Class::_Util qw( + dump_value fail_on_internal_call +); +use DBIx::Class::SQLMaker::Util 'extract_equality_conditions'; +use DBIx::Class::ResultSource::FromSpec::Util qw( + fromspec_columns_info + find_join_path_to_alias +); use DBIx::Class::Carp; use namespace::clean; @@ -166,7 +171,7 @@ sub _adjust_select_args_for_complex_prefetch { unless $root_node; # use the heavy duty resolver to take care of aliased/nonaliased naming - my $colinfo = $self->_resolve_column_info($inner_attrs->{from}); + my $colinfo = fromspec_columns_info($inner_attrs->{from}); my $selected_root_columns; for my $i (0 .. $#{$outer_attrs->{select}}) { @@ -229,7 +234,8 @@ sub _adjust_select_args_for_complex_prefetch { my $inner_subq = do { # must use it here regardless of user requests (vastly gentler on optimizer) - local $self->{_use_join_optimizer} = 1; + local $self->{_use_join_optimizer} = 1 + unless $self->{_use_join_optimizer}; # throw away multijoins since we def. do not care about those inside the subquery # $inner_aliastypes *will* be redefined at this point @@ -344,7 +350,7 @@ sub _adjust_select_args_for_complex_prefetch { ) { push @outer_from, $j } - elsif (first { $_->{$alias} } @outer_nonselecting_chains ) { + elsif (grep { $_->{$alias} } @outer_nonselecting_chains ) { push @outer_from, $j; $may_need_outer_group_by ||= $outer_aliastypes->{multiplying}{$alias} ? 1 : 0; } @@ -442,7 +448,7 @@ sub _resolve_aliastypes_from_select_args { } # get a column to source/alias map (including unambiguous unqualified ones) - my $colinfo = $self->_resolve_column_info ($attrs->{from}); + my $colinfo = fromspec_columns_info($attrs->{from}); # set up a botched SQLA my $sql_maker = $self->sql_maker; @@ -493,7 +499,11 @@ sub _resolve_aliastypes_from_select_args { grep { $_ !~ / \A \s* \( \s* SELECT \s+ .+? \s+ FROM \s+ .+? \) \s* \z /xsi } map - { ($sql_maker->_recurse_fields($_))[0] } + { + length ref $_ + ? ($sql_maker->_recurse_fields($_))[0] + : $sql_maker->_quote($_) + } @{$attrs->{select}} ], ordering => [ map @@ -513,9 +523,9 @@ sub _resolve_aliastypes_from_select_args { ( $_ = join ' ', map { ( ! defined $_ ) ? () - : ( length ref $_ ) ? (require Data::Dumper::Concise && $self->throw_exception( - "Unexpected ref in scan-plan: " . Data::Dumper::Concise::Dumper($_) - )) + : ( length ref $_ ) ? $self->throw_exception( + "Unexpected ref in scan-plan: " . dump_value $_ + ) : ( $_ =~ /^\s*$/ ) ? () : $_ @@ -631,7 +641,7 @@ sub _resolve_aliastypes_from_select_args { sub _group_over_selection { my ($self, $attrs) = @_; - my $colinfos = $self->_resolve_column_info ($attrs->{from}); + my $colinfos = fromspec_columns_info($attrs->{from}); my (@group_by, %group_index); @@ -720,6 +730,8 @@ sub _group_over_selection { # for DESC, and group_by the root columns. The end result should be # exactly what we expect # + + # both populated on the first loop over $o_idx $sql_maker ||= $self->sql_maker; $order_chunks ||= [ map { ref $_ eq 'ARRAY' ? $_ : [ $_ ] } $sql_maker->_order_by_chunks($attrs->{order_by}) @@ -731,7 +743,7 @@ sub _group_over_selection { # to an ordering alias into a MIN/MAX $new_order_by[$o_idx] = \[ sprintf( '%s( %s )%s', - ($is_desc ? 'MAX' : 'MIN'), + $self->_minmax_operator_for_datatype($chunk_ci->{data_type}, $is_desc), $chunk, ($is_desc ? ' DESC' : ''), ), @@ -759,179 +771,10 @@ sub _group_over_selection { ); } -sub _resolve_ident_sources { - my ($self, $ident) = @_; - - my $alias2source = {}; - - # the reason this is so contrived is that $ident may be a {from} - # structure, specifying multiple tables to join - if ( blessed $ident && $ident->isa("DBIx::Class::ResultSource") ) { - # this is compat mode for insert/update/delete which do not deal with aliases - $alias2source->{me} = $ident; - } - elsif (ref $ident eq 'ARRAY') { - - for (@$ident) { - my $tabinfo; - if (ref $_ eq 'HASH') { - $tabinfo = $_; - } - if (ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH') { - $tabinfo = $_->[0]; - } - - $alias2source->{$tabinfo->{-alias}} = $tabinfo->{-rsrc} - if ($tabinfo->{-rsrc}); - } - } +sub _minmax_operator_for_datatype { + #my ($self, $datatype, $want_max) = @_; - return $alias2source; -} - -# Takes $ident, \@column_names -# -# returns { $column_name => \%column_info, ... } -# also note: this adds -result_source => $rsrc to the column info -# -# If no columns_names are supplied returns info about *all* columns -# for all sources -sub _resolve_column_info { - my ($self, $ident, $colnames) = @_; - - return {} if $colnames and ! @$colnames; - - my $sources = $self->_resolve_ident_sources($ident); - - $_ = { rsrc => $_, colinfos => $_->columns_info } - for values %$sources; - - my (%seen_cols, @auto_colnames); - - # compile a global list of column names, to be able to properly - # disambiguate unqualified column names (if at all possible) - for my $alias (keys %$sources) { - ( - ++$seen_cols{$_}{$alias} - and - ! $colnames - and - push @auto_colnames, "$alias.$_" - ) for keys %{ $sources->{$alias}{colinfos} }; - } - - $colnames ||= [ - @auto_colnames, - ( grep { keys %{$seen_cols{$_}} == 1 } keys %seen_cols ), - ]; - - my %return; - for (@$colnames) { - my ($colname, $source_alias) = reverse split /\./, $_; - - my $assumed_alias = - $source_alias - || - # if the column was seen exactly once - we know which rsrc it came from - ( - $seen_cols{$colname} - and - keys %{$seen_cols{$colname}} == 1 - and - ( %{$seen_cols{$colname}} )[0] - ) - || - next - ; - - $self->throw_exception( - "No such column '$colname' on source " . $sources->{$assumed_alias}{rsrc}->source_name - ) unless $seen_cols{$colname}{$assumed_alias}; - - $return{$_} = { - %{ $sources->{$assumed_alias}{colinfos}{$colname} }, - -result_source => $sources->{$assumed_alias}{rsrc}, - -source_alias => $assumed_alias, - -fq_colname => "$assumed_alias.$colname", - -colname => $colname, - }; - - $return{"$assumed_alias.$colname"} = $return{$_} - unless $source_alias; - } - - return \%return; -} - -# The DBIC relationship chaining implementation is pretty simple - every -# new related_relationship is pushed onto the {from} stack, and the {select} -# window simply slides further in. This means that when we count somewhere -# in the middle, we got to make sure that everything in the join chain is an -# actual inner join, otherwise the count will come back with unpredictable -# results (a resultset may be generated with _some_ rows regardless of if -# the relation which the $rs currently selects has rows or not). E.g. -# $artist_rs->cds->count - normally generates: -# SELECT COUNT( * ) FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid -# which actually returns the number of artists * (number of cds || 1) -# -# So what we do here is crawl {from}, determine if the current alias is at -# the top of the stack, and if not - make sure the chain is inner-joined down -# to the root. -# -sub _inner_join_to_node { - my ($self, $from, $alias) = @_; - - my $switch_branch = $self->_find_join_path_to_node($from, $alias); - - return $from unless @{$switch_branch||[]}; - - # So it looks like we will have to switch some stuff around. - # local() is useless here as we will be leaving the scope - # anyway, and deep cloning is just too fucking expensive - # So replace the first hashref in the node arrayref manually - my @new_from = ($from->[0]); - my $sw_idx = { map { (values %$_), 1 } @$switch_branch }; #there's one k/v per join-path - - for my $j (@{$from}[1 .. $#$from]) { - my $jalias = $j->[0]{-alias}; - - if ($sw_idx->{$jalias}) { - my %attrs = %{$j->[0]}; - delete $attrs{-join_type}; - push @new_from, [ - \%attrs, - @{$j}[ 1 .. $#$j ], - ]; - } - else { - push @new_from, $j; - } - } - - return \@new_from; -} - -sub _find_join_path_to_node { - my ($self, $from, $target_alias) = @_; - - # subqueries and other oddness are naturally not supported - return undef if ( - ref $from ne 'ARRAY' - || - ref $from->[0] ne 'HASH' - || - ! defined $from->[0]{-alias} - ); - - # no path - the head is the alias - return [] if $from->[0]{-alias} eq $target_alias; - - for my $i (1 .. $#$from) { - return $from->[$i][0]{-join_path} if ( ($from->[$i][0]{-alias}||'') eq $target_alias ); - } - - # something else went quite wrong - return undef; + $_[2] ? 'MAX' : 'MIN'; } sub _extract_order_criteria { @@ -984,10 +827,10 @@ sub _order_by_is_stable { my @cols = ( ( map { $_->[0] } $self->_extract_order_criteria($order_by) ), - ( $where ? keys %{ $self->_extract_fixed_condition_columns($where) } : () ), + ( $where ? keys %{ extract_equality_conditions( $where ) } : () ), ) or return 0; - my $colinfo = $self->_resolve_column_info($ident, \@cols); + my $colinfo = fromspec_columns_info($ident, \@cols); return keys %$colinfo ? $self->_columns_comprise_identifying_set( $colinfo, \@cols ) @@ -1017,7 +860,7 @@ sub _columns_comprise_identifying_set { sub _extract_colinfo_of_stable_main_source_order_by_portion { my ($self, $attrs) = @_; - my $nodes = $self->_find_join_path_to_node($attrs->{from}, $attrs->{alias}); + my $nodes = find_join_path_to_alias($attrs->{from}, $attrs->{alias}); return unless defined $nodes; @@ -1032,7 +875,7 @@ sub _extract_colinfo_of_stable_main_source_order_by_portion { map { values %$_ } @$nodes, ) }; - my $colinfos = $self->_resolve_column_info($attrs->{from}); + my $colinfos = fromspec_columns_info($attrs->{from}); my ($colinfos_to_return, $seen_main_src_cols); @@ -1049,9 +892,9 @@ sub _extract_colinfo_of_stable_main_source_order_by_portion { if $colinfo->{-source_alias} eq $attrs->{alias}; } - # FIXME the condition may be singling out things on its own, so we - # conceivable could come back wi "stable-ordered by nothing" - # not confient enough in the parser yet, so punt for the time being + # FIXME: the condition may be singling out things on its own, so we + # conceivably could come back with "stable-ordered by nothing" + # not confident enough in the parser yet, so punt for the time being return unless $seen_main_src_cols; my $main_src_fixed_cols_from_cond = [ $attrs->{where} @@ -1062,7 +905,7 @@ sub _extract_colinfo_of_stable_main_source_order_by_portion { ? $colinfos->{$_}{-colname} : () } - keys %{ $self->_extract_fixed_condition_columns($attrs->{where}) } + keys %{ extract_equality_conditions( $attrs->{where} ) } ) : () ]; @@ -1073,435 +916,48 @@ sub _extract_colinfo_of_stable_main_source_order_by_portion { ]) ? $colinfos_to_return : (); } -# Attempts to flatten a passed in SQLA condition as much as possible towards -# a plain hashref, *without* altering its semantics. Required by -# create/populate being able to extract definitive conditions from preexisting -# resultset {where} stacks -# -# FIXME - while relatively robust, this is still imperfect, one of the first -# things to tackle when we get access to a formalized AST. Note that this code -# is covered by a *ridiculous* amount of tests, so starting with porting this -# code would be a rather good exercise -sub _collapse_cond { - my ($self, $where, $where_is_anded_array) = @_; - - my $fin; +sub _resolve_column_info :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + carp_unique("_resolve_column_info() is deprecated, ask on IRC for a better alternative"); - if (! $where) { - return; - } - elsif ($where_is_anded_array or ref $where eq 'HASH') { - - my @pairs; - - my @pieces = $where_is_anded_array ? @$where : $where; - while (@pieces) { - my $chunk = shift @pieces; - - if (ref $chunk eq 'HASH') { - for (sort keys %$chunk) { - - # Match SQLA 1.79 behavior - unless( length $_ ) { - is_literal_value($chunk->{$_}) - ? carp 'Hash-pairs consisting of an empty string with a literal are deprecated, use -and => [ $literal ] instead' - : $self->throw_exception("Supplying an empty left hand side argument is not supported in hash-pairs") - ; - } - - push @pairs, $_ => $chunk->{$_}; - } - } - elsif (ref $chunk eq 'ARRAY') { - push @pairs, -or => $chunk - if @$chunk; - } - elsif ( ! length ref $chunk) { - - # Match SQLA 1.79 behavior - $self->throw_exception("Supplying an empty left hand side argument is not supported in array-pairs") - if $where_is_anded_array and (! defined $chunk or ! length $chunk); - - push @pairs, $chunk, shift @pieces; - } - else { - push @pairs, '', $chunk; - } - } - - return unless @pairs; - - my @conds = $self->_collapse_cond_unroll_pairs(\@pairs) - or return; - - # Consolidate various @conds back into something more compact - for my $c (@conds) { - if (ref $c ne 'HASH') { - push @{$fin->{-and}}, $c; - } - else { - for my $col (sort keys %$c) { - - # consolidate all -and nodes - if ($col =~ /^\-and$/i) { - push @{$fin->{-and}}, - ref $c->{$col} eq 'ARRAY' ? @{$c->{$col}} - : ref $c->{$col} eq 'HASH' ? %{$c->{$col}} - : { $col => $c->{$col} } - ; - } - elsif ($col =~ /^\-/) { - push @{$fin->{-and}}, { $col => $c->{$col} }; - } - elsif (exists $fin->{$col}) { - $fin->{$col} = [ -and => map { - (ref $_ eq 'ARRAY' and ($_->[0]||'') =~ /^\-and$/i ) - ? @{$_}[1..$#$_] - : $_ - ; - } ($fin->{$col}, $c->{$col}) ]; - } - else { - $fin->{$col} = $c->{$col}; - } - } - } - } - } - elsif (ref $where eq 'ARRAY') { - # we are always at top-level here, it is safe to dump empty *standalone* pieces - my $fin_idx; - - for (my $i = 0; $i <= $#$where; $i++ ) { - - # Match SQLA 1.79 behavior - $self->throw_exception( - "Supplying an empty left hand side argument is not supported in array-pairs" - ) if (! defined $where->[$i] or ! length $where->[$i]); - - my $logic_mod = lc ( ($where->[$i] =~ /^(\-(?:and|or))$/i)[0] || '' ); - - if ($logic_mod) { - $i++; - $self->throw_exception("Unsupported top-level op/arg pair: [ $logic_mod => $where->[$i] ]") - unless ref $where->[$i] eq 'HASH' or ref $where->[$i] eq 'ARRAY'; - - my $sub_elt = $self->_collapse_cond({ $logic_mod => $where->[$i] }) - or next; - - my @keys = keys %$sub_elt; - if ( @keys == 1 and $keys[0] !~ /^\-/ ) { - $fin_idx->{ "COL_$keys[0]_" . serialize $sub_elt } = $sub_elt; - } - else { - $fin_idx->{ "SER_" . serialize $sub_elt } = $sub_elt; - } - } - elsif (! length ref $where->[$i] ) { - my $sub_elt = $self->_collapse_cond({ @{$where}[$i, $i+1] }) - or next; - - $fin_idx->{ "COL_$where->[$i]_" . serialize $sub_elt } = $sub_elt; - $i++; - } - else { - $fin_idx->{ "SER_" . serialize $where->[$i] } = $self->_collapse_cond( $where->[$i] ) || next; - } - } - - if (! $fin_idx) { - return; - } - elsif ( keys %$fin_idx == 1 ) { - $fin = (values %$fin_idx)[0]; - } - else { - my @or; - - # at this point everything is at most one level deep - unroll if needed - for (sort keys %$fin_idx) { - if ( ref $fin_idx->{$_} eq 'HASH' and keys %{$fin_idx->{$_}} == 1 ) { - my ($l, $r) = %{$fin_idx->{$_}}; - - if ( - ref $r eq 'ARRAY' - and - ( - ( @$r == 1 and $l =~ /^\-and$/i ) - or - $l =~ /^\-or$/i - ) - ) { - push @or, @$r - } - - elsif ( - ref $r eq 'HASH' - and - keys %$r == 1 - and - $l =~ /^\-(?:and|or)$/i - ) { - push @or, %$r; - } - - else { - push @or, $l, $r; - } - } - else { - push @or, $fin_idx->{$_}; - } - } - - $fin->{-or} = \@or; - } - } - else { - # not a hash not an array - $fin = { -and => [ $where ] }; - } - - # unroll single-element -and's - while ( - $fin->{-and} - and - @{$fin->{-and}} < 2 - ) { - my $and = delete $fin->{-and}; - last if @$and == 0; - - # at this point we have @$and == 1 - if ( - ref $and->[0] eq 'HASH' - and - ! grep { exists $fin->{$_} } keys %{$and->[0]} - ) { - $fin = { - %$fin, %{$and->[0]} - }; - } - else { - $fin->{-and} = $and; - last; - } - } - - # compress same-column conds found in $fin - for my $col ( grep { $_ !~ /^\-/ } keys %$fin ) { - next unless ref $fin->{$col} eq 'ARRAY' and ($fin->{$col}[0]||'') =~ /^\-and$/i; - my $val_bag = { map { - (! defined $_ ) ? ( UNDEF => undef ) - : ( ! length ref $_ or is_plain_value $_ ) ? ( "VAL_$_" => $_ ) - : ( ( 'SER_' . serialize $_ ) => $_ ) - } @{$fin->{$col}}[1 .. $#{$fin->{$col}}] }; - - if (keys %$val_bag == 1 ) { - ($fin->{$col}) = values %$val_bag; - } - else { - $fin->{$col} = [ -and => map { $val_bag->{$_} } sort keys %$val_bag ]; - } - } - - return keys %$fin ? $fin : (); + fromspec_columns_info( @_[1,2] ); } -sub _collapse_cond_unroll_pairs { - my ($self, $pairs) = @_; +sub _find_join_path_to_node :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + carp_unique("_find_join_path_to_node() is deprecated, ask on IRC for a better alternative"); - my @conds; + find_join_path_to_alias( @_[1,2] ); +} - while (@$pairs) { - my ($lhs, $rhs) = splice @$pairs, 0, 2; +sub _collapse_cond :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + carp_unique("_collapse_cond() is deprecated, ask on IRC for a better alternative"); - if (! length $lhs) { - push @conds, $self->_collapse_cond($rhs); - } - elsif ( $lhs =~ /^\-and$/i ) { - push @conds, $self->_collapse_cond($rhs, (ref $rhs eq 'ARRAY')); - } - elsif ( $lhs =~ /^\-or$/i ) { - push @conds, $self->_collapse_cond( - (ref $rhs eq 'HASH') ? [ map { $_ => $rhs->{$_} } sort keys %$rhs ] : $rhs - ); - } - else { - if (ref $rhs eq 'HASH' and ! keys %$rhs) { - # FIXME - SQLA seems to be doing... nothing...? - } - # normalize top level -ident, for saner extract_fixed_condition_columns code - elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-ident}) { - push @conds, { $lhs => { '=', $rhs } }; - } - elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-value} and is_plain_value $rhs->{-value}) { - push @conds, { $lhs => $rhs->{-value} }; - } - elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='}) { - if ( length ref $rhs->{'='} and is_literal_value $rhs->{'='} ) { - push @conds, { $lhs => $rhs }; - } - else { - for my $p ($self->_collapse_cond_unroll_pairs([ $lhs => $rhs->{'='} ])) { - - # extra sanity check - if (keys %$p > 1) { - require Data::Dumper::Concise; - local $Data::Dumper::Deepcopy = 1; - $self->throw_exception( - "Internal error: unexpected collapse unroll:" - . Data::Dumper::Concise::Dumper { in => { $lhs => $rhs }, out => $p } - ); - } - - my ($l, $r) = %$p; - - push @conds, ( - ! length ref $r - or - # the unroller recursion may return a '=' prepended value already - ref $r eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='} - or - is_plain_value($r) - ) - ? { $l => $r } - : { $l => { '=' => $r } } - ; - } - } - } - elsif (ref $rhs eq 'ARRAY') { - # some of these conditionals encounter multi-values - roll them out using - # an unshift, which will cause extra looping in the while{} above - if (! @$rhs ) { - push @conds, { $lhs => [] }; - } - elsif ( ($rhs->[0]||'') =~ /^\-(?:and|or)$/i ) { - $self->throw_exception("Value modifier not followed by any values: $lhs => [ $rhs->[0] ] ") - if @$rhs == 1; - - if( $rhs->[0] =~ /^\-and$/i ) { - unshift @$pairs, map { $lhs => $_ } @{$rhs}[1..$#$rhs]; - } - # if not an AND then it's an OR - elsif(@$rhs == 2) { - unshift @$pairs, $lhs => $rhs->[1]; - } - else { - push @conds, { $lhs => [ @{$rhs}[1..$#$rhs] ] }; - } - } - elsif (@$rhs == 1) { - unshift @$pairs, $lhs => $rhs->[0]; - } - else { - push @conds, { $lhs => $rhs }; - } - } - # unroll func + { -value => ... } - elsif ( - ref $rhs eq 'HASH' - and - ( my ($subop) = keys %$rhs ) == 1 - and - length ref ((values %$rhs)[0]) - and - my $vref = is_plain_value( (values %$rhs)[0] ) - ) { - push @conds, { $lhs => { $subop => $$vref } } - } - else { - push @conds, { $lhs => $rhs }; - } - } - } - - return @conds; + shift; + DBIx::Class::SQLMaker::Util::normalize_sqla_condition(@_); } -# Analyzes a given condition and attempts to extract all columns -# with a definitive fixed-condition criteria. Returns a hashref -# of k/v pairs suitable to be passed to set_columns(), with a -# MAJOR CAVEAT - multi-value (contradictory) equalities are still -# represented as a reference to the UNRESOVABLE_CONDITION constant -# The reason we do this is that some codepaths only care about the -# codition being stable, as opposed to actually making sense -# -# The normal mode is used to figure out if a resultset is constrained -# to a column which is part of a unique constraint, which in turn -# allows us to better predict how ordering will behave etc. -# -# With the optional "consider_nulls" boolean argument, the function -# is instead used to infer inambiguous values from conditions -# (e.g. the inheritance of resultset conditions on new_result) -# -sub _extract_fixed_condition_columns { - my ($self, $where, $consider_nulls) = @_; - my $where_hash = $self->_collapse_cond($_[1]); - - my $res = {}; - my ($c, $v); - for $c (keys %$where_hash) { - my $vals; +sub _extract_fixed_condition_columns :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + carp_unique("_extract_fixed_condition_columns() is deprecated, ask on IRC for a better alternative"); - if (!defined ($v = $where_hash->{$c}) ) { - $vals->{UNDEF} = $v if $consider_nulls - } - elsif ( - ref $v eq 'HASH' - and - keys %$v == 1 - ) { - if (exists $v->{-value}) { - if (defined $v->{-value}) { - $vals->{"VAL_$v->{-value}"} = $v->{-value} - } - elsif( $consider_nulls ) { - $vals->{UNDEF} = $v->{-value}; - } - } - # do not need to check for plain values - _collapse_cond did it for us - elsif( - length ref $v->{'='} - and - ( - ( ref $v->{'='} eq 'HASH' and keys %{$v->{'='}} == 1 and exists $v->{'='}{-ident} ) - or - is_literal_value($v->{'='}) - ) - ) { - $vals->{ 'SER_' . serialize $v->{'='} } = $v->{'='}; - } - } - elsif ( - ! length ref $v - or - is_plain_value ($v) - ) { - $vals->{"VAL_$v"} = $v; - } - elsif (ref $v eq 'ARRAY' and ($v->[0]||'') eq '-and') { - for ( @{$v}[1..$#$v] ) { - my $subval = $self->_extract_fixed_condition_columns({ $c => $_ }, 'consider nulls'); # always fish nulls out on recursion - next unless exists $subval->{$c}; # didn't find anything - $vals->{ - ! defined $subval->{$c} ? 'UNDEF' - : ( ! length ref $subval->{$c} or is_plain_value $subval->{$c} ) ? "VAL_$subval->{$c}" - : ( 'SER_' . serialize $subval->{$c} ) - } = $subval->{$c}; - } - } + shift; + extract_equality_conditions(@_); +} - if (keys %$vals == 1) { - ($res->{$c}) = (values %$vals) - unless !$consider_nulls and exists $vals->{UNDEF}; - } - elsif (keys %$vals > 1) { - $res->{$c} = UNRESOLVABLE_CONDITION; - } - } +sub _resolve_ident_sources :DBIC_method_is_indirect_sugar { + DBIx::Class::Exception->throw( + '_resolve_ident_sources() has been removed with no replacement, ' + . 'ask for advice on IRC if this affected you' + ); +} - $res; +sub _inner_join_to_node :DBIC_method_is_indirect_sugar { + DBIx::Class::Exception->throw( + '_inner_join_to_node() has been removed with no replacement, ' + . 'ask for advice on IRC if this affected you' + ); } 1; diff --git a/lib/DBIx/Class/Storage/TxnScopeGuard.pm b/lib/DBIx/Class/Storage/TxnScopeGuard.pm index 31a2d5bea..f961c4e44 100644 --- a/lib/DBIx/Class/Storage/TxnScopeGuard.pm +++ b/lib/DBIx/Class/Storage/TxnScopeGuard.pm @@ -26,11 +26,9 @@ sub new { # # Deliberately *NOT* using is_exception - if someone left a misbehaving # antipattern value in $@, it's not our business to whine about it - if( defined $@ and length $@ ) { - weaken( - $guard->{existing_exception_ref} = (length ref $@) ? $@ : \$@ - ); - } + weaken( + $guard->{existing_exception_ref} = (length ref $@) ? $@ : \$@ + ) if( defined $@ and length $@ ); $storage->txn_begin; diff --git a/lib/DBIx/Class/UTF8Columns.pm b/lib/DBIx/Class/UTF8Columns.pm index 793c1bc9b..db571a69c 100644 --- a/lib/DBIx/Class/UTF8Columns.pm +++ b/lib/DBIx/Class/UTF8Columns.pm @@ -3,7 +3,7 @@ use strict; use warnings; use base qw/DBIx::Class/; -__PACKAGE__->mk_classdata( '_utf8_columns' ); +__PACKAGE__->mk_group_accessors( inherited => '_utf8_columns' ); =head1 NAME @@ -94,7 +94,7 @@ sub utf8_columns { if (@_) { foreach my $col (@_) { $self->throw_exception("column $col doesn't exist") - unless $self->has_column($col); + unless $self->result_source->has_column($col); } return $self->_utf8_columns({ map { $_ => 1 } @_ }); } else { diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 4afa4c225..7e0520b23 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -1,10 +1,16 @@ package # hide from PAUSE DBIx::Class::_Util; +# load es early as we can, usually a noop +use DBIx::Class::StartupCheck; + use warnings; use strict; -use constant SPURIOUS_VERSION_CHECK_WARNINGS => ( "$]" < 5.010 ? 1 : 0); +# For the love of everything that is crab-like: DO NOT reach into this +# The entire thing is really fragile and should not be screwed with +# unless absolutely and unavoidably necessary +our $__describe_class_query_cache; BEGIN { package # hide from pause @@ -12,22 +18,26 @@ BEGIN { use Config; + use constant { + PERL_VERSION => "$]", + OS_NAME => "$^O", + }; + use constant { # but of course - BROKEN_FORK => ($^O eq 'MSWin32') ? 1 : 0, + BROKEN_FORK => (OS_NAME eq 'MSWin32') ? 1 : 0, - BROKEN_GOTO => ( "$]" < 5.008003 ) ? 1 : 0, + BROKEN_GOTO => ( PERL_VERSION < 5.008003 ) ? 1 : 0, - HAS_ITHREADS => $Config{useithreads} ? 1 : 0, + # perl -MScalar::Util=weaken -e 'weaken( $hash{key} = \"value" )' + BROKEN_WEAK_SCALARREF_VALUES => ( PERL_VERSION < 5.008003 ) ? 1 : 0, - UNSTABLE_DOLLARAT => ( "$]" < 5.013002 ) ? 1 : 0, + HAS_ITHREADS => $Config{useithreads} ? 1 : 0, - DBICTEST => $INC{"DBICTest/Util.pm"} ? 1 : 0, + TAINT_MODE => 0 + ${^TAINT}, # tri-state: 0, 1, -1 - # During 5.13 dev cycle HELEMs started to leak on copy - # add an escape for these perls ON SMOKERS - a user will still get death - PEEPEENESS => ( eval { DBICTest::RunMode->is_smoker } && ( "$]" >= 5.013005 and "$]" <= 5.013006) ), + UNSTABLE_DOLLARAT => ( PERL_VERSION < 5.013002 ) ? 1 : 0, ( map # @@ -38,55 +48,236 @@ BEGIN { { substr($_, 5) => !!( $ENV{$_} ) } qw( DBIC_SHUFFLE_UNORDERED_RESULTSETS - DBIC_ASSERT_NO_INTERNAL_WANTARRAY DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS + DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + DBIC_ASSERT_NO_FAILING_SANITY_CHECKS + DBIC_ASSERT_NO_INCONSISTENT_RELATIONSHIP_RESOLUTION DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE ) ), IV_SIZE => $Config{ivsize}, - - OS_NAME => $^O, }; - if ( "$]" < 5.009_005) { + if ( PERL_VERSION < 5.009_005) { require MRO::Compat; constant->import( OLD_MRO => 1 ); + + # + # Yes, I know this is a rather PHP-ish name, but please first read + # https://metacpan.org/source/BOBTFISH/MRO-Compat-0.12/lib/MRO/Compat.pm#L363-368 + # + # Even if we are using Class::C3::XS it still won't work, as doing + # defined( *{ "SubClass::"->{$_} }{CODE} ) + # will set pkg_gen to the same value for SubClass and *ALL PARENTS* + # + *DBIx::Class::_Util::get_real_pkg_gen = sub ($) { + require Digest::MD5; + require Math::BigInt; + + my $cur_class; + no strict 'refs'; + + # the non-assign-unless-there-is-a-hash is deliberate + ( $__describe_class_query_cache->{'!internal!'} || {} )->{$_[0]}{gen} ||= ( + Math::BigInt->new( '0x' . ( Digest::MD5::md5_hex( join "\0", map { + + ( $__describe_class_query_cache->{'!internal!'} || {} )->{$_}{methlist} ||= ( + + $cur_class = $_ + + and + + # RV to be hashed up and turned into a number + join "\0", ( + $cur_class, + map + {( + # stringification should be sufficient, ignore names/refaddr entirely + $_, + do { + my @attrs; + local $@; + local $SIG{__DIE__} if $SIG{__DIE__}; + # attributes::get may throw on blessed-false crefs :/ + eval { @attrs = attributes::get( $_ ); 1 } + or warn "Unable to determine attributes of coderef $_ due to the following error: $@"; + @attrs; + }, + )} + map + {( + # skip dummy C::C3 helper crefs + ! ( ( $Class::C3::MRO{$cur_class} || {} )->{methods}{$_} ) + and + ( + ref(\ "${cur_class}::"->{$_} ) ne 'GLOB' + or + defined( *{ "${cur_class}::"->{$_} }{CODE} ) + ) + ) + ? ( \&{"${cur_class}::$_"} ) + : () + } + keys %{ "${cur_class}::" } + ) + ) + } ( + + @{ + ( $__describe_class_query_cache->{'!internal!'} || {} )->{$_[0]}{linear_isa} + ||= + mro::get_linear_isa($_[0]) + }, + + (( + ( $__describe_class_query_cache->{'!internal!'} || {} )->{$_[0]}{is_universal} + ||= + mro::is_universal($_[0]) + ) ? () : @{ + ( $__describe_class_query_cache->{'!internal!'} || {} )->{UNIVERSAL}{linear_isa} + ||= + mro::get_linear_isa("UNIVERSAL") + } ), + + ) ) ) ) + ); + }; } else { require mro; constant->import( OLD_MRO => 0 ); + *DBIx::Class::_Util::get_real_pkg_gen = \&mro::get_pkg_gen; } + + # Both of these are no longer used for anything. However bring + # them back after they were purged in 08a8d8f1, as there appear + # to be outfits with *COPY PASTED* pieces of lib/DBIx/Class/Storage/* + # in their production codebases. There is no point in breaking these + # if whatever they used actually continues to work + my $sigh = sub { + DBIx::Class::_Util::emit_loud_diag( + skip_frames => 1, + msg => "The @{[ (caller(1))[3] ]} constant is no more - adjust your code" + ); + + 0; + }; + sub DBICTEST () { &$sigh } + sub PEEPEENESS () { &$sigh } } +use constant SPURIOUS_VERSION_CHECK_WARNINGS => ( DBIx::Class::_ENV_::PERL_VERSION < 5.010 ? 1 : 0); + # FIXME - this is not supposed to be here # Carp::Skip to the rescue soon use DBIx::Class::Carp '^DBIx::Class|^DBICTest'; +# Ensure it is always there, in case we need to do a $schema-less throw() +use DBIx::Class::Exception (); + use B (); use Carp 'croak'; use Storable 'nfreeze'; use Scalar::Util qw(weaken blessed reftype refaddr); -use List::Util qw(first); -use Sub::Quote qw(qsub quote_sub); +use Sub::Name (); +use attributes (); + +# Usually versions are not specified anywhere aside the Makefile.PL +# (writing them out in-code is extremely obnoxious) +# However without a recent enough Moo the quote_sub override fails +# in very puzzling and hard to detect ways: so add a version check +# just this once +use Sub::Quote qw(qsub); +BEGIN { Sub::Quote->VERSION('2.002002') } # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone' BEGIN { *deep_clone = \&Storable::dclone } use base 'Exporter'; our @EXPORT_OK = qw( - sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt - fail_on_internal_wantarray fail_on_internal_call - refdesc refcount hrefaddr - scope_guard detected_reinvoked_destructor - is_exception dbic_internal_try - quote_sub qsub perlstring serialize deep_clone - UNRESOLVABLE_CONDITION + sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt fail_on_internal_call + refdesc refcount hrefaddr set_subname get_subname describe_class_methods + scope_guard detected_reinvoked_destructor emit_loud_diag + true false + is_exception dbic_internal_try dbic_internal_catch visit_namespaces + quote_sub qsub perlstring serialize deep_clone dump_value uniq bag_eq + parent_dir mkdir_p + UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR ); use constant UNRESOLVABLE_CONDITION => \ '1 = 0'; +use constant DUMMY_ALIASPAIR => ( + foreign_alias => "!!!\xFF()!!!_DUMMY_FOREIGN_ALIAS_SHOULD_NEVER_BE_SEEN_IN_USE_!!!()\xFF!!!", + self_alias => "!!!\xFE()!!!_DUMMY_SELF_ALIAS_SHOULD_NEVER_BE_SEEN_IN_USE_!!!()\xFE!!!", +); + +# Override forcing no_defer, and adding naming consistency checks +our %refs_closed_over_by_quote_sub_installed_crefs; +sub quote_sub { + Carp::confess( "Anonymous quoting not supported by the DBIC quote_sub override - supply a sub name" ) if + @_ < 2 + or + ! defined $_[1] + or + length ref $_[1] + ; + + Carp::confess( "The DBIC quote_sub override expects sub name '$_[0]' to be fully qualified" ) + unless (my $stash) = $_[0] =~ /^(.+)::/; + + Carp::confess( + "The DBIC sub_quote override does not support 'no_install'" + ) if ( + $_[3] + and + $_[3]->{no_install} + ); + + Carp::confess( + 'The DBIC quote_sub override expects the namespace-part of sub name ' + . "'$_[0]' to match the supplied package argument '$_[3]->{package}'" + ) if ( + $_[3] + and + defined $_[3]->{package} + and + $stash ne $_[3]->{package} + ); + + my @caller = caller(0); + my $sq_opts = { + package => $caller[0], + hints => $caller[8], + warning_bits => $caller[9], + hintshash => $caller[10], + %{ $_[3] || {} }, + + # explicitly forced for everything + no_defer => 1, + }; + + weaken ( + # just use a growing counter, no need to perform neither compaction + # nor any special ithread-level handling + $refs_closed_over_by_quote_sub_installed_crefs + { scalar keys %refs_closed_over_by_quote_sub_installed_crefs } + = $_ + ) for grep { + length ref $_ + and + ( + ! DBIx::Class::_ENV_::BROKEN_WEAK_SCALARREF_VALUES + or + ref $_ ne 'SCALAR' + ) + } values %{ $_[2] || {} }; + + Sub::Quote::quote_sub( $_[0], $_[1], $_[2]||{}, $sq_opts ); +} + sub sigwarn_silencer ($) { my $pattern = shift; @@ -121,11 +312,226 @@ sub refcount ($) { B::svref_2object($_[0])->REFCNT; } +sub visit_namespaces { + my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; + + my $visited_count = 1; + + # A package and a namespace are subtly different things + $args->{package} ||= 'main'; + $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x; + $args->{package} =~ s/^:://; + + if ( $args->{action}->($args->{package}) ) { + my $ns = + ( ($args->{package} eq 'main') ? '' : $args->{package} ) + . + '::' + ; + + $visited_count += visit_namespaces( %$args, package => $_ ) for + grep + # this happens sometimes on %:: traversal + { $_ ne '::main' } + map + { $_ =~ /^(.+?)::$/ ? "$ns$1" : () } + do { no strict 'refs'; keys %$ns } + ; + } + + $visited_count; +} + +# FIXME In another life switch these to a polyfill like the ones in namespace::clean +sub get_subname ($) { + my $gv = B::svref_2object( $_[0] )->GV; + wantarray + ? ( $gv->STASH->NAME, $gv->NAME ) + : ( join '::', $gv->STASH->NAME, $gv->NAME ) + ; +} +sub set_subname ($$) { + + # fully qualify name + splice @_, 0, 1, caller(0) . "::$_[0]" + if $_[0] !~ /::|'/; + + &Sub::Name::subname; +} + sub serialize ($) { + # stable hash order local $Storable::canonical = 1; + + # explicitly false - there is nothing sensible that can come out of + # an attempt at CODE serialization + local $Storable::Deparse; + + # take no chances + local $Storable::forgive_me; + + # FIXME + # A number of codepaths *expect* this to be Storable.pm-based so that + # the STORABLE_freeze hooks in the metadata subtree get executed properly nfreeze($_[0]); } +sub uniq { + my( %seen, $seen_undef, $numeric_preserving_copy ); + grep { not ( + defined $_ + ? $seen{ $numeric_preserving_copy = $_ }++ + : $seen_undef++ + ) } @_; +} + +sub bag_eq ($$) { + croak "bag_eq() requiress two arrayrefs as arguments" if ( + ref($_[0]) ne 'ARRAY' + or + ref($_[1]) ne 'ARRAY' + ); + + return '' unless @{$_[0]} == @{$_[1]}; + + my( %seen, $numeric_preserving_copy ); + + ( defined $_ + ? $seen{'value' . ( $numeric_preserving_copy = $_ )}++ + : $seen{'undef'}++ + ) for @{$_[0]}; + + ( defined $_ + ? $seen{'value' . ( $numeric_preserving_copy = $_ )}-- + : $seen{'undef'}-- + ) for @{$_[1]}; + + return ( + (grep { $_ } values %seen) + ? '' + : 1 + ); +} + +my $dd_obj; +sub dump_value ($) { + local $Data::Dumper::Indent = 1 + unless defined $Data::Dumper::Indent; + + my $dump_str = ( + $dd_obj + ||= + do { + require Data::Dumper; + my $d = Data::Dumper->new([]) + ->Purity(0) + ->Pad('') + ->Useqq(1) + ->Terse(1) + ->Freezer('') + ->Quotekeys(0) + ->Bless('bless') + ->Pair(' => ') + ->Sortkeys(1) + ->Deparse(1) + ; + + # FIXME - this is kinda ridiculous - there ought to be a + # Data::Dumper->new_with_defaults or somesuch... + # + if( modver_gt_or_eq ( 'Data::Dumper', '2.136' ) ) { + $d->Sparseseen(1); + + if( modver_gt_or_eq ( 'Data::Dumper', '2.153' ) ) { + $d->Maxrecurse(1000); + + if( modver_gt_or_eq ( 'Data::Dumper', '2.160' ) ) { + $d->Trailingcomma(1); + } + } + } + + $d; + } + )->Values([$_[0]])->Dump; + + $dd_obj->Reset->Values([]); + + $dump_str; +} + +my $seen_loud_screams; +sub emit_loud_diag { + my $args = { ref $_[0] eq 'HASH' ? %{$_[0]} : @_ }; + + unless ( defined $args->{msg} and length $args->{msg} ) { + emit_loud_diag( + msg => "No 'msg' value supplied to emit_loud_diag()" + ); + exit 70; + } + + my $msg = "\n" . join( ': ', + ( $0 eq '-e' ? () : $0 ), + $args->{msg} + ); + + # when we die - we usually want to keep doing it + $args->{emit_dups} = !!$args->{confess} + unless exists $args->{emit_dups}; + + local $Carp::CarpLevel = + ( $args->{skip_frames} || 0 ) + + + $Carp::CarpLevel + + + # hide our own frame + 1 + ; + + my $longmess = Carp::longmess(); + + # different object references will thwart deduplication without this + ( my $key = "${msg}\n${longmess}" ) =~ s/\b0x[0-9a-f]+\b/0x.../gi; + + return $seen_loud_screams->{$key} if + $seen_loud_screams->{$key}++ + and + ! $args->{emit_dups} + ; + + $msg .= $longmess + unless $msg =~ /\n\z/; + + print STDERR "$msg\n" + or + print STDOUT "\n!!!STDERR ISN'T WRITABLE!!!:$msg\n"; + + return $seen_loud_screams->{$key} + unless $args->{confess}; + + # increment *again*, because... Carp. + $Carp::CarpLevel++; + + # not $msg - Carp will reapply the longmess on its own + Carp::confess($args->{msg}); +} + + +### +### This is *NOT* boolean.pm - deliberately not using a singleton +### +{ + package # hide from pause + DBIx::Class::_Util::_Bool; + use overload + bool => sub { ${$_[0]} }, + fallback => 1, + ; +} +sub true () { my $x = 1; bless \$x, "DBIx::Class::_Util::_Bool" } +sub false () { my $x = 0; bless \$x, "DBIx::Class::_Util::_Bool" } + sub scope_guard (&) { croak 'Calling scope_guard() in void context makes no sense' if ! defined wantarray; @@ -147,8 +553,9 @@ sub scope_guard (&) { 1; } or - Carp::cluck( - "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@" + DBIx::Class::_Util::emit_loud_diag( + emit_dups => 1, + msg => "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@\n " ); } } @@ -166,6 +573,7 @@ sub is_exception ($) { my ($not_blank, $suberror); { + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; eval { # The ne() here is deliberate - a plain length($e), or worse "$e" ne @@ -212,18 +620,16 @@ sub is_exception ($) { and length( my $class = ref $e ) ) { - carp_unique( sprintf( - "Objects of external exception class '%s' stringify to '' (the " + carp_unique( + "Objects of external exception class '$class' stringify to '' (the " . 'empty string), implementing the so called null-object-pattern. ' . 'Given Perl\'s "globally cooperative" exception handling using this ' . 'class of exceptions is extremely dangerous, as it may (and often ' . 'does) result in silent discarding of errors. DBIx::Class tries to ' . 'work around this as much as possible, but other parts of your ' . 'software stack may not be even aware of the problem. Please submit ' - . 'a bugreport against the distribution containing %s', - - ($class) x 2, - )); + . "a bugreport against the distribution containing '$class'", + ); $not_blank = 1; } @@ -234,10 +640,10 @@ sub is_exception ($) { { my $callstack_state; - # Recreate the logic of try(), while reusing the catch()/finally() as-is - # - # FIXME: We need to move away from Try::Tiny entirely (way too heavy and - # yes, shows up ON TOP of profiles) but this is a batle for another maint + # Recreate the logic of Try::Tiny, but without the crazy Sub::Name + # invocations and without support for finally() altogether + # ( yes, these days Try::Tiny is so "tiny" it shows *ON TOP* of most + # random profiles https://youtu.be/PYCbumw0Fis?t=1919 ) sub dbic_internal_try (&;@) { my $try_cref = shift; @@ -245,39 +651,37 @@ sub is_exception ($) { for my $arg (@_) { - if( ref($arg) eq 'Try::Tiny::Catch' ) { + croak 'dbic_internal_try() may not be followed by multiple dbic_internal_catch() blocks' + if $catch_cref; - croak 'dbic_internal_try() may not be followed by multiple catch() blocks' - if $catch_cref; + ($catch_cref = $$arg), next + if ref($arg) eq 'DBIx::Class::_Util::Catch'; - $catch_cref = $$arg; - } - elsif ( ref($arg) eq 'Try::Tiny::Finally' ) { - croak 'dbic_internal_try() does not support finally{}'; - } - else { - croak( - 'dbic_internal_try() encountered an unexpected argument ' - . "'@{[ defined $arg ? $arg : 'UNDEF' ]}' - perhaps " - . 'a missing semi-colon before or ' # trailing space important - ); - } + croak( 'Mixing dbic_internal_try() with Try::Tiny::catch() is not supported' ) + if ref($arg) eq 'Try::Tiny::Catch'; + + croak( 'dbic_internal_try() does not support finally{}' ) + if ref($arg) eq 'Try::Tiny::Finally'; + + croak( + 'dbic_internal_try() encountered an unexpected argument ' + . "'@{[ defined $arg ? $arg : 'UNDEF' ]}' - perhaps " + . 'a missing semi-colon before or ' # trailing space important + ); } my $wantarray = wantarray; my $preexisting_exception = $@; my @ret; - my $all_good = eval { + my $saul_goodman = eval { $@ = $preexisting_exception; local $callstack_state->{in_internal_try} = 1 unless $callstack_state->{in_internal_try}; # always unset - someone may have snuck it in - local $SIG{__DIE__} - if $SIG{__DIE__}; - + local $SIG{__DIE__} if $SIG{__DIE__}; if( $wantarray ) { @ret = $try_cref->(); @@ -295,7 +699,7 @@ sub is_exception ($) { my $exception = $@; $@ = $preexisting_exception; - if ( $all_good ) { + if ( $saul_goodman ) { return $wantarray ? @ret : $ret[0] } elsif ( $catch_cref ) { @@ -307,17 +711,36 @@ sub is_exception ($) { return; } - sub in_internal_try { !! $callstack_state->{in_internal_try} } + sub dbic_internal_catch (&;@) { + + croak( 'Useless use of bare dbic_internal_catch()' ) + unless wantarray; + + croak( 'dbic_internal_catch() must receive exactly one argument at end of expression' ) + if @_ > 1; + + bless( + \( $_[0] ), + 'DBIx::Class::_Util::Catch' + ), + } + + sub in_internal_try () { + !! $callstack_state->{in_internal_try} + } } { my $destruction_registry = {}; - sub CLONE { - $destruction_registry = { map - { defined $_ ? ( refaddr($_) => $_ ) : () } - values %$destruction_registry - }; + sub DBIx::Class::__Util_iThreads_handler__::CLONE { + %$destruction_registry = map { + (defined $_) + ? ( refaddr($_) => $_ ) + : () + } values %$destruction_registry; + + weaken($_) for values %$destruction_registry; # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage # collected before leaving this scope. Depending on the code above, this @@ -335,10 +758,10 @@ sub is_exception ($) { for keys %$destruction_registry; if (! length ref $_[0]) { - printf STDERR '%s() expects a blessed reference %s', - (caller(0))[3], - Carp::longmess, - ; + emit_loud_diag( + emit_dups => 1, + msg => (caller(0))[3] . '() expects a blessed reference' + ); return undef; # don't know wtf to do } elsif (! defined $destruction_registry->{ my $addr = refaddr($_[0]) } ) { @@ -346,7 +769,7 @@ sub is_exception ($) { return 0; } else { - carp_unique ( sprintf ( + emit_loud_diag( msg => sprintf ( 'Preventing *MULTIPLE* DESTROY() invocations on %s - an *EXTREMELY ' . 'DANGEROUS* condition which is *ALMOST CERTAINLY GLOBAL* within your ' . 'application, affecting *ALL* classes without active protection against ' @@ -375,11 +798,10 @@ sub modver_gt_or_eq ($$) { croak "Nonsensical minimum version supplied" if ! defined $ver or $ver !~ $ver_rx; - no strict 'refs'; - my $ver_cache = ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= ( $mod->VERSION - ? {} - : croak "$mod does not seem to provide a version (perhaps it never loaded)" - ); + my $ver_cache = do { + no strict 'refs'; + ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= {} + }; ! defined $ver_cache->{$ver} and @@ -388,8 +810,20 @@ sub modver_gt_or_eq ($$) { local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ ) if SPURIOUS_VERSION_CHECK_WARNINGS; + # prevent captures by potential __WARN__ hooks or the like: + # there is nothing of value that can be happening here, and + # leaving a hook in-place can only serve to fail some test + local $SIG{__WARN__} if ( + ! SPURIOUS_VERSION_CHECK_WARNINGS + and + $SIG{__WARN__} + ); + + croak "$mod does not seem to provide a version (perhaps it never loaded)" + unless $mod->VERSION; + + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; - local $SIG{__DIE__}; eval { $mod->VERSION($ver) } ? 1 : 0; }; @@ -410,77 +844,341 @@ sub modver_gt_or_eq_and_lt ($$$) { } { - my $list_ctx_ok_stack_marker; - sub fail_on_internal_wantarray () { - return if $list_ctx_ok_stack_marker; + sub describe_class_methods { + my $args = ( + ref $_[0] eq 'HASH' ? $_[0] + : ( @_ == 1 and ! length ref $_[0] ) ? { class => $_[0] } + : { @_ } + ); - if (! defined wantarray) { - croak('fail_on_internal_wantarray() needs a tempvar to save the stack marker guard'); - } + my ($class, $requested_mro) = @{$args}{qw( class use_mro )}; - my $cf = 1; - while ( ( (CORE::caller($cf+1))[3] || '' ) =~ / :: (?: + croak "Expecting a class name either as the sole argument or a 'class' option" + if not defined $class or $class !~ $module_name_rx; - # these are public API parts that alter behavior on wantarray - search | search_related | slice | search_literal + croak( + "The supplied 'class' argument is tainted: this is *extremely* " + . 'dangerous, fix your code ASAP!!! ( for more details read through ' + . 'https://is.gd/perl_mro_taint_wtf )' + ) if ( + DBIx::Class::_ENV_::TAINT_MODE + and + Scalar::Util::tainted($class) + ); - | + $requested_mro ||= mro::get_mro($class); - # these are explicitly prefixed, since we only recognize them as valid - # escapes when they come from the guts of CDBICompat - CDBICompat .*? :: (?: search_where | retrieve_from_sql | retrieve_all ) + # mro::set_mro() does not bump pkg_gen - WHAT THE FUCK?! + my $query_cache_key = "$class|$requested_mro"; - ) $/x ) { - $cf++; - } + my $internal_cache_key = + ( mro::get_mro($class) eq $requested_mro ) + ? $class + : $query_cache_key + ; - my ($fr, $want, $argdesc); - { - package DB; - $fr = [ CORE::caller($cf) ]; - $want = ( CORE::caller($cf-1) )[5]; - $argdesc = ref $DB::args[0] - ? DBIx::Class::_Util::refdesc($DB::args[0]) - : 'non ' - ; - }; + # use a cache on old MRO, since while we are recursing in this function + # nothing can possibly change (the speedup is immense) + # (yes, people could be tie()ing the stash and adding methods on access + # but there is a limit to how much crazy can be supported here) + # + # we use the cache for linear_isa lookups on new MRO as well - it adds + # a *tiny* speedup, and simplifies the code a lot + # + local $__describe_class_query_cache->{'!internal!'} = {} + unless $__describe_class_query_cache->{'!internal!'}; + + my $my_gen = 0; + + $my_gen += get_real_pkg_gen($_) for ( my @full_ISA = ( + + @{ + $__describe_class_query_cache->{'!internal!'}{$internal_cache_key}{linear_isa} + ||= + mro::get_linear_isa($class, $requested_mro) + }, + + (( + $__describe_class_query_cache->{'!internal!'}{$class}{is_universal} + ||= + mro::is_universal($class) + ) ? () : @{ + $__describe_class_query_cache->{'!internal!'}{UNIVERSAL}{linear_isa} + ||= + mro::get_linear_isa("UNIVERSAL") + }), + + )); + + my $slot = $__describe_class_query_cache->{$query_cache_key} ||= {}; + + unless ( ($slot->{cumulative_gen}||0) == $my_gen ) { + + # reset + %$slot = ( + class => $class, + isa => { map { $_ => 1 } @full_ISA }, + linear_isa => [ + @{ $__describe_class_query_cache->{'!internal!'}{$internal_cache_key}{linear_isa} } + [ 1 .. $#{$__describe_class_query_cache->{'!internal!'}{$internal_cache_key}{linear_isa}} ] + ], + mro => { + type => $requested_mro, + is_c3 => ( ($requested_mro eq 'c3') ? 1 : 0 ), + }, + cumulative_gen => $my_gen, + ); - if ( - $want and $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ - ) { - DBIx::Class::Exception->throw( sprintf ( - "Improper use of %s instance in list context at %s line %d\n\n Stacktrace starts", - $argdesc, @{$fr}[1,2] - ), 'with_stacktrace'); + # remove ourselves from ISA + shift @full_ISA; + + # ensure the cache is populated for the parents, code below can then + # efficiently operate over the query_cache directly + describe_class_methods($_) for reverse @full_ISA; + + no strict 'refs'; + + # combine full ISA-order inherited and local method list into a + # "shadowing stack" + + ( + unshift @{ $slot->{methods}{$_->{name}} }, $_ + + and + + ( + $_->{via_class} ne $class + or + $slot->{methods_defined_in_class}{$_->{name}} = $_ + ) + + and + + @{ $slot->{methods}{$_->{name}} } > 1 + + and + + $slot->{methods_with_supers}{$_->{name}} = $slot->{methods}{$_->{name}} + + ) for ( + + # what describe_class_methods for @full_ISA produced above + ( map { values %{ + $__describe_class_query_cache->{$_}{methods_defined_in_class} || {} + } } map { "$_|" . mro::get_mro($_) } reverse @full_ISA ), + + # our own non-cleaned subs + their attributes + ( map { + ( + # need to account for dummy helper crefs under OLD_MRO + ( + ! DBIx::Class::_ENV_::OLD_MRO + or + ! ( ( $Class::C3::MRO{$class} || {} )->{methods}{$_} ) + ) + and + # these 2 OR-ed checks are sufficient for 5.10+ + ( + ref(\ "${class}::"->{$_} ) ne 'GLOB' + or + defined( *{ "${class}::"->{$_} }{CODE} ) + ) + ) ? { + via_class => $class, + name => $_, + attributes => { map { $_ => 1 } do { + my @attrs; + local $@; + local $SIG{__DIE__} if $SIG{__DIE__}; + # attributes::get may throw on blessed-false crefs :/ + eval { @attrs = attributes::get( \&{"${class}::${_}"} ); 1 } + or warn "Unable to determine attributes of the \\&${class}::$_ method due to following error: $@"; + @attrs; + } }, + } + : () + } keys %{"${class}::"} ) + ); + + + # recalculate the pkg_gen on newer perls under Taint mode, + # because of shit like: + # perl -T -Mmro -e 'package Foo; sub bar {}; defined( *{ "Foo::"->{bar}}{CODE} ) and warn mro::get_pkg_gen("Foo") for (1,2,3)' + # + if ( + ! DBIx::Class::_ENV_::OLD_MRO + and + DBIx::Class::_ENV_::TAINT_MODE + ) { + + $slot->{cumulative_gen} = 0; + $slot->{cumulative_gen} += get_real_pkg_gen($_) + for $class, @full_ISA; + } } - my $mark = []; - weaken ( $list_ctx_ok_stack_marker = $mark ); - $mark; + # RV + +{ %$slot }; } } + +# +# Why not just use some higher-level module or at least File::Spec here? +# Because: +# 1) This is a *very* rarely used function, and the deptree is large +# enough already as it is +# +# 2) (more importantly) Our tooling is utter shit in this area. There +# is no comprehensive support for UNC paths in PathTools and there +# are also various small bugs in representation across different +# path-manipulation CPAN offerings. +# +# Since this routine is strictly used for logical path processing (it +# *must* be able to work with not-yet-existing paths), use this seemingly +# simple but I *think* complete implementation to feed to other consumers +# +# If bugs are ever uncovered in this routine, *YOU ARE URGED TO RESIST* +# the impulse to bring in an external dependency. During runtime there +# is exactly one spot that could potentially maybe once in a blue moon +# use this function. Keep it lean. +# +sub parent_dir ($) { + ( $_[0] =~ m{ [\/\\] ( \.{0,2} ) ( [\/\\]* ) \z }x ) + ? ( + $_[0] + . + ( ( length($1) and ! length($2) ) ? '/' : '' ) + . + '../' + ) + : ( + require File::Spec + and + File::Spec->catpath ( + ( File::Spec->splitpath( "$_[0]" ) )[0,1], + '/', + ) + ) + ; +} + +sub mkdir_p ($) { + require File::Path; + # do not ask for a recent version, use 1.x API calls + File::Path::mkpath([ "$_[0]" ]); # File::Path does not like objects +} + + sub fail_on_internal_call { - my ($fr, $argdesc); - { - package DB; - $fr = [ CORE::caller(1) ]; - $argdesc = ref $DB::args[0] - ? DBIx::Class::_Util::refdesc($DB::args[0]) - : undef - ; - }; + my $fr = [ CORE::caller(1) ]; + + die "\nMethod $fr->[3] is not marked with the 'DBIC_method_is_indirect_sugar' attribute\n\n" unless ( + + # unlikely but who knows... + ! @$fr + + or + + # This is a weird-ass double-purpose method, only one branch of which is marked + # as an illegal indirect call + # Hence the 'indirect' attribute makes no sense + # FIXME - likely need to mark this in some other manner + $fr->[3] eq 'DBIx::Class::ResultSet::new' + + or + + # RsrcProxy stuff is special and not attr-annotated on purpose + # Yet it is marked (correctly) as fail_on_internal_call(), as DBIC + # itself should not call these methods as first-entry + $fr->[3] =~ /^DBIx::Class::ResultSourceProxy::[^:]+$/ + + or + + # FIXME - there is likely a more fine-graned way to escape "foreign" + # callers, based on annotations... (albeit a slower one) + # For the time being just skip in a dumb way + $fr->[3] !~ /^DBIx::Class|^DBICx::|^DBICTest::/ + + or + + grep + { $_ eq 'DBIC_method_is_indirect_sugar' } + do { no strict 'refs'; attributes::get( \&{ $fr->[3] }) } + ); + + + my @fr2; + # need to make allowance for a proxy-yet-direct call + # or for an exception wrapper + $fr = \@fr2 if ( + ( + $fr->[3] eq '(eval)' + and + @fr2 = (CORE::caller(2)) + ) + or + ( + $fr->[0] eq 'DBIx::Class::ResultSourceProxy' + and + @fr2 = (CORE::caller(2)) + and + ( + ( $fr->[3] =~ /([^:])+$/ )[0] + eq + ( $fr2[3] =~ /([^:])+$/ )[0] + ) + ) + ); + if ( - $argdesc + defined $fr->[0] and $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ and $fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there + and + # one step higher + @fr2 = CORE::caller(@fr2 ? 3 : 2) + and + # if the frame that called us is an indirect itself - nothing to see here + (! grep + { $_ eq 'DBIC_method_is_indirect_sugar' } + do { + no strict 'refs'; + attributes::get( \&{ $fr2[3] }) + } + ) + and + ( + $fr->[3] ne 'DBIx::Class::ResultSet::search' + or + # these are explicit wantarray-passthrough callsites for search() due to old silly API choice + $fr2[3] !~ /^DBIx::Class::Ordered::(?: _group_rs | (?: _ | next_ | previous_ )? siblings )/x + ) ) { + + my $argdesc; + + { + package DB; + + my @throwaway = caller( @fr2 ? 2 : 1 ); + + # screwing with $DB::args is rather volatile - be extra careful + no warnings 'uninitialized'; + + $argdesc = + ( not defined $DB::args[0] ) ? 'UNAVAILABLE' + : ( length ref $DB::args[0] ) ? DBIx::Class::_Util::refdesc($DB::args[0]) + : $DB::args[0] . '' + ; + }; + DBIx::Class::Exception->throw( sprintf ( - "Illegal internal call of indirect proxy-method %s() with argument %s: examine the last lines of the proxy method deparse below to determine what to call directly instead at %s on line %d\n\n%s\n\n Stacktrace starts", + "Illegal internal call of indirect proxy-method %s() with argument '%s': examine the last lines of the proxy method deparse below to determine what to call directly instead at %s on line %d\n\n%s\n\n Stacktrace starts", $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do { require B::Deparse; no strict 'refs'; @@ -490,4 +1188,59 @@ sub fail_on_internal_call { } } +if (DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE) { + + no warnings 'redefine'; + + my $next_bless = defined(&CORE::GLOBAL::bless) + ? \&CORE::GLOBAL::bless + : sub { CORE::bless($_[0], $_[1]) } + ; + + *CORE::GLOBAL::bless = sub { + my $class = (@_ > 1) ? $_[1] : CORE::caller(); + + # allow for reblessing (role application) + return $next_bless->( $_[0], $class ) + if defined blessed $_[0]; + + my $obj = $next_bless->( $_[0], $class ); + + my $calling_sub = (CORE::caller(1))[3] || ''; + + ( + # before 5.18 ->isa() will choke on the "0" package + # which we test for in several obscure cases, sigh... + !( DBIx::Class::_ENV_::PERL_VERSION < 5.018 ) + or + $class + ) + and + ( + ( + $calling_sub !~ /^ (?: + DBIx::Class::Schema::clone + | + DBIx::Class::DB::setup_schema_instance + )/x + and + $class->isa("DBIx::Class::Schema") + ) + or + ( + $calling_sub ne 'DBIx::Class::ResultSource::new' + and + $class->isa("DBIx::Class::ResultSource") + ) + ) + and + local $Carp::CarpLevel = $Carp::CarpLevel + 1 + and + Carp::confess("Improper instantiation of '$obj': you *MUST* call the corresponding constructor"); + + + $obj; + }; +} + 1; diff --git a/lib/SQL/Translator/Parser/DBIx/Class.pm b/lib/SQL/Translator/Parser/DBIx/Class.pm index 4cc21f0b0..3c7c2004f 100644 --- a/lib/SQL/Translator/Parser/DBIx/Class.pm +++ b/lib/SQL/Translator/Parser/DBIx/Class.pm @@ -15,11 +15,9 @@ $DEBUG = 0 unless defined $DEBUG; use Exporter; use SQL::Translator::Utils qw(debug normalize_name); use DBIx::Class::Carp qw/^SQL::Translator|^DBIx::Class|^Try::Tiny/; -use DBIx::Class::_Util 'dbic_internal_try'; -use DBIx::Class::Exception; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch bag_eq ); use Class::C3::Componentised; use Scalar::Util 'blessed'; -use Try::Tiny; use namespace::clean; use base qw(Exporter); @@ -57,7 +55,8 @@ sub parse { if (!ref $dbicschema) { dbic_internal_try { Class::C3::Componentised->ensure_class_loaded($dbicschema) - } catch { + } + dbic_internal_catch { DBIx::Class::Exception->throw("Can't load $dbicschema: $_"); } } @@ -127,6 +126,10 @@ sub parse { name => $table_name, type => 'TABLE', ); + + my $ci = $source->columns_info; + + # same order as add_columns foreach my $col ($source->columns) { # assuming column_info in dbic is the same as DBI (?) @@ -137,7 +140,7 @@ sub parse { is_auto_increment => 0, is_foreign_key => 0, is_nullable => 0, - %{$source->column_info($col)} + %{$ci->{$col} || {}} ); if ($colinfo{is_nullable}) { $colinfo{default} = '' unless exists $colinfo{default}; @@ -150,15 +153,14 @@ sub parse { $table->primary_key(@primary) if @primary; - my %unique_constraints = $source->unique_constraints; - foreach my $uniq (sort keys %unique_constraints) { - if (!$source->_compare_relationship_keys($unique_constraints{$uniq}, \@primary)) { - $table->add_constraint( - type => 'unique', - name => $uniq, - fields => $unique_constraints{$uniq} - ); - } + my $unique_constraints = $source->unique_constraints_info; + foreach my $uniq (sort keys %$unique_constraints) { + $table->add_constraint( + %{ $unique_constraints->{$uniq}->{sqlt_extra} || {} }, + type => 'unique', + name => $uniq, + fields => $unique_constraints->{$uniq}->{columns} + ) unless bag_eq( \@primary, $unique_constraints->{$uniq}->{columns} ); } my @rels = $source->relationships(); @@ -174,6 +176,11 @@ sub parse { my $rel_info = $source->relationship_info($rel); # Ignore any rel cond that isn't a straight hash + # + # FIXME - this can be done *WAY* better via the recolcond resolver + # but no time to think through the implications for deploy() at + # the moment. Grep for {identity_map_matches_condition} for ideas + # how to improve this, and the /^\w+\.(\w+)$/ crap below next unless ref $rel_info->{cond} eq 'HASH'; my $relsource = dbic_internal_try { $source->related_source($rel) }; @@ -224,12 +231,12 @@ sub parse { # this is supposed to indicate a has_one/might_have... # where's the introspection!!?? :) else { - $fk_constraint = not $source->_compare_relationship_keys(\@keys, \@primary); + $fk_constraint = ! bag_eq( \@keys, \@primary ); } - my ($otherrelname, $otherrelationship) = %{ $source->reverse_relationship_info($rel) }; my $cascade; + CASCADE_TYPE: for my $c (qw/delete update/) { if (exists $rel_info->{attrs}{"on_$c"}) { if ($fk_constraint) { @@ -240,8 +247,16 @@ sub parse { . "If you are sure that SQLT must generate a constraint for this relationship, add 'is_foreign_key_constraint => 1' to the attributes.\n"; } } - elsif (defined $otherrelationship and $otherrelationship->{attrs}{$c eq 'update' ? 'cascade_copy' : 'cascade_delete'}) { - $cascade->{$c} = 'CASCADE'; + else { + for my $revrelinfo (values %{ $source->reverse_relationship_info($rel) } ) { + ( ( $cascade->{$c} = 'CASCADE' ), next CASCADE_TYPE ) if ( + $revrelinfo->{attrs} + ->{ ($c eq 'update') + ? 'cascade_copy' + : 'cascade_delete' + } + ); + } } } diff --git a/lib/SQL/Translator/Producer/DBIx/Class/File.pm b/lib/SQL/Translator/Producer/DBIx/Class/File.pm index 90c61fd38..db02f7c70 100644 --- a/lib/SQL/Translator/Producer/DBIx/Class/File.pm +++ b/lib/SQL/Translator/Producer/DBIx/Class/File.pm @@ -36,7 +36,7 @@ $DEBUG = 0 unless defined $DEBUG; use SQL::Translator::Schema::Constants; use SQL::Translator::Utils qw(header_comment); -use Data::Dumper (); +use DBIx::Class::_Util 'dump_value'; ## Skip all column type translation, as we want to use whatever the parser got. @@ -108,13 +108,9 @@ __PACKAGE__->table('${tname}'); $output .= "\n__PACKAGE__->add_columns("; foreach my $f (@fields) { - local $Data::Dumper::Terse = 1; $output .= "\n '" . (keys %$f)[0] . "' => " ; - my $colinfo = - Data::Dumper->Dump([values %$f], - [''] # keys %$f] - ); - chomp($colinfo); + ( my $colinfo = dump_value( (values %$f)[0] ) ) =~ s/^/ /mg; + $colinfo =~ s/^\s*|\s*$//g; $output .= $colinfo . ","; } $output .= "\n);\n"; @@ -129,7 +125,6 @@ __PACKAGE__->table('${tname}'); foreach my $cont ($table->get_constraints) { -# print Data::Dumper::Dumper($cont->type); if($cont->type =~ /foreign key/i) { # $output .= "\n__PACKAGE__->belongs_to('" . diff --git a/maint/Makefile.PL.inc/12_authordeps.pl b/maint/Makefile.PL.inc/12_authordeps.pl index e83e03db5..405bc1e09 100644 --- a/maint/Makefile.PL.inc/12_authordeps.pl +++ b/maint/Makefile.PL.inc/12_authordeps.pl @@ -1,6 +1,6 @@ my ($optdep_msg, $opt_testdeps); -if ($args->{skip_author_deps}) { +unless ($args->{with_optdeps}) { $optdep_msg = <<'EOW'; ****************************************************************************** @@ -9,8 +9,12 @@ *** IGNORING AUTHOR MODE: no optional test dependencies will be forced. *** *** *** *** If you are using this checkout with the intention of submitting a DBIC *** -*** patch, you are *STRONGLY ENCOURAGED* to install all dependencies, so *** -*** that every possible unit-test will run. *** +*** patch you may want to aim at running more tests by re-configuring via: *** +*** *** +*** perl Makefile.PL --with-optdeps *** +*** *** +*** which will install all optional dependencies. This is not a mandatory *** +*** step - the extensive CI setup will likely catch your mistakes anyway. *** *** *** ****************************************************************************** ****************************************************************************** @@ -23,8 +27,8 @@ ****************************************************************************** ****************************************************************************** *** *** -*** AUTHOR MODE: all optional test dependencies converted to hard requires *** -*** ( to disable re-run Makefile.PL with --skip-author-deps ) *** +*** --with-optdeps specified: converting all optional test dependencies to *** +*** hard requires ( to disable re-run Makefile.PL without options ) *** *** *** ****************************************************************************** ****************************************************************************** @@ -116,7 +120,7 @@ END unlink 'Makefile'; exit 1; } - my $meta = do { local @ARGV = 'META.yml'; local $/; <> }; + my $meta = do { local (@ARGV, $/) = 'META.yml'; <> }; $meta =~ /^\Qname: DBIx-Class\E$/m or do { warn "Seemingly malformed META.yml...?\n"; diff --git a/maint/Makefile.PL.inc/51_autohandle_MANIFEST.pl b/maint/Makefile.PL.inc/51_autohandle_MANIFEST.pl index 938cab5d6..32745cbd4 100644 --- a/maint/Makefile.PL.inc/51_autohandle_MANIFEST.pl +++ b/maint/Makefile.PL.inc/51_autohandle_MANIFEST.pl @@ -4,6 +4,7 @@ postamble <<"EOM"; fresh_manifest : remove_manifest manifest +@{[ $crlf_fixup->('MANIFEST') ]} remove_manifest : \t\$(RM_F) MANIFEST diff --git a/maint/Makefile.PL.inc/53_autogen_pod.pl b/maint/Makefile.PL.inc/53_autogen_pod.pl index ff72fd9b0..1c5530fa1 100644 --- a/maint/Makefile.PL.inc/53_autogen_pod.pl +++ b/maint/Makefile.PL.inc/53_autogen_pod.pl @@ -4,7 +4,7 @@ # 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 } ) +File::Path::rmtree([ '.generated_pod' ]) if -d '.generated_pod'; my $pod_dir = 'maint/.Generated_Pod'; @@ -12,7 +12,7 @@ # 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 } ); + File::Path::rmtree([ File::Glob::bsd_glob("$pod_dir/*") ]); } else { mkdir $pod_dir or die "Unable to create $pod_dir: $!"; @@ -22,10 +22,17 @@ { 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"); + eval { + require DBIx::Class::Optional::Dependencies; + DBIx::Class::Optional::Dependencies->_gen_pod ($ver, "$pod_dir/lib"); + 1; + } + or + 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"; @@ -95,7 +102,7 @@ # generate the DBIx/Class.pod only during distdir { - my $dist_pod_fn = File::Spec->catfile($pod_dir, qw(lib DBIx Class.pod)); + my $dist_pod_fn = "$pod_dir/lib/DBIx/Class.pod"; postamble <<"EOP"; @@ -105,15 +112,18 @@ \tperldoc -u lib/DBIx/Class.pm > $dist_pod_fn \t@{[ $mm_proto->oneliner( - "s!^.*?this line is replaced with the author list.*! qq{List of the awesome contributors who made DBIC v$ver possible\n\n} . qx(\$^X -Ilib maint/gen_pod_authors)!me", - [qw( -0777 -p -i )] + "s!^.*?this line is replaced with the author list.*! qq{List of the awesome contributors who made DBIC v$ver possible\\n\\n} . qx(\$^X -Ilib maint/gen_pod_authors)!me", + [qw( -0777 -p -i.arghwin32 )] ) ]} $dist_pod_fn +\t\$(RM_F) $dist_pod_fn.arghwin32 create_distdir : dbic_distdir_defang_authors # Remove the maintainer-only warning (be nice ;) dbic_distdir_defang_authors : -\t@{[ $mm_proto->oneliner('s/ ^ \s* \# \s* \*\*\* .+ \n ( ^ \s* \# \s*? \n )? //xmg', [qw( -0777 -p -i )] ) ]} \$(DISTVNAME)/AUTHORS +\t@{[ $mm_proto->oneliner('s/ ^ \s* \# \s* \*\*\* .+ \n ( ^ \s* \# \s*? \n )? //xmg', [qw( -0777 -p -i.arghwin32 )] ) ]} \$(DISTVNAME)/AUTHORS +@{[ $crlf_fixup->( '$(DISTVNAME)/AUTHORS' ) ]} +\t\$(RM_F) \$(DISTVNAME)/AUTHORS.arghwin32 EOP } @@ -146,7 +156,7 @@ 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']) + $mm_proto->oneliner("install([ from_to => {q($pod_dir) => './', write => q($pod_dir.packlist)}, verbose => 0, uninstall_shadows => 0, skip => [] ])", ['-MExtUtils::Install']) ]} EOP diff --git a/maint/Makefile.PL.inc/54_autogen_legalese_and_README.pl b/maint/Makefile.PL.inc/54_autogen_legalese_and_README.pl index 8b96f508b..169fea619 100644 --- a/maint/Makefile.PL.inc/54_autogen_legalese_and_README.pl +++ b/maint/Makefile.PL.inc/54_autogen_legalese_and_README.pl @@ -5,9 +5,8 @@ # 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 $r_fn = File::Spec->catfile($dir, 'README'); +my $dir = 'maint/.Generated_Pod'; +my $r_fn = "$dir/README"; my $start_file = sub { my $fn = $mm_proto->quote_literal(shift); @@ -32,8 +31,9 @@ create_distdir : dbic_distdir_regen_license dbic_distdir_regen_license : -@{[ $start_file->( File::Spec->catfile( Meta->name . '-' . Meta->version, 'LICENSE') ) ]} +@{[ $start_file->( Meta->name . '-' . Meta->version . '/LICENSE' ) ]} \t@{[ $mm_proto->oneliner('cat', ['-MExtUtils::Command']) ]} LICENSE >> \$(DISTVNAME)/LICENSE +@{[ $crlf_fixup->('$(DISTVNAME)/LICENSE') ]} EOP diff --git a/maint/Makefile.PL.inc/56_autogen_schema_files.pl b/maint/Makefile.PL.inc/56_autogen_schema_files.pl index 6096010f6..bbc9912ab 100644 --- a/maint/Makefile.PL.inc/56_autogen_schema_files.pl +++ b/maint/Makefile.PL.inc/56_autogen_schema_files.pl @@ -1,9 +1,8 @@ -require File::Spec; -my $test_ddl_fn = File::Spec->catfile(qw( t lib sqlite.sql )); -my @test_ddl_cmd = qw( -I lib -I t/lib -- maint/gen_sqlite_schema_files --schema-class DBICTest::Schema ); +my $test_ddl_fn = 't/lib/sqlite.sql'; +my @test_ddl_cmd = qw( -I lib -I t/lib -MANFANG -- maint/gen_sqlite_schema_files --schema-class DBICTest::Schema ); -my $example_ddl_fn = File::Spec->catfile(qw( examples Schema db example.sql )); -my $example_db_fn = File::Spec->catfile(qw( examples Schema db example.db )); +my $example_ddl_fn = 'examples/Schema/db/example.sql'; +my $example_db_fn = 'examples/Schema/db/example.db'; my @example_ddl_cmd = qw( -I lib -I examples/Schema -- maint/gen_sqlite_schema_files --schema-class MyApp::Schema ); my @example_pop_cmd = qw( -I lib -I examples/Schema -- examples/Schema/insertdb.pl ); @@ -23,6 +22,7 @@ # 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 + require File::Spec; system('git status --porcelain >' . File::Spec->devnull); } diff --git a/maint/Makefile.PL.inc/11_authortests.pl b/maint/Makefile.PL.inc/92_authortests.pl similarity index 73% rename from maint/Makefile.PL.inc/11_authortests.pl rename to maint/Makefile.PL.inc/92_authortests.pl index 7760de2ef..77b52e5f8 100644 --- a/maint/Makefile.PL.inc/11_authortests.pl +++ b/maint/Makefile.PL.inc/92_authortests.pl @@ -1,4 +1,3 @@ -require File::Spec; require File::Find; my $xt_dist_dirs; @@ -9,7 +8,12 @@ ); }, 'xt/dist'); -my @xt_dist_tests = map { File::Spec->catfile($_, '*.t') } sort keys %$xt_dist_dirs; +my @xt_dist_tests = map { "$_/*.t" } sort keys %$xt_dist_dirs; + +my $parallel_jobs = ( $^O eq 'MSWin32' ) + ? 1 # FIXME for some reason windows hangs on parallel jobs at `make dist` + : 4 +; # inject an explicit xt test run, mainly to check the contents of # lib and the generated POD's *before* anything is copied around @@ -31,7 +35,10 @@ # perl cmd join( ' ', '$(ABSPERLRUN)', - map { $mm_proto->quote_literal($_) } qw(-e $ENV{RELEASE_TESTING}=1;$ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}=1;) + map { $mm_proto->quote_literal($_) } ( + '-e', + "\$ENV{RELEASE_TESTING}=1;\$ENV{HARNESS_OPTIONS}=j$parallel_jobs;" + ), ), # test list join( ' ', @@ -50,7 +57,11 @@ # perl cmd join( ' ', '$(ABSPERLRUN)', - map { $mm_proto->quote_literal($_) } qw(-Ilib -e $ENV{RELEASE_TESTING}=1;$ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}=1;) + map { $mm_proto->quote_literal($_) } ( + '-Ilib', + '-e', + "\$ENV{RELEASE_TESTING}=1;\$ENV{HARNESS_OPTIONS}=j$parallel_jobs;" + ), ), 'xt/dist/postdistdir/*.t', ) diff --git a/maint/careless_ssh.bash b/maint/careless_ssh.bash new file mode 100755 index 000000000..1b9e0bcd8 --- /dev/null +++ b/maint/careless_ssh.bash @@ -0,0 +1,3 @@ +#!/bin/bash + +/usr/bin/ssh -o UserKnownHostsFile=/dev/null -o StrictHostKeyChecking=no "$@" diff --git a/maint/gen_pod_inherit b/maint/gen_pod_inherit index e441e88ee..4164da6c6 100755 --- a/maint/gen_pod_inherit +++ b/maint/gen_pod_inherit @@ -47,6 +47,7 @@ Pod::Inherit->new({ lib/DBIx/Class/DB.pm lib/DBIx/Class/CDBICompat/ lib/DBIx/Class/CDBICompat.pm + lib/DBIx/Class/_TempExtlib/ ), # skip the ::Storage:: family for now qw( diff --git a/maint/gen_sqlite_schema_files b/maint/gen_sqlite_schema_files index a3793d33e..0ac70ec2b 100755 --- a/maint/gen_sqlite_schema_files +++ b/maint/gen_sqlite_schema_files @@ -4,8 +4,8 @@ use strict; use warnings; use Module::Runtime 'use_module'; +use DBIx::Class::_Util qw(mkdir_p parent_dir); use SQL::Translator; -use Path::Class 'file'; use Getopt::Long; my $getopt = Getopt::Long::Parser->new( config => [qw/gnu_getopt bundling_override no_ignore_case/] @@ -34,7 +34,7 @@ my $schema = use_module( $args->{'schema-class'}[0] )->connect( ); if ($args->{'deploy-to'}) { - file($args->{'deploy-to'}[0])->dir->mkpath; + mkdir_p parent_dir $args->{'deploy-to'}[0]; $schema->deploy({ add_drop_table => 1 }); } @@ -43,10 +43,9 @@ if ($args->{'ddl-out'}[0] eq '-') { $ddl_fh = *STDOUT; } else { - my $fn = file($args->{'ddl-out'}[0]); - $fn->dir->mkpath; - open $ddl_fh, '>', $fn - or die "Unable to open $fn: $!\n"; + mkdir_p parent_dir $args->{'ddl-out'}[0]; + open $ddl_fh, '>', $args->{'ddl-out'}[0] + or die "Unable to open $args->{'ddl-out'}[0]: $!\n"; } binmode $ddl_fh; # avoid win32 \n crapfest diff --git a/maint/poisonsmoke.bash b/maint/poisonsmoke.bash new file mode 100755 index 000000000..d8b984c37 --- /dev/null +++ b/maint/poisonsmoke.bash @@ -0,0 +1,40 @@ +#!/bin/bash + +set -e + +[[ -e Makefile.PL ]] || ( echo "Not in the right dir" && exit 1 ) + +clear +echo + +export TRAVIS=true +export TRAVIS_REPO_SLUG="x/dbix-class" +export DBI_DSN="dbi:ODBC:server=NonexistentServerAddress" +export DBI_DRIVER="ADO" + +toggle_booleans=( \ + $( grep -ohP '\bDBIC_[0-9_A-Z]+' -r lib/ --exclude-dir Optional | sort -u | grep -vP '^(DBIC_TRACE(_PROFILE)?|DBIC_.+_DEBUG)$' ) \ + DBIC_SHUFFLE_UNORDERED_RESULTSETS \ + DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION \ + DBICTEST_RUN_ALL_TESTS \ + DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER \ +) + +for var in "${toggle_booleans[@]}" +do + if [[ -z "${!var}" ]] ; then + export $var=1 + echo -n "$var " + fi +done +echo -e "\n\n^^ variables above **automatically** set to '1'" + +provecmd="nice prove -QlrswTj10" + +echo -e " +Executing \`$provecmd $@\` via $(which perl) within the following environment: + +$(env | grep -P 'TEST|HARNESS|MAKE|TRAVIS|PERL|DBIC|PATH|SHELL' | LC_ALL=C sort | cat -v) +" + +$provecmd "$@" diff --git a/maint/travis-ci_scripts/10_before_install.bash b/maint/travis-ci_scripts/10_before_install.bash old mode 100755 new mode 100644 index 667425922..3d5bbae55 --- a/maint/travis-ci_scripts/10_before_install.bash +++ b/maint/travis-ci_scripts/10_before_install.bash @@ -1,5 +1,10 @@ #!/bin/bash +if [[ "${BASH_SOURCE[0]}" == "${0}" ]] ; then + echo "This script can not be executed standalone - it can only be source()d" 1>&2 + exit 1 +fi + export SHORT_CIRCUIT_SMOKE if have_sudo ; then @@ -71,47 +76,65 @@ if [[ "$CLEANTEST" != "true" ]]; then "sudo bash -c 'dd if=/dev/zero of=/swap.img bs=256M count=5 && chmod 600 /swap.img && mkswap /swap.img && swapon /swap.img'" fi - export CACHE_DIR="/tmp/poormanscache" + + # never installed, this looks like trusty + if [[ ! -d /var/lib/mysql ]] ; then + sudo dpkg --add-architecture i386 + extra_debs+=( postgresql mysql-server ) + fi + + + # these APT sources do not mean anything to us anyway + sudo rm -rf /etc/apt/sources.list.d/* # - # FIXME these debconf lines should automate the firebird config but do not :((( + # FIXME these debconf lines should automate the firebird config but seem not to :((( 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' - # these APT sources do not mean anything to us anyway - sudo rm -rf /etc/apt/sources.list.d/* + run_or_err "Updating APT sources" "sudo apt-get update" + apt_install ${extra_debs[@]} libmysqlclient-dev memcached firebird2.5-super firebird2.5-dev expect - # the actual package is built for lucid, installs fine on both precise and trusty - sudo bash -c 'echo "deb http://archive.canonical.com/ubuntu precise partner" >> /etc/apt/sources.list' - # never installed, this looks like trusty - if [[ ! -d /var/lib/mysql ]] ; then - sudo dpkg --add-architecture i386 - extra_debs="$extra_debs postgresql mysql-server" - fi + # need to stop them again, in case we installed them above (trusty) + for d in mysql postgresql ; do + run_or_err "Stopping $d" "sudo /etc/init.d/$d stop || /bin/true" + done + + + export CACHE_DIR="/tmp/poormanscache" + mkdir "$CACHE_DIR" # FIXME - by default db2 eats too much memory, we won't be able to test on legacy infra # someone needs to add a minimizing configuration akin to 9367d187 if [[ "$(free -m | grep 'Mem:' | perl -p -e '$_ = (split /\s+/, $_)[1]')" -gt 4000 ]] ; then - extra_debs="$extra_debs db2exc" + run_or_err "Getting DB2 from poor man's cache github" ' + wget -qO- https://github.com/poormanscache/poormanscache/archive/DB2_ExC/9.7.5_deb_x86-64.tar.gz \ + | tar -C "$CACHE_DIR" -zx' + + # the actual package is built for lucid, installs fine on both precise and trusty + manual_debs+=( "db2exc_9.7.5-0lucid0_amd64.deb" ) fi - run_or_err "Updating APT sources" "sudo apt-get update" + run_or_err "Getting Oracle from poor man's cache github" ' + wget -qO- https://github.com/poormanscache/poormanscache/archive/OracleXE/10.2.0_deb_mixed.tar.gz \ + | tar -C "$CACHE_DIR" -zx' + manual_debs+=( "bc-multiarch-travis_1.0_all.deb" "oracle-xe_10.2.0.1-1.1_i386.deb" ) - apt_install $extra_debs libmysqlclient-dev memcached firebird2.5-super firebird2.5-dev expect - # needs to happen separately and *after* db2exc, as the former shits all over /usr/include (wtf?!) - # for more info look at /opt/ibm/db2/V9.7/instance/db2iutil :: create_links() - apt_install unixodbc-dev + # reassemble chunked pieces ( working around github's filesize limit ) + for reass in $CACHE_DIR/*/reassemble ; do /bin/bash "$reass" ; done + + run_or_err "Installing RDBMS debs manually: $( echo ${manual_debs[@]/#/$CACHE_DIR/*/*/} )" \ + "sudo dpkg -i $( echo ${manual_debs[@]/#/$CACHE_DIR/*/*/} ) || sudo bash -c 'source maint/travis-ci_scripts/common.bash && apt_install -f'" - # need to stop them again, in case we installed them above (trusty) - for d in mysql postgresql ; do - run_or_err "Stopping $d" "sudo /etc/init.d/$d stop || /bin/true" - done - run_or_err "Cloning poor man's cache from github" "git clone --depth=1 --single-branch --branch=oracle/10.2.0 https://github.com/poormanscache/poormanscache.git $CACHE_DIR && $CACHE_DIR/reassemble" - run_or_err "Installing OracleXE manually from deb" \ - "sudo dpkg -i $CACHE_DIR/apt_cache/bc-multiarch-travis_1.0_all.deb $CACHE_DIR/apt_cache/oracle-xe_10.2.0.1-1.1_i386.deb || sudo bash -c 'source maint/travis-ci_scripts/common.bash && apt_install -f'" + # Needs to happen separately and *after* db2exc, as the former shits all over /usr/include (wtf?!) + # For more info look at /opt/ibm/db2/V9.7/instance/db2iutil :: create_links() + # The --reinstall is there in case it was already in place and got destroyed + # (this is the case on newer trusty images) + apt_install --reinstall unixodbc-dev + ### config memcached run_or_err "Starting memcached" "sudo /etc/init.d/memcached start" @@ -162,11 +185,14 @@ if [[ "$CLEANTEST" != "true" ]]; then "echo \"CREATE DATABASE '/var/lib/firebird/2.5/data/dbic_test.fdb';\" | sudo isql-fb -u sysdba -p 123" then + + # Do not upgrade to a newer ODBC driver - smoking on an old + # and buggy POS is much more valuable + # run_or_err "Fetching and building Firebird ODBC driver" ' cd "$(mktemp -d)" - wget -qO- http://sourceforge.net/projects/firebird/files/firebird-ODBC-driver/2.0.2-Release/OdbcFb-Source-2.0.2.153.gz/download | tar -zx + wget -qO- https://github.com/dbsrgits/Firebird-ODBC-driver/archive/2.0.2.153.tar.gz | tar -zx --strip-components 1 cd Builds/Gcc.lin - perl -p -i -e "s|/usr/lib64|/usr/lib/x86_64-linux-gnu|g" ../makefile.environ make -f makefile.linux sudo make -f makefile.linux install ' @@ -258,7 +284,7 @@ FileUsage = 1 GRANT connect,resource TO $DBICTEST_ORA_EXTRAUSER_USER; '" - export ORACLE_HOME="$CACHE_DIR/ora_instaclient/x86-64/oracle_instaclient_10.2.0.5.0" + export ORACLE_HOME="$CACHE_DIR/poormanscache-OracleXE-10.2.0_deb_mixed/ora_instaclient/x86-64/oracle_instaclient_10.2.0.5.0" ### config db2exc # we may have skipped installation due to low memory diff --git a/maint/travis-ci_scripts/20_install.bash b/maint/travis-ci_scripts/20_install.bash old mode 100755 new mode 100644 index 515b17651..1a4968f1e --- a/maint/travis-ci_scripts/20_install.bash +++ b/maint/travis-ci_scripts/20_install.bash @@ -1,10 +1,15 @@ #!/bin/bash +if [[ "${BASH_SOURCE[0]}" == "${0}" ]] ; then + echo "This script can not be executed standalone - it can only be source()d" 1>&2 + exit 1 +fi + if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi # we need a mirror that both has the standard index and a backpan version rolled # into one, due to MDV testing -CPAN_MIRROR="http://cpan.metacpan.org/" +export CPAN_MIRROR="http://cpan.metacpan.org/" PERL_CPANM_OPT="$PERL_CPANM_OPT --mirror $CPAN_MIRROR" @@ -31,19 +36,37 @@ if [[ -n "$BREWVER" ]] ; then BREWSRC="$BREWVER" - if [[ "$BREWVER" == "schmorp_stableperl" ]] ; then + if is_cperl; then + if [[ "$BREWVER" == "cperl-master" ]] ; then + git clone --single-branch --depth=1 --branch=master https://github.com/perl11/cperl /tmp/cperl-master + BREWSRC="/tmp/cperl-master" + else + # FFS perlbrew ( see http://wollmers-perl.blogspot.de/2015/10/install-cperl-with-perlbrew.html ) + wget -qO- https://github.com/perl11/cperl/archive/$BREWVER.tar.gz > /tmp/cperl-$BREWVER.tar.gz + BREWSRC="/tmp/cperl-$BREWVER.tar.gz" + fi + elif [[ "$BREWVER" == "schmorp_stableperl" ]] ; then BREWSRC="http://stableperl.schmorp.de/dist/stableperl-5.22.0-1.001.tar.gz" fi run_or_err "Compiling/installing Perl $BREWVER (without testing, using ${perlbrew_jopt:-1} threads, may take up to 5 minutes)" \ "perlbrew install --as $BREWVER --notest --noman --verbose $BREWOPTS -j${perlbrew_jopt:-1} $BREWSRC" - # can not do 'perlbrew uss' in the run_or_err subshell above, or a $() - # furthermore `perlbrew use` returns 0 regardless of whether the perl is - # found (won't be there unless compilation suceeded, wich *ALSO* returns 0) - perlbrew use $BREWVER + # FIXME work around https://github.com/perl11/cperl/issues/144 + # (still affecting 5.22.3) + if is_cperl && ! [[ -f ~/perl5/perlbrew/perls/$BREWVER/bin/perl ]] ; then + ln -s ~/perl5/perlbrew/perls/$BREWVER/bin/cperl ~/perl5/perlbrew/perls/$BREWVER/bin/perl || /bin/true + fi + + # can not do 'perlbrew use' in the run_or_err subshell above, or a $() + # furthermore some versions of `perlbrew use` return 0 regardless of whether + # the perl is found (won't be there unless compilation suceeded, wich *ALSO* returns 0) + perlbrew use $BREWVER || /bin/true - if [[ "$( perlbrew use | grep -oP '(?<=Currently using ).+' )" != "$BREWVER" ]] ; then + if \ + ! [[ -x ~/perl5/perlbrew/perls/$BREWVER/bin/perl ]] \ + || [[ "$( perlbrew use | grep -oP '(?<=Currently using ).+' )" != "$BREWVER" ]] + then echo_err "Unable to switch to $BREWVER - compilation failed...?" echo_err "$LASTOUT" exit 1 @@ -55,6 +78,13 @@ elif [[ "$CLEANTEST" == "true" ]] && [[ "$POISON_ENV" != "true" ]] ; then purge_sitelib fi +if [[ "$POISON_ENV" = "true" ]] ; then + # create a perlbrew-specific local lib + perlbrew lib create travis-local + perlbrew use "$( perlbrew use | grep -oP '(?<=Currently using ).+' )@travis-local" + echo_err "POISON_ENV active - adding a local lib: $(perlbrew use)" +fi + # configure CPAN.pm - older versions go into an endless loop # when trying to autoconf themselves CPAN_CFG_SCRIPT=" @@ -63,7 +93,7 @@ CPAN_CFG_SCRIPT=" *CPAN::FirstTime::conf_sites = sub {}; CPAN::Config->load; \$CPAN::Config->{urllist} = [qw{ $CPAN_MIRROR }]; - \$CPAN::Config->{halt_on_failure} = 1; + \$CPAN::Config->{halt_on_failure} = $( is_cperl && echo -n 0 || echo -n 1 ); CPAN::Config->commit; " run_or_err "Configuring CPAN.pm" "perl -e '$CPAN_CFG_SCRIPT'" @@ -86,6 +116,17 @@ fi # poison the environment if [[ "$POISON_ENV" = "true" ]] ; then + toggle_vars=( MVDT ) + + [[ "$CLEANTEST" == "true" ]] && toggle_vars+=( BREAK_CC ) + + for var in "${toggle_vars[@]}" ; do + if [[ -z "${!var}" ]] ; then + export $var=true + echo "POISON_ENV: setting $var to 'true'" + fi + done + # look through lib, find all mentioned DBIC* ENVvars and set them to true and see if anything explodes toggle_booleans=( $( grep -ohP '\bDBIC_[0-9_A-Z]+' -r lib/ --exclude-dir Optional | sort -u | grep -vP '^(DBIC_TRACE(_PROFILE)?|DBIC_.+_DEBUG)$' ) ) @@ -111,8 +152,12 @@ if [[ "$POISON_ENV" = "true" ]] ; then fi done + echo "POISON_ENV: setting PERL_UNICODE=SAD" + export PERL_UNICODE=SAD + ### emulate a local::lib-like env + # trick cpanm into executing true as shell - we just need the find+unpack run_or_err "Downloading latest stable DBIC from CPAN" \ "SHELL=/bin/true cpanm --look DBIx::Class" @@ -124,7 +169,6 @@ if [[ "$POISON_ENV" = "true" ]] ; then # perldoc -l searches $(pwd)/lib in addition to PERL5LIB etc, hence the cd / echo_err "Latest stable DBIC (without deps) locatable via \$PERL5LIB at $(cd / && perldoc -l DBIx::Class)" - fi if [[ "$CLEANTEST" != "true" ]] ; then diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash old mode 100755 new mode 100644 index 603344050..1de6cfb65 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -5,24 +5,59 @@ source maint/travis-ci_scripts/common.bash if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then exit 0 ; fi -# The prereq-install stage will not work with both POISON and DEVREL +# The DEVREL_DEPS prereq-install stage won't mix with MVDT # DEVREL wins -if [[ "$DEVREL_DEPS" = "true" ]] ; then - export POISON_ENV="" +if [[ "$DEVREL_DEPS" == "true" ]] ; then + export MVDT="" fi -# FIXME - this is a kludge in place of proper MDV testing. For the time +# Need a shitton of patches to run on cperl (luckily all provided) +if is_cperl ; then + + run_or_err "Downloading and installing cperl distroprefs" ' + wget -qO- https://github.com/rurban/distroprefs/archive/master.tar.gz |\ + tar -C $HOME/.cpan --strip-components 1 -zx distroprefs-master/prefs distroprefs-master/sources + ' + + # Argh -DFORTIFY_INC!!! + # FIXME - remove when M::I is gone + export PERL5LIB="$PERL5LIB:." + + # Also need to have YAML in place, otherwise the distroprefs are not readable + # work around https://github.com/perl11/cperl/issues/155#issuecomment-224862978 + perl -MYAML -e1 &>/dev/null || installdeps YAML + +fi + + +# announce what are we running +echo_err "$(ci_vm_state_text)" + + +# FIXME - this is a kludge in place of proper MVDT testing. For the time # being simply use the minimum versions of our DBI/DBDstack, to avoid # fuckups like 0.08260 (went unnoticed for 5 months) -if [[ "$POISON_ENV" = "true" ]] ; then +if [[ "$MVDT" == "true" ]] ; then # use url-spec for DBI due to https://github.com/miyagawa/cpanminus/issues/328 if [[ "$CLEANTEST" != "true" ]] || perl -M5.013003 -e1 &>/dev/null ; then # the fulltest may re-upgrade DBI, be conservative only on cleantests # earlier DBI will not compile without PERL_POLLUTE which was gone in 5.14 parallel_installdeps_notest T/TI/TIMB/DBI-1.614.tar.gz + + # FIXME work around DBD::DB2 being silly: https://rt.cpan.org/Ticket/Display.html?id=101659 + if [[ -n "$DBICTEST_DB2_DSN" ]] ; then + echo_err "Installing same DBI version into the main perl (above the current local::lib)" + $SHELL -lic "perlbrew use $( perlbrew use | grep -oP '(?<=Currently using )[^@]+' ) && parallel_installdeps_notest T/TI/TIMB/DBI-1.614.tar.gz" + fi else parallel_installdeps_notest T/TI/TIMB/DBI-1.57.tar.gz + + # FIXME work around DBD::DB2 being silly: https://rt.cpan.org/Ticket/Display.html?id=101659 + if [[ -n "$DBICTEST_DB2_DSN" ]] ; then + echo_err "Installing same DBI version into the main perl (above the current local::lib)" + $SHELL -lic "perlbrew use $( perlbrew use | grep -oP '(?<=Currently using )[^@]+' ) && parallel_installdeps_notest T/TI/TIMB/DBI-1.57.tar.gz" + fi fi # Test both minimum DBD::SQLite and minimum BigInt SQLite @@ -32,23 +67,36 @@ if [[ "$POISON_ENV" = "true" ]] ; then else parallel_installdeps_notest DBD::SQLite@1.29 fi +fi - # also try minimal tested installs *without* a compiler - if [[ "$CLEANTEST" = "true" ]]; then +# +# try minimal fully tested installs *without* a compiler (with some exceptions of course) +if [[ "$BREAK_CC" == "true" ]] ; then - # Clone and P::S::XS are both bugs - # File::Spec can go away as soon as I dump Path::Class - # File::Path is there because of RT#107392 (sigh) - # List::Util can be excised after that as well (need to make my own max() routine for older perls) + [[ "$CLEANTEST" != "true" ]] && echo_err "Breaking the compiler without CLEANTEST makes no sense" && exit 1 - installdeps Sub::Name Clone Package::Stash::XS \ - $( perl -MFile::Spec\ 3.26 -e1 &>/dev/null || echo "File::Path File::Spec" ) \ - $( perl -MList::Util\ 1.16 -e1 &>/dev/null || echo "List::Util" ) + # FIXME - working around RT#74707, https://metacpan.org/source/DOY/Package-Stash-0.37/Makefile.PL#L112-122 + # + # DEVREL_DEPS means our installer is cpanm, which will respect failures + # and the like, so stuff soft-failing (failed deps that are not in fact + # needed) will not fly. Add *EVEN MORE* stuff that needs a compiler + # + # FIXME - the PathTools 3.47 is to work around https://rt.cpan.org/Ticket/Display.html?id=107392 + # + installdeps Sub::Name Clone Package::Stash::XS \ + $( [[ "$DEVREL_DEPS" == "true" ]] && ( perl -MFile::Spec\ 3.13 -e1 &>/dev/null || echo "S/SM/SMUELLER/PathTools-3.47.tar.gz" ) ) \ + $( perl -MDBI -e1 &>/dev/null || echo "DBI" ) \ + $( perl -MDBD::SQLite -e1 &>/dev/null || echo "DBD::SQLite" ) - mkdir -p "$HOME/bin" # this is already in $PATH, just doesn't exist - run_or_err "Linking ~/bin/cc to /bin/false - thus essentially BREAKING the C compiler" \ - "ln -s /bin/false $HOME/bin/cc" - fi + mkdir -p "$HOME/bin" # this is already in $PATH, just doesn't exist + run_or_err "Linking ~/bin/cc to /bin/false - thus essentially BREAKING the C compiler" \ + "ln -s /bin/false $HOME/bin/cc" + + # FIXME: working around RT#113682, and some other unfiled bugs + installdeps Module::Build Devel::GlobalDestruction Class::Accessor::Grouped + + run_or_err "Linking ~/bin/cc to /bin/true - BREAKING the C compiler even harder" \ + "ln -fs /bin/true $HOME/bin/cc" fi if [[ "$CLEANTEST" = "true" ]]; then @@ -57,7 +105,7 @@ if [[ "$CLEANTEST" = "true" ]]; then # 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 [[ -d ~/.cpanm/latest-build/DBIx-Class-*/inc ]] || run_or_err "Downloading latest stable DBIC inc/ from CPAN" \ "SHELL=/bin/true cpanm --look DBIx::Class" @@ -86,19 +134,23 @@ else # 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, - # while a File::Path upgrade may cause a parallel EUMM run to fail) + # (e.g. once Carp is upgraded there's no more Carp::Heavy) # - parallel_installdeps_notest File::Path parallel_installdeps_notest Carp parallel_installdeps_notest Module::Build - parallel_installdeps_notest File::Spec Module::Runtime - parallel_installdeps_notest Test::Exception Encode::Locale Test::Fatal + parallel_installdeps_notest Test::Exception Encode::Locale Test::Fatal Module::Runtime parallel_installdeps_notest Test::Warn B::Hooks::EndOfScope Test::Differences HTTP::Status parallel_installdeps_notest Test::Pod::Coverage Test::EOL Devel::GlobalDestruction Sub::Name MRO::Compat Class::XSAccessor URI::Escape HTML::Entities - parallel_installdeps_notest YAML LWP Class::Trigger DateTime::Format::Builder Class::Accessor::Grouped Package::Variant + parallel_installdeps_notest YAML LWP Class::Trigger Class::Accessor::Grouped Package::Variant parallel_installdeps_notest SQL::Abstract Moose Module::Install@1.15 JSON SQL::Translator File::Which Class::DBI::Plugin git://github.com/dbsrgits/perl-pperl.git + # FIXME - temp workaround for RT#117959 + if ! perl -M5.008004 -e1 &>/dev/null ; then + parallel_installdeps_notest DateTime::Locale@1.06 + parallel_installdeps_notest DateTime::TimeZone@2.02 + parallel_installdeps_notest DateTime@1.38 + fi + # 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 @@ -114,13 +166,12 @@ else 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 + run_or_err "Configure on current branch" "perl Makefile.PL" + # we are doing a devrel pass - try to upgrade *everything* (we will be using cpanm so safe-ish) if [[ "$DEVREL_DEPS" == "true" ]] ; then @@ -141,18 +192,41 @@ if [[ "$CLEANTEST" = "true" ]]; then ##### END TEMPORARY WORKAROUNDS fi + # FIXME - work around RT#117844 + if [[ "$BREWVER" == "5.10.0" ]]; then + unset PERL_UNICODE + fi + installdeps $HARD_DEPS + run_or_err "Re-configure" "perl Makefile.PL" + else - parallel_installdeps_notest "$(make listdeps | sort -R)" + run_or_err "Configure on current branch with --with-optdeps" "perl Makefile.PL --with-optdeps" + # FIXME - evil evil work around for https://github.com/Manwar/Test-Strict/issues/17 + if perl -M5.025 -e1 &>/dev/null; then + mkdir -p "$( perl -MConfig -e 'print $Config{sitelib}' )/Devel" + cat < "$( perl -MConfig -e 'print $Config{sitelib}' )/Devel/Cover.pm" +package Devel::Cover; +our \$VERSION = 0.43; +1; +MyDevelCover + fi + + # if we are smoking devrels - make sure we upgrade everything we know about + if [[ "$DEVREL_DEPS" == "true" ]] ; then + parallel_installdeps_notest "$(make listalldeps | sort -R)" + else + parallel_installdeps_notest "$(make listdeps | sort -R)" + fi + + run_or_err "Re-configure with --with-optdeps" "perl Makefile.PL --with-optdeps" fi echo_err "$(tstamp) Dependency installation finished" -run_or_err "Re-configure" "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 :(" @@ -163,8 +237,8 @@ if [[ -n "$(make listdeps)" ]] ; then exit 1 fi -# check that our MDV somewhat works -if [[ "$POISON_ENV" = "true" ]] && ( perl -MDBD::SQLite\ 1.38 -e1 || perl -MDBI\ 1.615 -e1 ) &>/dev/null ; then +# check that our MVDT somewhat works +if [[ "$MVDT" == "true" ]] && ( perl -MDBD::SQLite\ 1.38 -e1 || perl -MDBI\ 1.615 -e1 ) &>/dev/null ; then echo_err "Something went wrong - higher versions of DBI and/or DBD::SQLite than we expected" exit 1 fi @@ -174,9 +248,6 @@ if [[ "$CLEANTEST" = "true" ]] && perl -MModule::Build::Tiny -e1 &>/dev/null ; t 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) - -$(ci_vm_state_text)" +$(tstamp) Configuration phase seems to have taken $(date -ud "@$SECONDS" '+%H:%M:%S') (@$SECONDS)" diff --git a/maint/travis-ci_scripts/40_script.bash b/maint/travis-ci_scripts/40_script.bash old mode 100755 new mode 100644 index 25a35ff67..0a6ecd541 --- a/maint/travis-ci_scripts/40_script.bash +++ b/maint/travis-ci_scripts/40_script.bash @@ -28,12 +28,7 @@ if [[ "$CLEANTEST" = "true" ]] ; then run_or_err "Prepare blib" "make pure_all" run_harness_tests else - PROVECMD="prove -lrswj$VCPU_USE xt t" - - # FIXME - temporary, until Package::Stash is fixed - if perl -M5.010 -e 1 &>/dev/null ; then - PROVECMD="$PROVECMD -T" - fi + PROVECMD="prove -lrswTj$VCPU_USE xt t" # List every single SKIP/TODO when they are visible if [[ "$VCPU_USE" == 1 ]] ; then diff --git a/maint/travis-ci_scripts/50_after_failure.bash b/maint/travis-ci_scripts/50_after_failure.bash old mode 100755 new mode 100644 diff --git a/maint/travis-ci_scripts/50_after_success.bash b/maint/travis-ci_scripts/50_after_success.bash old mode 100755 new mode 100644 index 9642c3e84..fd30331a6 --- a/maint/travis-ci_scripts/50_after_success.bash +++ b/maint/travis-ci_scripts/50_after_success.bash @@ -11,6 +11,9 @@ export HARNESS_OPTIONS="j$VCPU_USE" if [[ "$DEVREL_DEPS" == "true" ]] && perl -M5.008003 -e1 &>/dev/null ; then + + [[ "$BREAK_CC" == "true" ]] && run_or_err "Unbreaking previously broken ~/bin/cc" "rm $HOME/bin/cc" + # FIXME - Devel::Cover (brought by Test::Strict, but soon needed anyway) # does not test cleanly on 5.8.7 - just get it directly if perl -M5.008007 -e1 &>/dev/null && ! perl -M5.008008 -e1 &>/dev/null; then @@ -24,13 +27,19 @@ if [[ "$DEVREL_DEPS" == "true" ]] && perl -M5.008003 -e1 &>/dev/null ; then parallel_installdeps_notest YAML Lexical::SealRequireHints fi + # FIXME - workaround for RT#117855/RT#117856 + if [[ -n "$PERL_UNICODE" ]] ; then + parallel_installdeps_notest Text::CSV + fi + # FIXME Change when Moose goes away installdeps Moose $(perl -Ilib -MDBIx::Class::Optional::Dependencies=-list_missing,dist_dir) - run_or_err "Attempt to build a dist" "rm -rf inc/ && perl Makefile.PL --skip-author-deps && make dist" + run_or_err "Attempt to build a dist" "rm -rf inc/ && perl Makefile.PL && make dist" tarball_assembled=1 elif [[ "$CLEANTEST" != "true" ]] ; then + parallel_installdeps_notest $(perl -Ilib -MDBIx::Class::Optional::Dependencies=-list_missing,dist_dir) run_or_err "Attempt to build a dist from original checkout" "make dist" @@ -88,9 +97,11 @@ if [[ -n "$tarball_assembled" ]] ; then export $e="" done + # FIXME - for some reason a plain `cpan .` does not work in this case + # no time to investigate run_or_err \ "Attempt to configure/test/build/install dist using latest CPAN@$(perl -MCPAN -e 'print CPAN->VERSION')" \ - "cpan ." + "perl -MCPAN -e 'install( q{.} )'" else run_or_err \ diff --git a/maint/travis-ci_scripts/60_after_script.bash b/maint/travis-ci_scripts/60_after_script.bash old mode 100755 new mode 100644 diff --git a/maint/travis-ci_scripts/common.bash b/maint/travis-ci_scripts/common.bash old mode 100755 new mode 100644 index f73added4..48fb7c1d1 --- a/maint/travis-ci_scripts/common.bash +++ b/maint/travis-ci_scripts/common.bash @@ -1,5 +1,10 @@ #!/bin/bash +if [[ "${BASH_SOURCE[0]}" == "${0}" ]] ; then + echo "This script can not be executed standalone - it can only be source()d" 1>&2 + exit 1 +fi + # "autodie" set -e @@ -15,6 +20,14 @@ fi tstamp() { echo -n "[$(date '+%H:%M:%S')]" ; } +CPAN_is_sane() { perl -MCPAN\ 1.94_56 -e 1 &>/dev/null ; } + +CPAN_supports_BUILDPL() { perl -MCPAN\ 1.9205 -e1 &>/dev/null; } + +have_sudo() { sudo /bin/true &>/dev/null ; } + +is_cperl() { [[ "$BREWVER" =~ $( echo -n "^cperl-" ) ]] ; } + ci_vm_state_text() { echo " ========================== CI System information ============================ @@ -91,7 +104,7 @@ apt_install() { # flatten pkgs="$@" - run_or_err "Installing Debian APT packages: $pkgs" "sudo apt-get install --allow-unauthenticated --no-install-recommends -y $pkgs" + run_or_err "Installing APT packages: $pkgs" "sudo apt-get install --allow-unauthenticated --no-install-recommends -y $pkgs" } extract_prereqs() { @@ -135,6 +148,8 @@ extract_prereqs() { parallel_installdeps_notest() { if [[ -z "$@" ]] ; then return; fi + is_cperl && echo_err "cpanminus is not yet usable on cperl" && exit 1 + # one module spec per line MODLIST="$(printf '%s\n' "$@" | sort -R)" @@ -165,7 +180,7 @@ parallel_installdeps_notest() { " } -export -f parallel_installdeps_notest run_or_err echo_err tstamp +export -f parallel_installdeps_notest run_or_err echo_err tstamp is_cperl have_sudo CPAN_is_sane CPAN_supports_BUILDPL installdeps() { if [[ -z "$@" ]] ; then return; fi @@ -194,6 +209,8 @@ installdeps() { _dep_inst_with_test() { if [[ "$DEVREL_DEPS" == "true" ]] ; then + is_cperl && echo_err "cpanminus is not yet usable on cperl" && exit 1 + # --dev is already part of CPANM_OPT LASTCMD="$TIMEOUT_CMD cpanm $@" $LASTCMD 2>&1 || return 1 @@ -321,10 +338,3 @@ purge_sitelib() { fi } - - -CPAN_is_sane() { perl -MCPAN\ 1.94_56 -e 1 &>/dev/null ; } - -CPAN_supports_BUILDPL() { perl -MCPAN\ 1.9205 -e1 &>/dev/null; } - -have_sudo() { sudo /bin/true &>/dev/null ; } diff --git a/maint/travis_buildlog_downloader b/maint/travis_buildlog_downloader new file mode 100755 index 000000000..3287d3591 --- /dev/null +++ b/maint/travis_buildlog_downloader @@ -0,0 +1,41 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +# H::T does not support gzip/deflate out of the box, but you know what? +# THAT'S OK BECAUSE TRAVIS' LOGSERVER DOESN'T EITHER +use HTTP::Tiny; + +use JSON::PP; + +( my $build_id = $ARGV[0]||'' ) =~ /^[0-9]+$/ + or die "Expecting a numeric build id as argument\n"; + +my $base_url = "http://api.travis-ci.org/builds/$build_id"; +print "Retrieving $base_url\n"; + +my $resp = ( my $ua = HTTP::Tiny->new )->get( $base_url ); +die "Unable to retrieve $resp->{url}: $resp->{status}\n$resp->{content}\n\n" + unless $resp->{success}; + +my @jobs = ( map + { ( ($_->{id}||'') =~ /^([0-9]+)$/ ) ? [ $1 => $_->{number} ] : () } + @{( eval { decode_json( $resp->{content} )->{matrix} } || [] )} +) or die "Unable to find any jobs:\n$resp->{content}\n\n"; + +my $dir = "TravisCI_build_$build_id"; + +mkdir $dir + unless -d $dir; + +for my $job (@jobs) { + my $log_url = "http://api.travis-ci.org/jobs/$job->[0]/log.txt"; + my $dest_fn = "$dir/job_$job->[1].$job->[0].log"; + + print "Retrieving $log_url into $dest_fn\n"; + + $resp = $ua->mirror( $log_url, $dest_fn ); + warn "Error retrieving $resp->{url}: $resp->{status}\n$resp->{content}\n\n" + unless $resp->{success}; +} diff --git a/script/dbicadmin b/script/dbicadmin index bdd618c2d..414b58297 100755 --- a/script/dbicadmin +++ b/script/dbicadmin @@ -71,21 +71,21 @@ if(defined (my $fn = $opts->{documentation_as_pod}) ) { $usage->synopsis($synopsis_text); $usage->short_description($short_description); + my $fh; if ($fn) { - require File::Spec; - require File::Path; - my $dir = File::Spec->catpath( (File::Spec->splitpath($fn))[0,1] ); - File::Path::mkpath([$dir]); + require DBIx::Class::_Util; + DBIx::Class::_Util::mkdir_p( DBIx::Class::_Util::parent_dir( $fn ) ); + open( $fh, '>', $fn ) or die "Unable to open $fn: $!\n"; + } + else { + $fh = \*STDOUT; } - 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"; + print $fh "\n"; + print $fh $usage->pod; + print $fh "\n"; - close STDOUT if $fn; + close $fh if $fn; exit 0; } diff --git a/t/00describe_environment.t b/t/00describe_environment.t index 35e6b02f4..fc1c6942e 100644 --- a/t/00describe_environment.t +++ b/t/00describe_environment.t @@ -11,9 +11,9 @@ BEGIN { @initial_INC = @INC; } -BEGIN { - unshift @INC, 't/lib'; +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } +BEGIN { if ( "$]" < 5.010) { # Pre-5.10 perls pollute %INC on unsuccesfull module @@ -48,6 +48,15 @@ use strict; use warnings; use Test::More 'no_plan'; + +# Things happen... unfortunately +$SIG{__DIE__} = sub { + die $_[0] unless defined $^S and ! $^S; + + diag "Something horrible happened while assembling the diag data\n$_[0]"; + exit 0; +}; + use Config; use File::Find 'find'; use Digest::MD5 (); @@ -57,7 +66,7 @@ use List::Util 'max'; use ExtUtils::MakeMaker; use DBICTest::RunMode; -use DBICTest::Util 'visit_namespaces'; +use DBIx::Class::_Util 'visit_namespaces'; use DBIx::Class::Optional::Dependencies; my $known_paths = { @@ -167,6 +176,8 @@ find({ wanted => sub { -f $_ or return; + $_ =~ m|lib/DBIx/Class/_TempExtlib| and return; + # can't just `require $fn`, as we need %INC to be # populated properly my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x @@ -192,6 +203,7 @@ my $load_weights = { my @known_modules = sort { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) } + qw( Data::Dumper ), keys %{ DBIx::Class::Optional::Dependencies->req_list_for([ grep @@ -410,9 +422,10 @@ my $max_ver_len = max map ; my $max_marker_len = max map { length $_ } ( '$INC[999]', keys %$seen_markers ); +# Note - must be less than 76 chars wide to account for the diag() prefix my $discl = <<'EOD'; -List of loadable modules within both the core and *OPTIONAL* dependency chains +List of loadable modules within both *OPTIONAL* and core dependency chains present on this system (modules sourced from ./blib, ./lib, ./t, and ./xt with versions identical to their parent namespace were omitted for brevity) @@ -498,6 +511,11 @@ $final_out .= "=============================\n$discl\n\n"; diag $final_out; +# *very* large printouts may not finish flushing before the test exits +# injecting a ... ok in the middle of the diag +# http://www.cpantesters.org/cpan/report/fbdac74c-35ca-11e6-ab41-c893a58a4b8c +select( undef, undef, undef, 0.2 ); + exit 0; @@ -521,12 +539,18 @@ sub abs_unix_path { # File::Spec's rel2abs does not resolve symlinks # we *need* to look at the filesystem to be sure - my $abs_fn = abs_path($_[0]); + # + # But looking at the FS for non-existing basenames *may* + # throw on some OSes so be extra paranoid: + # http://www.cpantesters.org/cpan/report/26a6e42f-6c23-1014-b7dd-5cd275d8a230 + # + my $abs_fn = eval { abs_path($_[0]) } || ''; - if ( $^O eq 'MSWin32' and $abs_fn ) { + if ( $abs_fn and $^O eq 'MSWin32' ) { # sometimes we can get a short/longname mix, normalize everything to longnames - $abs_fn = Win32::GetLongPathName($abs_fn); + $abs_fn = Win32::GetLongPathName($abs_fn) + if -e $abs_fn; # Fixup (native) slashes in Config not matching (unixy) slashes in INC $abs_fn =~ s|\\|/|g; @@ -540,7 +564,7 @@ sub shorten_fn { my $abs_fn = abs_unix_path($fn); - if (my $p = subpath_of_known_path( $fn ) ) { + if ($abs_fn and my $p = subpath_of_known_path( $fn ) ) { $abs_fn =~ s| (?[$i]; + # searching from here on out won't mean anything + # FIXME - there is actually a way to interrogate this safely, but + # that's a fight for another day + return undef if length ref $inc_dirs->[$i]; + + return $i + if 0 == index( $existing_path, abs_unix_path( $inc_dirs->[$i] ) . '/' ); + } + } + + for my $i ( 0 .. $#$inc_dirs ) { if ( -d $inc_dirs->[$i] diff --git a/t/05components.t b/t/05components.t index 63138635a..335fb068f 100644 --- a/t/05components.t +++ b/t/05components.t @@ -1,13 +1,21 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; -use DBICTest::ForeignComponent; + +{ + package DBICTest::SomeResult; + use base 'DBIx::Class::Core'; + __PACKAGE__->table("boguz"); +} # Tests if foreign component was loaded by calling foreign's method -ok( DBICTest::ForeignComponent->foreign_test_method, 'foreign component' ); +ok( ! $INC{"DBICTest/ForeignComponent.pm"}, "DBICTest::ForeignComponent not yet loaded" ); +ok( DBICTest::SomeResult->result_class("DBICTest::ForeignComponent")->foreign_test_method, 'foreign component loaded correctly' ); # Test for inject_base to filter out duplicates { package DBICTest::_InjectBaseTest; diff --git a/t/100extra_source.t b/t/100extra_source.t index 490bbeccb..b345ce16c 100644 --- a/t/100extra_source.t +++ b/t/100extra_source.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; { diff --git a/t/100populate.t b/t/100populate.t index 4b7f9292d..2817e5b2b 100644 --- a/t/100populate.t +++ b/t/100populate.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest; use DBIx::Class::_Util qw(sigwarn_silencer serialize); use Math::BigInt; diff --git a/t/101populate_rs.t b/t/101populate_rs.t index 5686c3ec4..7f356d9df 100644 --- a/t/101populate_rs.t +++ b/t/101populate_rs.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + ## ---------------------------------------------------------------------------- ## Tests for the $resultset->populate method. ## @@ -14,7 +16,7 @@ use warnings; use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; diff --git a/t/101source.t b/t/101source.t index 477a4dd8b..889945b98 100644 --- a/t/101source.t +++ b/t/101source.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema; diff --git a/t/102load_classes.t b/t/102load_classes.t index 893601498..d391b3423 100644 --- a/t/102load_classes.t +++ b/t/102load_classes.t @@ -1,15 +1,17 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib 't/lib'; + use DBICTest; my $warnings; eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICTest::Schema; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; __PACKAGE__->load_classes; }; ok(!$@, 'Loaded all loadable classes') or diag $@; diff --git a/t/104view.t b/t/104view.t index 4abe7e82a..a3668b2b4 100644 --- a/t/104view.t +++ b/t/104view.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/106dbic_carp.t b/t/106dbic_carp.t index f6bd91d8a..171e7db1f 100644 --- a/t/106dbic_carp.t +++ b/t/106dbic_carp.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -7,7 +9,7 @@ BEGIN { $ENV{DBIC_TRACE} = 0 } use Test::More; use Test::Warn; use Test::Exception; -use lib 't/lib'; + use DBICTest; use DBIx::Class::Carp; diff --git a/t/107obj_result_class.t b/t/107obj_result_class.t index f616bcbbc..d09d5c2bb 100644 --- a/t/107obj_result_class.t +++ b/t/107obj_result_class.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + package ResultClassInflator; sub new { bless {}, __PACKAGE__ } @@ -11,7 +13,7 @@ use warnings; use Test::More tests => 6; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/18insert_default.t b/t/18insert_default.t index 17657cc66..db8fb5663 100644 --- a/t/18insert_default.t +++ b/t/18insert_default.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/19retrieve_on_insert.t b/t/19retrieve_on_insert.t index d25818066..c8ecf34b2 100644 --- a/t/19retrieve_on_insert.t +++ b/t/19retrieve_on_insert.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/20setuperrors.t b/t/20setuperrors.t index ede7e294a..609581749 100644 --- a/t/20setuperrors.t +++ b/t/20setuperrors.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; use Test::Exception; -use lib 't/lib'; + use DBICTest; throws_ok ( diff --git a/t/26dumper.t b/t/26dumper.t index ade503184..c964655c3 100644 --- a/t/26dumper.t +++ b/t/26dumper.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; @@ -5,7 +7,7 @@ use Test::More; use Data::Dumper; $Data::Dumper::Sortkeys = 1; -use lib qw(t/lib); + use_ok('DBICTest'); my $schema = DBICTest->init_schema(); diff --git a/t/33exception_wrap.t b/t/33exception_wrap.t index 3b351ab9d..0acc6901f 100644 --- a/t/33exception_wrap.t +++ b/t/33exception_wrap.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -5,8 +7,6 @@ use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); - use DBICTest; my $schema = DBICTest->init_schema; diff --git a/t/34exception_action.t b/t/34exception_action.t index d7885d5e2..aa803eb23 100644 --- a/t/34exception_action.t +++ b/t/34exception_action.t @@ -1,10 +1,13 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); +use Scalar::Util 'weaken'; + use DBICTest; # Set up the "usual" sqlite for DBICTest @@ -100,14 +103,14 @@ for my $ap (qw( # make sure an exception_action can replace $@ with an antipattern $schema->exception_action(sub { die $ap->new }); - warnings_like { + warnings_exist { eval { $throw->() }; isa_ok $@, $ap; } $exp_warn, 'proper warning on antipattern encountered within exception_action'; # and make sure that the rethrow works $schema->exception_action(sub { die @_ }); - warnings_like { + warnings_exist { eval { $schema->txn_do (sub { die $ap->new }); }; @@ -116,4 +119,19 @@ for my $ap (qw( } $exp_warn, 'Proper warning on encountered antipattern'; } +# ensure we do not get into an infloop +{ + weaken( my $s = $schema ); + + $schema->exception_action(sub{ + $s->throw_exception(@_) + }); + + throws_ok { + $schema->storage->dbh_do(sub { + $_[1]->do('wgwfwfwghawhjsejsethjwetjesjesjsejsetjes') + } ) + } qr/syntax error/i; +} + done_testing; diff --git a/t/35exception_inaction.t b/t/35exception_inaction.t index 0d8597f94..a75ee6142 100644 --- a/t/35exception_inaction.t +++ b/t/35exception_inaction.t @@ -1,7 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib 't/lib'; + use DBICTest::RunMode; BEGIN { if( DBICTest::RunMode->is_plain ) { @@ -10,8 +12,7 @@ BEGIN { } } -use File::Temp (); -use DBIx::Class::_Util 'scope_guard'; +use DBICTest::Util 'capture_stderr'; use DBIx::Class::Schema; # Do not use T::B - the test is hard enough not to segfault as it is @@ -38,37 +39,20 @@ sub ok { return !!$_[0]; } -# yes, make it even dirtier -my $schema = 'DBIx::Class::Schema'; - -$schema->connection('dbi:SQLite::memory:'); - # this is incredibly horrible... # demonstrate utter breakage of the reconnection/retry logic # -open(my $stderr_copy, '>&', *STDERR) or die "Unable to dup STDERR: $!"; -my $tf = File::Temp->new( UNLINK => 1 ); - -my $output; - +my $output = capture_stderr { ESCAPE: { - my $guard = scope_guard { - close STDERR; - open(STDERR, '>&', $stderr_copy); - $output = do { local (@ARGV, $/) = $tf; <> }; - close $tf; - unlink $tf; - undef $tf; - close $stderr_copy; - }; - - close STDERR; - open(STDERR, '>&', $tf) or die "Unable to reopen STDERR: $!"; + # yes, make it even dirtier + my $schema = 'DBIx::Class::Schema'; + $schema->connection('dbi:SQLite::memory:'); $schema->storage->ensure_connected; $schema->storage->_dbh->disconnect; + # silences "exitting sub via last" local $SIG{__WARN__} = sub {}; $schema->exception_action(sub { @@ -84,7 +68,7 @@ ESCAPE: # NEITHER will this ok(0, "Nope"); -} +}}; ok(1, "Post-escape reached"); diff --git a/t/36double_destroy.t b/t/36double_destroy.t new file mode 100644 index 000000000..8fc4cb706 --- /dev/null +++ b/t/36double_destroy.t @@ -0,0 +1,43 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; + +use DBICTest::Util 'capture_stderr'; + +use DBICTest; + +my $output; + +# ensure Devel::StackTrace-refcapture-like effects are countered +{ + my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); + my $g = $s->txn_scope_guard; + + my @arg_capture; + { + local $SIG{__WARN__} = sub { + package DB; + my $frnum; + while (my @f = CORE::caller(++$frnum) ) { + push @arg_capture, @DB::args; + } + }; + + undef $g; + 1; + } + + # this should emit on stderr + $output = capture_stderr { @arg_capture = () }; +}; + +like( + $output, + qr/\QPreventing *MULTIPLE* DESTROY() invocations on DBIx::Class::Storage::TxnScopeGuard/, + 'Proper warning emitted on STDERR' +); + +done_testing; diff --git a/t/39load_namespaces_1.t b/t/39load_namespaces_1.t index 0f8ae1ee9..f7fb08ee2 100644 --- a/t/39load_namespaces_1.t +++ b/t/39load_namespaces_1.t @@ -1,15 +1,17 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; # do not remove even though it is not used my $warnings; eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICNSTest; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; __PACKAGE__->load_namespaces; }; ok(!$@, 'load_namespaces doesnt die') or diag $@; diff --git a/t/39load_namespaces_2.t b/t/39load_namespaces_2.t index d9b88fa9f..1e73c7f6e 100644 --- a/t/39load_namespaces_2.t +++ b/t/39load_namespaces_2.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; # do not remove even though it is not used plan tests => 6; @@ -11,7 +13,7 @@ my $warnings; eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICNSTest; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; __PACKAGE__->load_namespaces( result_namespace => 'Rslt', resultset_namespace => 'RSet', diff --git a/t/39load_namespaces_3.t b/t/39load_namespaces_3.t index 99ad8a952..1b63baa83 100644 --- a/t/39load_namespaces_3.t +++ b/t/39load_namespaces_3.t @@ -1,16 +1,18 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest; # do not remove even though it is not used lives_ok (sub { warnings_exist ( sub { package DBICNSTestOther; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; __PACKAGE__->load_namespaces( result_namespace => [ '+DBICNSTest::Rslt', '+DBICNSTest::OtherRslt' ], resultset_namespace => '+DBICNSTest::RSet', diff --git a/t/39load_namespaces_4.t b/t/39load_namespaces_4.t index 1bdc49d56..789ed5097 100644 --- a/t/39load_namespaces_4.t +++ b/t/39load_namespaces_4.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; # do not remove even though it is not used plan tests => 6; @@ -11,7 +13,7 @@ my $warnings; eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICNSTest; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; __PACKAGE__->load_namespaces( default_resultset_class => 'RSBase' ); }; ok(!$@) or diag $@; diff --git a/t/39load_namespaces_exception.t b/t/39load_namespaces_exception.t index c5a03df6e..14bf34222 100644 --- a/t/39load_namespaces_exception.t +++ b/t/39load_namespaces_exception.t @@ -1,15 +1,17 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; # do not remove even though it is not used plan tests => 1; eval { package DBICNSTest; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; __PACKAGE__->load_namespaces( result_namespace => 'Bogus', resultset_namespace => 'RSet', diff --git a/t/39load_namespaces_rt41083.t b/t/39load_namespaces_rt41083.t index 258429031..f59d59758 100644 --- a/t/39load_namespaces_rt41083.t +++ b/t/39load_namespaces_rt41083.t @@ -1,7 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib 't/lib'; + use DBICTest; # do not remove even though it is not used use Test::More tests => 8; @@ -30,7 +32,7 @@ sub _verify_sources { eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICNSTest::RtBug41083; - use base 'DBIx::Class::Schema'; + use base 'DBICTest::BaseSchema'; __PACKAGE__->load_namespaces( result_namespace => 'Result_A', resultset_namespace => 'ResultSet_A', @@ -50,7 +52,7 @@ sub _verify_sources { eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICNSTest::RtBug41083; - use base 'DBIx::Class::Schema'; + use base 'DBICTest::BaseSchema'; __PACKAGE__->load_namespaces( default_resultset_class => 'ResultSet' ); diff --git a/t/39load_namespaces_stress.t b/t/39load_namespaces_stress.t index db178ee2a..bfef36056 100644 --- a/t/39load_namespaces_stress.t +++ b/t/39load_namespaces_stress.t @@ -1,9 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use Time::HiRes qw/gettimeofday/; -use lib qw(t/lib); use DBICTest; # do not remove even though it is not used our $src_count = 100; @@ -27,7 +27,7 @@ EOM { package DBICTest::NS::Stress::Schema; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; sub _findallmod { return $_[1] eq ( __PACKAGE__ . '::Result' ) @@ -39,10 +39,7 @@ EOM is (DBICTest::NS::Stress::Schema->sources, 0, 'Start with no sources'); - -note gettimeofday . ":\tload_namespaces start"; DBICTest::NS::Stress::Schema->load_namespaces; -note gettimeofday . ":\tload_namespaces finished"; is (DBICTest::NS::Stress::Schema->sources, $src_count, 'All sources attached'); diff --git a/t/40compose_connection.t b/t/40compose_connection.t index 051ab9ba3..2732a5e62 100644 --- a/t/40compose_connection.t +++ b/t/40compose_connection.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; warnings_exist { DBICTest->init_schema( compose_connection => 1, sqlite_use_file => 1 ) } diff --git a/t/46where_attribute.t b/t/46where_attribute.t index f798ace4e..0fedbe7b3 100644 --- a/t/46where_attribute.t +++ b/t/46where_attribute.t @@ -1,8 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); +use Test::Warn; + use DBICTest; my $schema = DBICTest->init_schema(); @@ -20,9 +23,12 @@ is($programming_perl->id, 1, 'select from a resultset with find_or_create for ex # and inserts? my $see_spot; -$see_spot = eval { $owner->books->find_or_create({ title => "See Spot Run" }) }; -if ($@) { print $@ } -ok(!$@, 'find_or_create on resultset with attribute for non-existent entry did not throw'); +$see_spot = eval { + warnings_exist { + $owner->books->find_or_create({ title => "See Spot Run" }) + } qr/Missing value for primary key column 'id' on BooksInLibrary - perhaps you forgot to set its 'is_auto_increment'/; +}; +is ($@, '', 'find_or_create on resultset with attribute for non-existent entry did not throw'); ok(defined $see_spot, 'successfully did insert on resultset with attribute for non-existent entry'); my $see_spot_rs = $owner->books->search({ title => "See Spot Run" }); diff --git a/t/50fork.t b/t/50fork.t index a9fbdec88..229a4f249 100644 --- a/t/50fork.t +++ b/t/50fork.t @@ -1,20 +1,22 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_pg'; use strict; use warnings; use Test::More; use Test::Exception; +use Time::HiRes qw(time sleep); +use List::Util 'max'; -use lib qw(t/lib); use DBICTest; my $main_pid = $$; -# README: If you set the env var to a number greater than 10, +# README: If you set the env var to a number greater than 5, # we will use that many children my $num_children = $ENV{DBICTEST_FORK_STRESS} || 1; -if($num_children !~ /^[0-9]+$/ || $num_children < 10) { - $num_children = 10; +if($num_children !~ /^[0-9]+$/ || $num_children < 5) { + $num_children = 5; } my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; @@ -87,6 +89,11 @@ ok(!$@) or diag "Creation eval failed: $@"; } $parent_rs->reset; + +# sleep until this spot so everything starts simultaneously +# add "until turn of second" for prettier display +my $t = int( time() ) + 4; + my @pids; while(@pids < $num_children) { @@ -101,6 +108,9 @@ while(@pids < $num_children) { $pid = $$; + sleep( max( 0.1, $t - time ) ); + note ("Child process $pid starting work at " . time() ); + my $work = sub { my $child_rs = $schema->resultset('CD')->search({ year => 1901 }); my $row = $parent_rs->next; @@ -121,7 +131,7 @@ while(@pids < $num_children) { $work->(); } - sleep(3); + sleep(2); exit 0; } diff --git a/t/51threadnodb.t b/t/51threadnodb.t deleted file mode 100644 index 3af78d575..000000000 --- a/t/51threadnodb.t +++ /dev/null @@ -1,66 +0,0 @@ -use Config; -BEGIN { - unless ($Config{useithreads}) { - print "1..0 # SKIP your perl does not support ithreads\n"; - exit 0; - } - - if ($INC{'Devel/Cover.pm'}) { - print "1..0 # SKIP Devel::Cover does not work with threads yet\n"; - exit 0; - } -} -use threads; - -use strict; -use warnings; -use Test::More; -use DBIx::Class::_Util 'sigwarn_silencer'; - -use lib qw(t/lib); -use DBICTest; - -plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' - if "$]" < 5.008005; - -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 -my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; -if($num_children !~ /^[0-9]+$/ || $num_children < 10) { - $num_children = 10; -} - -my $schema = DBICTest->init_schema(no_deploy => 1); -isa_ok ($schema, 'DBICTest::Schema'); - -my @threads; -SKIP: { - - local $SIG{__WARN__} = sigwarn_silencer( qr/Thread creation failed/i ); - - for (1.. $num_children) { - push @threads, threads->create(sub { - my $rsrc = $schema->source('Artist'); - undef $schema; - isa_ok ($rsrc->schema, 'DBICTest::Schema'); - my $s2 = $rsrc->schema->clone; - - sleep 1; # without this many tasty crashes - }) || do { - skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 - if $! == Errno::EAGAIN(); - - die "Unable to start thread: $!"; - }; - } -} - -ok(1, "past spawning"); - -$_->join for @threads; -ok(1, "past joining"); - -done_testing; diff --git a/t/51threads.t b/t/51threads.t index ae3addc49..d5cd0d5bc 100644 --- a/t/51threads.t +++ b/t/51threads.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use Config; BEGIN { unless ($Config{useithreads}) { @@ -19,18 +21,20 @@ use warnings; use Test::More; use Test::Exception; +use Time::HiRes qw(time sleep); +use List::Util 'max'; plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' if "$]" < 5.008005; -use lib qw(t/lib); + use DBICTest; -# README: If you set the env var to a number greater than 10, +# README: If you set the env var to a number greater than 5, # we will use that many children my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; -if($num_children !~ /^[0-9]+$/ || $num_children < 10) { - $num_children = 10; +if($num_children !~ /^[0-9]+$/ || $num_children < 5) { + $num_children = 5; } my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; @@ -83,7 +87,7 @@ lives_ok (sub { done_testing; close $tb->$_ for (qw/output failure_output todo_output/); - sleep(1); # tasty crashes without this + sleep (0.2); # tasty crashes without this $out; }; @@ -101,18 +105,31 @@ lives_ok (sub { } $parent_rs->reset; + +# sleep until this spot so everything starts simultaneously +# add "until turn of second" for prettier display +my $t = int( time() ) + 4; + my @children; while(@children < $num_children) { my $newthread = async { my $tid = threads->tid; + sleep( max( 0.1, $t - time ) ); + + # FIXME if we do not stagger the threads, sparks fly due to CXSA + sleep ( $tid / 10 ) if "$]" < 5.012; + + note ("Thread $tid starting work at " . time() ); + my $child_rs = $schema->resultset('CD')->search({ year => 1901 }); my $row = $parent_rs->next; if($row && $row->get_column('artist') =~ /^(?:123|456)$/) { $schema->resultset('CD')->create({ title => "test success $tid", artist => $tid, year => scalar(@children) }); } - sleep(1); # tasty crashes without this + + sleep (0.2); # without this many tasty crashes even on latest perls }; die "Thread creation failed: $! $@" if !defined $newthread; push(@children, $newthread); @@ -120,16 +137,17 @@ while(@children < $num_children) { ok(1, "past spawning"); -{ - $_->join for(@children); +my @tids; +for (@children) { + push @tids, $_->tid; + $_->join; } ok(1, "past joining"); -while(@children) { - my $child = pop(@children); - my $tid = $child->tid; - my $rs = $schema->resultset('CD')->search({ title => "test success $tid", artist => $tid, year => scalar(@children) }); +while (@tids) { + my $tid = pop @tids; + my $rs = $schema->resultset('CD')->search({ title => "test success $tid", artist => $tid, year => scalar(@tids) }); is($rs->next->get_column('artist'), $tid, "Child $tid successful"); } @@ -138,4 +156,9 @@ undef $parent_rs; $schema->storage->dbh->do("DROP TABLE cd"); +# Too many threading bugs on exit, none of which have anything to do with +# the actual stuff we test +$ENV{DBICTEST_DIRTY_EXIT} = 1 + if "$]" < 5.012; + done_testing; diff --git a/t/51threadtxn.t b/t/51threadtxn.t index e74c7c175..6c781e562 100644 --- a/t/51threadtxn.t +++ b/t/51threadtxn.t @@ -1,4 +1,6 @@ -# README: If you set the env var to a number greater than 10, +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +# README: If you set the env var to a number greater than 5, # we will use that many children use Config; @@ -26,12 +28,14 @@ plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' if "$]" < 5.008005; use Scalar::Util 'weaken'; -use lib qw(t/lib); +use Time::HiRes qw(time sleep); +use List::Util 'max'; + use DBICTest; my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; -if($num_children !~ /^[0-9]+$/ || $num_children < 10) { - $num_children = 10; +if($num_children !~ /^[0-9]+$/ || $num_children < 5) { + $num_children = 5; } my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; @@ -57,11 +61,23 @@ eval { }; ok(!$@) or diag "Creation eval failed: $@"; +# sleep until this spot so everything starts simultaneously +# add "until turn of second" for prettier display +my $t = int( time() ) + 4; + my @children; while(@children < $num_children) { my $newthread = async { my $tid = threads->tid; + + sleep( max( 0.1, $t - time ) ); + + # FIXME if we do not stagger the threads, sparks fly due to CXSA + sleep ( $tid / 10 ) if "$]" < 5.012; + + note ("Thread $tid starting work at " . time() ); + weaken(my $weak_schema = $schema); weaken(my $weak_parent_rs = $parent_rs); $schema->txn_do(sub { @@ -71,7 +87,8 @@ while(@children < $num_children) { $weak_schema->resultset('CD')->create({ title => "test success $tid", artist => $tid, year => scalar(@children) }); } }); - sleep(1); # tasty crashes without this + + sleep (0.2); # without this many tasty crashes even on latest perls }; die "Thread creation failed: $! $@" if !defined $newthread; push(@children, $newthread); @@ -96,4 +113,9 @@ ok(1, "Made it to the end"); $schema->storage->dbh->do("DROP TABLE cd"); +# Too many threading bugs on exit, none of which have anything to do with +# the actual stuff we test +$ENV{DBICTEST_DIRTY_EXIT} = 1 + if "$]" < 5.012; + done_testing; diff --git a/t/52leaks.t b/t/52leaks.t index c6b64c261..b395483dc 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + # work around brain damage in PPerl (yes, it has to be a global) $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /\QUse of "goto" to jump into a construct is deprecated/ @@ -21,16 +23,17 @@ use strict; use warnings; use Test::More; -use lib qw(t/lib); -use DBICTest::RunMode; -use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs); -use Scalar::Util qw(weaken blessed reftype); -use DBIx::Class::_Util qw(hrefaddr sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt); BEGIN { + require DBICTest::Util; plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test" - if DBIx::Class::_ENV_::PEEPEENESS; + if DBICTest::Util::PEEPEENESS(); } +use DBICTest::RunMode; +use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs); +use Scalar::Util qw(weaken blessed reftype); +use DBIx::Class::_Util qw(hrefaddr sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt); +use DBIx::Class::Optional::Dependencies; my $TB = Test::More->builder; if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) { @@ -56,6 +59,7 @@ my $has_dt; # Skip the heavy-duty leak tracing when just doing an install # or when having Moose crap all over everything +# FIXME - remove when Replicated gets off Moose if ( !$ENV{DBICTEST_VIA_REPLICATED} and !DBICTest::RunMode->is_plain ) { # redefine the bless override so that we can catch each and every object created @@ -86,26 +90,36 @@ if ( !$ENV{DBICTEST_VIA_REPLICATED} and !DBICTest::RunMode->is_plain ) { return populate_weakregistry ($weak_registry, $obj ); }; - require Try::Tiny; - for my $func (qw/try catch finally/) { - my $orig = \&{"Try::Tiny::$func"}; - *{"Try::Tiny::$func"} = sub (&;@) { + + for my $func (qw( dbic_internal_try dbic_internal_catch )) { + my $orig = \&{"DBIx::Class::_Util::$func"}; + *{"DBIx::Class::_Util"} = sub (&;@) { populate_weakregistry( $weak_registry, $_[0] ); goto $orig; } } + if ( eval { require Try::Tiny } ) { + for my $func (qw( try catch finally )) { + my $orig = \&{"Try::Tiny::$func"}; + *{"Try::Tiny::$func"} = sub (&;@) { + populate_weakregistry( $weak_registry, $_[0] ); + goto $orig; + } + } + } + + # Some modules are known to install singletons on-load # Load them and empty the registry # this loads the DT armada $has_dt = DBIx::Class::Optional::Dependencies->req_ok_for([qw( test_rdbms_sqlite ic_dt )]); - require Errno; require DBI; require DBD::SQLite; - require FileHandle; require Moo; + require Math::BigInt; %$weak_registry = (); } @@ -441,6 +455,10 @@ for my $addr (keys %$weak_registry) { # T::B 2.0 has result objects and other fancyness delete $weak_registry->{$addr}; } + # remove this when IO::Dir is gone from SQLT + elsif ($INC{"IO/Dir.pm"} and $names =~ /^Class::Struct::Tie_ISA/m) { + delete $weak_registry->{$addr}; + } elsif ($names =~ /^Hash::Merge/m) { # only clear one object of a specific behavior - more would indicate trouble delete $weak_registry->{$addr} @@ -454,6 +472,15 @@ for my $addr (keys %$weak_registry) { delete $weak_registry->{$addr} unless $cleared->{bheos_pptiehinthashfieldhash}++; } + elsif ( + $names =~ /^Data::Dumper/m + and + $weak_registry->{$addr}{stacktrace} =~ /\bDBIx::Class::SQLMaker::Util::lax_serialize\b/ + ) { + # only clear one object of a specific behavior - more would indicate trouble + delete $weak_registry->{$addr} + unless $cleared->{dd_lax_serializer}++; + } elsif ($names =~ /^DateTime::TimeZone::UTC/m) { # DT is going through a refactor it seems - let it leak zones for now delete $weak_registry->{$addr}; @@ -531,6 +558,9 @@ SKIP: { if modver_gt_or_eq_and_lt( 'Test::More', '1.200', '1.301001_099' ); local $ENV{DBICTEST_IN_PERSISTENT_ENV} = 1; + local $ENV{DBICTEST_ANFANG_DEFANG} = 1; + + require File::Spec; $persistence_tests = { PPerl => { diff --git a/t/60core.t b/t/60core.t index 595df62d1..2f30ad74b 100644 --- a/t/60core.t +++ b/t/60core.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); @@ -123,19 +125,8 @@ warnings_exist { $schema->resultset('Artist')->search_rs(id => 4) } qr/\Qsearch( %condition ) is deprecated/, 'Deprecation warning on ->search( %condition )'; -# this has been warning for 4 years, killing -throws_ok { - $schema->resultset('Artist')->find(artistid => 4); -} qr|expects either a column/value hashref, or a list of values corresponding to the columns of the specified unique constraint|; - is($schema->resultset("Artist")->count, 4, 'count ok'); -# test find on an unresolvable condition -is( - $schema->resultset('Artist')->find({ artistid => [ -and => 1, 2 ]}), - undef -); - # test find_or_new { @@ -548,17 +539,6 @@ lives_ok (sub { my $newlink = $newbook->link}, "stringify to false value doesn't isa_ok( $new_artist, 'DBIx::Class::Row', '$rs->new gives a row object' ); } - -# make sure we got rid of the compat shims -SKIP: { - 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, removed before $remove_version"); - } -} - #------------------------------ # READ THIS BEFORE "FIXING" #------------------------------ diff --git a/t/61findnot.t b/t/61findnot.t index ab709e365..e9fe1ac75 100644 --- a/t/61findnot.t +++ b/t/61findnot.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/63register_class.t b/t/63register_class.t index 63704644e..0229713f0 100644 --- a/t/63register_class.t +++ b/t/63register_class.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More tests => 2; -use lib qw(t/lib); + use DBICTest; use DBICTest::Schema; use DBICTest::Schema::Artist; diff --git a/t/63register_column.t b/t/63register_column.t index 21de95d54..7f5d2c3a1 100644 --- a/t/63register_column.t +++ b/t/63register_column.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; lives_ok { diff --git a/t/63register_source.t b/t/63register_source.t index 6951962a8..b4eb206d3 100644 --- a/t/63register_source.t +++ b/t/63register_source.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::Exception tests => 1; -use lib qw(t/lib); + use DBICTest; use DBICTest::Schema; use DBIx::Class::ResultSource::Table; diff --git a/t/64db.t b/t/64db.t index 1a0046d3c..9f293e2db 100644 --- a/t/64db.t +++ b/t/64db.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/65multipk.t b/t/65multipk.t index cd0e108ef..31c0d41c8 100644 --- a/t/65multipk.t +++ b/t/65multipk.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/67pager.t b/t/67pager.t index fa7c93a0e..994cf406b 100644 --- a/t/67pager.t +++ b/t/67pager.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/69update.t b/t/69update.t index ea1eaae89..bd9d31423 100644 --- a/t/69update.t +++ b/t/69update.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/70auto.t b/t/70auto.t index 839c80725..49717765e 100644 --- a/t/70auto.t +++ b/t/70auto.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/71mysql.t b/t/71mysql.t index 1b967de8a..4ea9aa2e9 100644 --- a/t/71mysql.t +++ b/t/71mysql.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_mysql'; use strict; @@ -11,7 +12,7 @@ use B::Deparse; use DBI::Const::GetInfoType; use Scalar::Util qw/weaken/; -use lib qw(t/lib); +use DBICTest::Util 'PEEPEENESS'; use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}; @@ -410,7 +411,7 @@ ZEROINSEARCH: { { local $TODO = "Perl $] is known to leak like a sieve" - if DBIx::Class::_ENV_::PEEPEENESS; + if PEEPEENESS; ok (! defined $orig_dbh, 'Parent $dbh handle is gone'); } @@ -434,7 +435,7 @@ ZEROINSEARCH: { { local $TODO = "Perl $] is known to leak like a sieve" - if DBIx::Class::_ENV_::PEEPEENESS; + if PEEPEENESS; ok (! defined $orig_dbh, 'DBIC operation triggered reconnect - old $dbh is gone'); } diff --git a/t/72pg.t b/t/72pg.t index 71213e84a..1f0cc0700 100644 --- a/t/72pg.t +++ b/t/72pg.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_pg'; use strict; @@ -6,13 +7,10 @@ use warnings; use Test::More; use Test::Exception; use Test::Warn; -use Sub::Name; use Config; -use DBIx::Class::Optional::Dependencies (); -use lib qw(t/lib); use DBICTest; use SQL::Abstract 'is_literal_value'; -use DBIx::Class::_Util 'is_exception'; +use DBIx::Class::_Util qw( is_exception set_subname ); my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; @@ -81,9 +79,14 @@ for my $use_insert_returning ($test_server_supports_insert_returning : (0) ) { - no warnings qw/once redefine/; + # doing it here instead of the actual class to keep the main thing under dfs + # and thus keep catching false positives (so far none, but one never knows) + mro::set_mro("DBICTest::Schema", "c3"); + my $old_connection = DBICTest::Schema->can('connection'); - local *DBICTest::Schema::connection = subname 'DBICTest::Schema::connection' => sub { + + no warnings qw/once redefine/; + local *DBICTest::Schema::connection = set_subname 'DBICTest::Schema::connection' => sub { my $s = shift->$old_connection(@_); $s->storage->_use_insert_returning ($use_insert_returning); $s; @@ -193,6 +196,9 @@ for my $use_insert_returning ($test_server_supports_insert_returning __PACKAGE__->column_info_from_storage(1); __PACKAGE__->set_primary_key('id'); + # FIXME - for some reason column_info_from_storage does not properly find + # the is_auto_increment setting... + __PACKAGE__->column_info('id')->{is_auto_increment} = 1; } SKIP: { skip "Need DBD::Pg 2.9.2 or newer for array tests", 4 if $DBD::Pg::VERSION < 2.009002; diff --git a/t/72pg_bytea.t b/t/72pg_bytea.t index 7049b319c..15f8db5f2 100644 --- a/t/72pg_bytea.t +++ b/t/72pg_bytea.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw(test_rdbms_pg binary_data); use strict; @@ -6,7 +7,7 @@ use warnings; use Test::More; use DBIx::Class::_Util 'modver_gt_or_eq'; -use lib qw(t/lib); + use DBICTest; my ($dsn, $dbuser, $dbpass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; diff --git a/t/73oracle.t b/t/73oracle.t index c6211e289..c8c4cd02a 100644 --- a/t/73oracle.t +++ b/t/73oracle.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_oracle'; use strict; @@ -5,10 +6,8 @@ use warnings; use Test::Exception; use Test::More; -use Sub::Name; -use Try::Tiny; +use DBIx::Class::_Util 'set_subname'; -use lib qw(t/lib); use DBICTest; $ENV{NLS_SORT} = "BINARY"; @@ -109,9 +108,14 @@ my $schema; for my $use_insert_returning ($test_server_supports_insert_returning ? (1,0) : (0) ) { for my $force_ora_joins ($test_server_supports_only_orajoins ? (0) : (0,1) ) { - no warnings qw/once redefine/; + # doing it here instead of the actual class to keep the main thing under dfs + # and thus keep catching false positives (so far none, but one never knows) + mro::set_mro("DBICTest::Schema", "c3"); + my $old_connection = DBICTest::Schema->can('connection'); - local *DBICTest::Schema::connection = subname 'DBICTest::Schema::connection' => sub { + + no warnings qw/once redefine/; + local *DBICTest::Schema::connection = set_subname 'DBICTest::Schema::connection' => sub { my $s = shift->$old_connection (@_); $s->storage->_use_insert_returning ($use_insert_returning); $s->storage->sql_maker_class('DBIx::Class::SQLMaker::OracleJoins') if $force_ora_joins; @@ -473,7 +477,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 - todo_skip "On Oracle8i all_triggers view is empty, i don't yet know why...", 1 + todo_skip "FIXME: 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 0391d4b13..6e5c90337 100644 --- a/t/73oracle_blob.t +++ b/t/73oracle_blob.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_oracle'; use strict; @@ -5,10 +6,6 @@ use warnings; use Test::Exception; use Test::More; -use Sub::Name; -use Try::Tiny; - -use lib qw(t/lib); use DBICTest::Schema::BindType; BEGIN { @@ -107,10 +104,14 @@ SKIP: { 'multi-part LOB equality query was not cached', ) if $size eq 'large'; is @objs, 1, 'One row found matching on both LOBs'; - ok (try { $objs[0]->blob }||'' eq "blob:$str", 'blob inserted/retrieved correctly'); - ok (try { $objs[0]->clob }||'' eq "clob:$str", 'clob inserted/retrieved correctly'); - ok (try { $objs[0]->clb2 }||'' eq "clb2:$str", "clb2 inserted correctly"); - ok (try { $objs[0]->blb2 }||'' eq "blb2:$str", "blb2 inserted correctly"); + + for my $type (qw( blob clob clb2 blb2 )) { + is ( + eval { $objs[0]->$type }, + "$type:$str", + "$type inserted/retrieved correctly" + ); + } { local $TODO = '-like comparison on blobs not tested before ora 10 (fails on 8i)' @@ -140,10 +141,14 @@ SKIP: { @objs = $rs->search({ blob => "updated blob", clob => 'updated clob' })->all; is @objs, 1, 'found updated row'; - ok (try { $objs[0]->blob }||'' eq "updated blob", 'blob updated/retrieved correctly'); - ok (try { $objs[0]->clob }||'' eq "updated clob", 'clob updated/retrieved correctly'); - ok (try { $objs[0]->clb2 }||'' eq "updated clb2", "clb2 updated correctly"); - ok (try { $objs[0]->blb2 }||'' eq "updated blb2", "blb2 updated correctly"); + + for my $type (qw( blob clob clb2 blb2 )) { + is ( + eval { $objs[0]->$type }, + "updated $type", + "$type updated/retrieved correctly" + ); + } lives_ok { $rs->search({ id => $id }) @@ -152,8 +157,14 @@ SKIP: { @objs = $rs->search({ blob => 're-updated blob', clob => 're-updated clob' })->all; is @objs, 1, 'found updated row'; - ok (try { $objs[0]->blob }||'' eq 're-updated blob', 'blob updated/retrieved correctly'); - ok (try { $objs[0]->clob }||'' eq 're-updated clob', 'clob updated/retrieved correctly'); + + for my $type (qw( blob clob )) { + is ( + eval { $objs[0]->$type }, + "re-updated $type", + "$type updated/retrieved correctly" + ); + } lives_ok { $rs->search({ blob => "re-updated blob", clob => "re-updated clob" }) diff --git a/t/73oracle_hq.t b/t/73oracle_hq.t index 57bdc2b8e..0dde66965 100644 --- a/t/73oracle_hq.t +++ b/t/73oracle_hq.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_oracle'; use strict; @@ -10,8 +11,6 @@ use Test::More; # dealing with HQs. So just punt on the entire shuffle thing. BEGIN { $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} = 0 } -use lib qw(t/lib); - use DBICTest::Schema::Artist; BEGIN { DBICTest::Schema::Artist->add_column('parentid'); diff --git a/t/745db2.t b/t/745db2.t index 17a63430c..e9a3fa6dc 100644 --- a/t/745db2.t +++ b/t/745db2.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_db2'; use strict; @@ -5,8 +6,7 @@ use warnings; use Test::More; use Test::Exception; -use Try::Tiny; -use lib qw(t/lib); + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_DB2_${_}" } qw/DSN USER PASS/}; @@ -21,9 +21,9 @@ my $dbh = $schema->storage->dbh; is $schema->storage->sql_maker->name_sep, $name_sep, 'name_sep detection'; -my $have_rno = try { +my $have_rno = eval { $dbh->selectrow_array( -"SELECT row_number() OVER (ORDER BY 1) FROM sysibm${name_sep}sysdummy1" + "SELECT row_number() OVER (ORDER BY 1) FROM sysibm${name_sep}sysdummy1" ); 1; }; diff --git a/t/746db2_400.t b/t/746db2_400.t index b6c43502c..1ce3b99f9 100644 --- a/t/746db2_400.t +++ b/t/746db2_400.t @@ -1,11 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_db2_400'; use strict; use warnings; use Test::More; -use DBIx::Class::Optional::Dependencies (); -use lib qw(t/lib); + use DBICTest; # Probably best to pass the DBQ option in the DSN to specify a specific diff --git a/t/746mssql.t b/t/746mssql.t index 23778a47a..e3ddd6d5c 100644 --- a/t/746mssql.t +++ b/t/746mssql.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_mssql_odbc'; use strict; @@ -5,10 +6,10 @@ use warnings; use Test::More; use Test::Exception; -use Try::Tiny; +use Test::Warn; -use lib qw(t/lib); use DBICTest; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/}; @@ -61,10 +62,10 @@ for my $opts_name (keys %opts) { my $opts = $opts{$opts_name}{opts}; $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts); - try { + dbic_internal_try { $schema->storage->ensure_connected } - catch { + dbic_internal_catch { if ($opts{$opts_name}{required}) { die "on_connect_call option '$opts_name' is not functional: $_"; } @@ -97,11 +98,35 @@ SQL ok(($new->artistid||0) > 0, "Auto-PK worked for $opts_name"); -# Test multiple active statements - SKIP: { - skip 'not a multiple active statements configuration', 1 - if $opts_name eq 'plain'; +# Test graceful error handling if not supporting multiple active statements + if( $opts_name eq 'plain' ) { + + # keep the first cursor alive (as long as $rs is alive) + my $rs = $schema->resultset("Artist"); + + my $a1 = $rs->next; + + my $a2; + + warnings_are { + # second cursor, invalidates $rs, but it doesn't + # matter as long as we do not try to use it + $a2 = $schema->resultset("Artist")->next; + } [], 'No warning on retry due to previous cursor invalidation'; + + is_deeply( + { $a1->get_columns }, + { $a2->get_columns }, + 'Same data', + ); + dies_ok { + $rs->next; + } 'Invalid cursor did not silently return garbage'; + } + +# Test multiple active statements + else { $schema->storage->ensure_connected; lives_ok { @@ -475,24 +500,69 @@ SQL $row = $rs->create({ amount => 100 }); } 'inserted a money value'; - cmp_ok ((try { $rs->find($row->id)->amount })||0, '==', 100, - 'money value round-trip'); + cmp_ok ( + ( eval { $rs->find($row->id)->amount } ) || 0, + '==', + 100, + 'money value round-trip' + ); lives_ok { $row->update({ amount => 200 }); } 'updated a money value'; - cmp_ok ((try { $rs->find($row->id)->amount })||0, '==', 200, - 'updated money value round-trip'); + cmp_ok ( + ( eval { $rs->find($row->id)->amount } ) || 0, + '==', + 200, + 'updated money value round-trip' + ); lives_ok { $row->update({ amount => undef }); } 'updated a money value to NULL'; - is try { $rs->find($row->id)->amount }, undef, - 'updated money value to NULL round-trip'; + lives_ok { + is( + $rs->find($row->id)->amount, + undef, + 'updated money value to NULL round-trip' + ); + } } } + +# Test leakage of PK on implicit retrieval + { + + my $next_owner = $schema->resultset('Owners')->get_column('id')->max + 1; + my $next_book = $schema->resultset('BooksInLibrary')->get_column('id')->max + 1; + + cmp_ok( + $next_owner, + '!=', + $next_book, + 'Preexisting auto-inc PKs staggered' + ); + + my $yet_another_owner = $schema->resultset('Owners')->create({ name => 'YAO' }); + my $yet_another_book; + warnings_exist { + $yet_another_book = $yet_another_owner->create_related( books => { title => 'YAB' }) + } qr/Missing value for primary key column 'id' on BooksInLibrary - perhaps you forgot to set its 'is_auto_increment'/; + + is( + $yet_another_owner->id, + $next_owner, + 'Expected Owner id' + ); + + is( + $yet_another_book->id, + $next_book, + 'Expected Book id' + ); + } } } diff --git a/t/746sybase.t b/t/746sybase.t index 0b8406c5c..74587afef 100644 --- a/t/746sybase.t +++ b/t/746sybase.t @@ -1,14 +1,15 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_ase'; use strict; use warnings; no warnings 'uninitialized'; +use Config; use Test::More; use Test::Exception; use DBIx::Class::_Util 'sigwarn_silencer'; -use lib qw(t/lib); use DBICTest; my @storage_types = ( @@ -627,6 +628,7 @@ if (Test::Builder->new->is_passing and $ENV{LC_ALL} and $ENV{LC_ALL} ne 'C') { local $ENV{DBICTEST_SYBASE_SUBTEST_RERUN} = 1; local $ENV{PATH}; + local $ENV{PERL5LIB} = join ($Config{path_sep}, @INC); my @cmd = map { $_ =~ /(.+)/ } ($^X, __FILE__); # this is cheating, and may even hang here and there (testing on windows passed fine) diff --git a/t/747mssql_ado.t b/t/747mssql_ado.t index 9c1d084a2..a426605d4 100644 --- a/t/747mssql_ado.t +++ b/t/747mssql_ado.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_mssql_ado'; use strict; @@ -5,9 +6,7 @@ use warnings; use Test::More; use Test::Exception; -use Try::Tiny; -use DBIx::Class::Optional::Dependencies (); -use lib qw(t/lib); + use DBICTest; # Example DSN (from frew): @@ -40,7 +39,7 @@ is $schema->storage->sql_limit_dialect, ($ver >= 9 ? 'RowNumberOver' : 'Top'), $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; - try { local $^W = 0; $dbh->do("DROP TABLE artist") }; + eval { local $^W = 0; $dbh->do("DROP TABLE artist") }; $dbh->do(<<'SQL'); CREATE TABLE artist ( artistid INT IDENTITY NOT NULL, @@ -54,7 +53,7 @@ SQL $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; - try { local $^W = 0; $dbh->do("DROP TABLE artist_guid") }; + eval { local $^W = 0; $dbh->do("DROP TABLE artist_guid") }; $dbh->do(<<"SQL"); CREATE TABLE artist_guid ( artistid UNIQUEIDENTIFIER NOT NULL, @@ -71,7 +70,7 @@ my $have_max = $ver >= 9; # 2005 and greater $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; - try { local $^W = 0; $dbh->do("DROP TABLE varying_max_test") }; + eval { local $^W = 0; $dbh->do("DROP TABLE varying_max_test") }; $dbh->do(" CREATE TABLE varying_max_test ( id INT IDENTITY NOT NULL, @@ -115,7 +114,7 @@ my $rs1 = $schema->resultset('Artist')->search({}, { order_by => 'artistid' }); my $rs2 = $schema->resultset('Artist')->search({}, { order_by => 'name' }); while ($rs1->next) { - ok try { $rs2->next }, 'multiple active cursors'; + lives_ok { ok $rs2->next } 'multiple active cursors'; } # test bug where ADO blows up if the first bindparam is shorter than the second @@ -232,14 +231,19 @@ foreach my $size (qw/small large/) { $row->discard_changes; } 're-selected just-inserted LOBs'; - cmp_ok try { $row->varchar_max }, 'eq', $str, 'VARCHAR(MAX) matches'; - cmp_ok try { $row->nvarchar_max }, 'eq', $str, 'NVARCHAR(MAX) matches'; - cmp_ok try { $row->varbinary_max }, 'eq', $str, 'VARBINARY(MAX) matches'; + for my $type (qw( varchar nvarchar varbinary ) ) { + my $meth = "${type}_max"; + is( + eval { $row->$meth }, + $str, + ( uc $type ) . '(MAX) matches' + ); + } } # test regular blobs -try { local $^W = 0; $schema->storage->dbh->do('DROP TABLE bindtype_test') }; +eval { local $^W = 0; $schema->storage->dbh->do('DROP TABLE bindtype_test') }; $schema->storage->dbh->do(qq[ CREATE TABLE bindtype_test ( @@ -299,7 +303,7 @@ ok( ); diag $@ if $@; -my $guid = try { $row->artistid }||''; +my $guid = eval { $row->artistid }||''; ok(($guid !~ /^{.*?}\z/), 'GUID not enclosed in braces') or diag "GUID is: $guid"; @@ -313,29 +317,48 @@ diag $@ if $@; my $row_from_db = $schema->resultset('ArtistGUID') ->search({ name => 'mtfnpy' })->first; -is try { $row_from_db->artistid }, try { $row->artistid }, - 'PK GUID round trip (via ->search->next)'; +is( + eval { $row_from_db->artistid }, + eval { $row->artistid }, + 'PK GUID round trip (via ->search->next)' +); -is try { $row_from_db->a_guid }, try { $row->a_guid }, - 'NON-PK GUID round trip (via ->search->next)'; +is( + eval { $row_from_db->a_guid }, + eval { $row->a_guid }, + 'NON-PK GUID round trip (via ->search->next)' +); -$row_from_db = try { $schema->resultset('ArtistGUID') - ->find($row->artistid) }; +$row_from_db = eval { + $schema->resultset('ArtistGUID')->find($row->artistid) +}; -is try { $row_from_db->artistid }, try { $row->artistid }, - 'PK GUID round trip (via ->find)'; +is( + eval { $row_from_db->artistid }, + eval { $row->artistid }, + 'PK GUID round trip (via ->find)' +); -is try { $row_from_db->a_guid }, try { $row->a_guid }, - 'NON-PK GUID round trip (via ->find)'; +is( + eval { $row_from_db->a_guid }, + eval { $row->a_guid }, + 'NON-PK GUID round trip (via ->find)' +); ($row_from_db) = $schema->resultset('ArtistGUID') ->search({ name => 'mtfnpy' })->all; -is try { $row_from_db->artistid }, try { $row->artistid }, - 'PK GUID round trip (via ->search->all)'; +is( + eval { $row_from_db->artistid }, + eval { $row->artistid }, + 'PK GUID round trip (via ->search->all)' +); -is try { $row_from_db->a_guid }, try { $row->a_guid }, - 'NON-PK GUID round trip (via ->search->all)'; +is( + eval { $row_from_db->a_guid }, + eval { $row->a_guid }, + 'NON-PK GUID round trip (via ->search->all)' +); lives_ok { $row = $schema->resultset('ArtistGUID')->create({ @@ -344,15 +367,21 @@ lives_ok { }); } 'created a row with explicit PK GUID'; -is try { $row->artistid }, '70171270-4822-4450-81DF-921F99BA3C06', - 'row has correct PK GUID'; +is( + eval { $row->artistid }, + '70171270-4822-4450-81DF-921F99BA3C06', + 'row has correct PK GUID' +); lives_ok { $row->update({ artistid => '70171270-4822-4450-81DF-921F99BA3C07' }); } "updated row's PK GUID"; -is try { $row->artistid }, '70171270-4822-4450-81DF-921F99BA3C07', - 'row has correct PK GUID'; +is( + eval { $row->artistid }, + '70171270-4822-4450-81DF-921F99BA3C07', + 'row has correct PK GUID' +); lives_ok { $row->delete; @@ -370,8 +399,8 @@ done_testing; # clean up our mess END { local $SIG{__WARN__} = sub {}; - if (my $dbh = try { $schema->storage->_dbh }) { - (try { $dbh->do("DROP TABLE $_") }) + if (my $dbh = eval { $schema->storage->_dbh }) { + (eval { $dbh->do("DROP TABLE $_") }) for qw/artist artist_guid varying_max_test bindtype_test/; } diff --git a/t/748informix.t b/t/748informix.t index 08fc4b5f1..cd9ad354b 100644 --- a/t/748informix.t +++ b/t/748informix.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_informix'; use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_INFORMIX_${_}" } qw/DSN USER PASS/}; diff --git a/t/749sqlanywhere.t b/t/749sqlanywhere.t index a52b5bda6..ed9c382ca 100644 --- a/t/749sqlanywhere.t +++ b/t/749sqlanywhere.t @@ -1,12 +1,13 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SQLANYWHERE_${_}" } qw/DSN USER PASS/}; @@ -224,35 +225,54 @@ SQL ); diag $@ if $@; - my $row_from_db = try { $schema->resultset('ArtistGUID') - ->search({ name => 'mtfnpy' })->first } - catch { diag $_ }; + my $row_from_db; + lives_ok { + $row_from_db = $schema->resultset('ArtistGUID')->search({ name => 'mtfnpy' })->first + }; - is try { $row_from_db->artistid }, $row->artistid, - 'PK GUID round trip (via ->search->next)'; + is( + eval { $row_from_db->artistid }, + $row->artistid, + 'PK GUID round trip (via ->search->next)' + ); - is try { $row_from_db->a_guid }, $row->a_guid, - 'NON-PK GUID round trip (via ->search->next)'; + is( + eval { $row_from_db->a_guid }, + $row->a_guid, + 'NON-PK GUID round trip (via ->search->next)' + ); - $row_from_db = try { $schema->resultset('ArtistGUID') - ->find($row->artistid) } - catch { diag $_ }; + lives_ok { + $row_from_db = $schema->resultset('ArtistGUID')->find($row->artistid) + }; - is try { $row_from_db->artistid }, $row->artistid, - 'PK GUID round trip (via ->find)'; + is( + eval { $row_from_db->artistid }, + $row->artistid, + 'PK GUID round trip (via ->find)' + ); - is try { $row_from_db->a_guid }, $row->a_guid, - 'NON-PK GUID round trip (via ->find)'; + is( + eval { $row_from_db->a_guid }, + $row->a_guid, + 'NON-PK GUID round trip (via ->find)' + ); - ($row_from_db) = try { $schema->resultset('ArtistGUID') - ->search({ name => 'mtfnpy' })->all } - catch { diag $_ }; + lives_ok { + ($row_from_db) = $schema->resultset('ArtistGUID')->search({ name => 'mtfnpy' })->all + }; - is try { $row_from_db->artistid }, $row->artistid, - 'PK GUID round trip (via ->search->all)'; + is( + eval { $row_from_db->artistid }, + $row->artistid, + 'PK GUID round trip (via ->search->all)' + ); - is try { $row_from_db->a_guid }, $row->a_guid, - 'NON-PK GUID round trip (via ->search->all)'; + is( + eval { $row_from_db->a_guid }, + $row->a_guid, + 'NON-PK GUID round trip (via ->search->all)' + ); } } diff --git a/t/74mssql.t b/t/74mssql.t index 4f72cc4a8..f24e1967c 100644 --- a/t/74mssql.t +++ b/t/74mssql.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_mssql_sybase'; use strict; @@ -6,7 +7,8 @@ use warnings; use Test::More; use Test::Exception; use Scalar::Util 'weaken'; -use lib qw(t/lib); +use DBIx::Class::_Util 'sigwarn_silencer'; + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_${_}" } qw/DSN USER PASS/}; @@ -202,7 +204,7 @@ SQL $schema->storage->_get_dbh->disconnect; - lives_and { + lives_ok { $wrappers->{$wrapper}->( sub { $rs_cp->create({ amount => 900 + $_ }) for 1..3; }); @@ -228,11 +230,16 @@ SQL weaken(my $a_rs_cp = $artist_rs); - local $TODO = 'Transaction handling with multiple active statements will ' - .'need eager cursor support.' - unless $wrapper eq 'no_transaction'; + $wrapper ne 'no_transaction' + and + ( + local $TODO = 'Transaction handling with multiple active statements will ' + .'need eager cursor support.', - lives_and { + local local $SIG{__WARN__} = sigwarn_silencer qr/disconnect invalidates .+? active statement/ + ); + + lives_ok { my @results; $wrappers->{$wrapper}->( sub { diff --git a/t/750firebird.t b/t/750firebird.t index 45dd8950a..eb4122a5d 100644 --- a/t/750firebird.t +++ b/t/750firebird.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -6,8 +8,7 @@ use Test::Exception; use DBIx::Class::Optional::Dependencies (); use DBIx::Class::_Util 'scope_guard'; use List::Util 'shuffle'; -use Try::Tiny; -use lib qw(t/lib); + use DBICTest; my $env2optdep = { @@ -26,8 +27,6 @@ plan skip_all => join (' ', 'and "nonpkid_seq" and the trigger "artist_bi".', ) unless grep { $ENV{"${_}_DSN"} } keys %$env2optdep; -# tests stolen from 749sybase_asa.t - # Example DSNs: # dbi:Firebird:db=/var/lib/firebird/2.5/data/hlaghdb.fdb # dbi:InterBase:db=/var/lib/firebird/2.5/data/hlaghdb.fdb @@ -39,11 +38,9 @@ my $schema; for my $prefix (shuffle keys %$env2optdep) { SKIP: { - 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}); + DBIx::Class::Optional::Dependencies->skip_without( $env2optdep->{$prefix} ); my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; - note "Testing with ${prefix}_DSN"; $schema = DBICTest::Schema->connect($dsn, $user, $pass, { @@ -220,7 +217,11 @@ EOF $row = $paged->next; } 'paged query survived'; - is try { $row->artistid }, 5, 'correct row from paged query'; + is( + eval { $row->artistid }, + 5, + 'correct row from paged query' + ); # DBD bug - if any unfinished statements are present during # DDL manipulation (test blobs below)- a segfault will occur diff --git a/t/751msaccess.t b/t/751msaccess.t index dfd581679..2b70a4aec 100644 --- a/t/751msaccess.t +++ b/t/751msaccess.t @@ -1,12 +1,13 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSACCESS_ODBC_${_}" } qw/DSN USER PASS/}; @@ -142,37 +143,38 @@ EOF title => 'my track', }); - my $joined_track = try { - $schema->resultset('Artist')->search({ + my $joined_track; + lives_ok { + $joined_track = $schema->resultset('Artist')->search({ artistid => $first_artistid, }, { join => [{ cds => 'tracks' }], '+select' => [ 'tracks.title' ], '+as' => [ 'track_title' ], })->next; - } - catch { - diag "Could not execute two-step left join: $_"; - }; + } 'Two-step left join executed'; - is try { $joined_track->get_column('track_title') }, 'my track', - 'two-step left join works'; + is( + eval { $joined_track->get_column('track_title') }, + 'my track', + 'two-step left join works' + ); - $joined_artist = try { - $schema->resultset('Track')->search({ + lives_ok { + $joined_artist = $schema->resultset('Track')->search({ trackid => $track->trackid, }, { join => [{ cd => 'artist' }], '+select' => [ 'artist.name' ], '+as' => [ 'artist_name' ], })->next; - } - catch { - diag "Could not execute two-step inner join: $_"; - }; + } 'Two-step inner join executed'; - is try { $joined_artist->get_column('artist_name') }, 'foo', - 'two-step inner join works'; + is( + eval { $joined_artist->get_column('artist_name') }, + 'foo', + 'two-step inner join works' + ); # test basic transactions $schema->txn_do(sub { diff --git a/t/752sqlite.t b/t/752sqlite.t index f61f07ee6..c0695546a 100644 --- a/t/752sqlite.t +++ b/t/752sqlite.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -7,7 +9,7 @@ use Test::Warn; use Time::HiRes 'time'; use Math::BigInt; -use lib qw(t/lib); + use DBICTest; use DBIx::Class::_Util qw( sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt ); @@ -94,6 +96,11 @@ DDL } # test blank begin/svp/commit/begin cycle +# +# need to prime this for exotic testing scenarios +# before testing for lack of warnings +modver_gt_or_eq('DBD::SQLite', '1.33'); + warnings_are { my $schema = DBICTest->init_schema( no_populate => 1 ); my $rs = $schema->resultset('Artist'); diff --git a/t/76joins.t b/t/76joins.t index d20faeca5..d98fd5a70 100644 --- a/t/76joins.t +++ b/t/76joins.t @@ -1,8 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/76select.t b/t/76select.t index 9d09380bc..b3b491ad8 100644 --- a/t/76select.t +++ b/t/76select.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/77join_count.t b/t/77join_count.t index 8350e2e8b..9de1a83ed 100644 --- a/t/77join_count.t +++ b/t/77join_count.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/78self_referencial.t b/t/78self_referencial.t index a02677d34..fe89bce37 100644 --- a/t/78self_referencial.t +++ b/t/78self_referencial.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/79aliasing.t b/t/79aliasing.t index 00e5e930a..70738c612 100644 --- a/t/79aliasing.t +++ b/t/79aliasing.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/80unique.t b/t/80unique.t index b38022504..726a2b22c 100644 --- a/t/80unique.t +++ b/t/80unique.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/82cascade_copy.t b/t/82cascade_copy.t index ec3ba92fe..505b79b5c 100644 --- a/t/82cascade_copy.t +++ b/t/82cascade_copy.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/83cache.t b/t/83cache.t index 5812083c2..a89772dac 100644 --- a/t/83cache.t +++ b/t/83cache.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/84serialize.t b/t/84serialize.t index ffa63fa0f..021c44e70 100644 --- a/t/84serialize.t +++ b/t/84serialize.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; use Storable qw(dclone freeze nfreeze thaw); use Scalar::Util qw/refaddr/; @@ -58,8 +60,10 @@ my %stores = ( ); -if ($ENV{DBICTEST_MEMCACHED}) { - if (DBIx::Class::Optional::Dependencies->req_ok_for ('test_memcached')) { +SKIP: { + require DBIx::Class::Optional::Dependencies; + DBIx::Class::Optional::Dependencies->skip_without('test_memcached'); + my $memcached = Cache::Memcached->new( { servers => [ $ENV{DBICTEST_MEMCACHED} ] } ); @@ -72,20 +76,7 @@ if ($ENV{DBICTEST_MEMCACHED}) { local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema; return $memcached->get($key); }; - } - else { - SKIP: { - skip 'Memcached tests need ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_memcached'), 1; - } - } } -else { - SKIP: { - skip 'Set $ENV{DBICTEST_MEMCACHED} to run the memcached serialization tests', 1; - } -} - - for my $name (keys %stores) { diff --git a/t/85utf8.t b/t/85utf8.t index e1f2caef8..3e4483596 100644 --- a/t/85utf8.t +++ b/t/85utf8.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; { diff --git a/t/86might_have.t b/t/86might_have.t index 05ba5390d..f656802f4 100644 --- a/t/86might_have.t +++ b/t/86might_have.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); @@ -38,7 +40,7 @@ warning_like { { "foreign.id" => "self.link" }, ); } - qr{"might_have/has_one" must not be on columns with is_nullable set to true}, + qr{'might_have'/'has_one' must not be used on columns with is_nullable set to true}, 'might_have should warn if the self.id column is nullable'; { diff --git a/t/86sqlt.t b/t/86sqlt.t index a6b17ecf3..486b5ed4e 100644 --- a/t/86sqlt.t +++ b/t/86sqlt.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'deploy'; use strict; @@ -7,7 +8,7 @@ use Test::More; use Test::Warn; use Scalar::Util 'blessed'; -use lib qw(t/lib); + use DBICTest; my $custom_deployment_statements_called = 0; diff --git a/t/87ordered.t b/t/87ordered.t index 1eb079bb0..219c942a6 100644 --- a/t/87ordered.t +++ b/t/87ordered.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + # vim: filetype=perl use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; use POSIX (); diff --git a/t/88result_set_column.t b/t/88result_set_column.t index e1b73a354..7abf670c7 100644 --- a/t/88result_set_column.t +++ b/t/88result_set_column.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -10,7 +12,7 @@ use Test::Exception; # and that's a whole another bag of dicks BEGIN { $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} = 0 } -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); @@ -38,6 +40,13 @@ while (my $r = $rs_title->next) { is_deeply (\@all_titles, \@nexted_titles, 'next works'); +my @list_ctx; +warnings_exist { + @list_ctx = $rs_year->func_rs('DISTINCT'); +} [qr/\Qfunc_rs() always returns a ResultSet instance regardless of calling context/]; +is( scalar @list_ctx, 1, 'wantarray context does not affect func_rs'); +isa_ok( $list_ctx[0], 'DBIx::Class::ResultSet' ); +isa_ok( scalar( $rs_year->func_rs('DISTINCT') ), 'DBIx::Class::ResultSet' ); is_deeply( [ sort $rs_year->func('DISTINCT') ], [ 1997, 1998, 1999, 2001 ], "wantarray context okay"); ok ($max_year->next == $rs_year->max, q/get_column (\'FUNC') ok/); diff --git a/t/90join_torture.t b/t/90join_torture.t index 27111e447..8ba193e5e 100644 --- a/t/90join_torture.t +++ b/t/90join_torture.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/93autocast.t b/t/93autocast.t index 49c1f5710..084f71467 100644 --- a/t/93autocast.t +++ b/t/93autocast.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; { # Fake storage driver for sqlite with autocast diff --git a/t/93single_accessor_object.t b/t/93single_accessor_object.t index a285b1af8..bcb53a140 100644 --- a/t/93single_accessor_object.t +++ b/t/93single_accessor_object.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; # Test various uses of passing an object to find, create, and update on a single diff --git a/t/94pk_mutation.t b/t/94pk_mutation.t index 3cdc47cb9..082e5c4c5 100644 --- a/t/94pk_mutation.t +++ b/t/94pk_mutation.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/94versioning.t b/t/94versioning.t index 9dcdcf15f..af46ef768 100644 --- a/t/94versioning.t +++ b/t/94versioning.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw(deploy test_rdbms_mysql); use strict; @@ -7,13 +8,11 @@ use Test::More; use Test::Warn; use Test::Exception; -use Path::Class; -use File::Copy; use Time::HiRes qw/time sleep/; -use lib qw(t/lib); use DBICTest; -use DBIx::Class::_Util 'sigwarn_silencer'; +use DBIx::Class::_Util qw( sigwarn_silencer mkdir_p ); +use DBICTest::Util 'rm_rf'; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}; @@ -25,20 +24,25 @@ my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}; # in case it came from the env $ENV{DBIC_NO_VERSION_CHECK} = 0; +# FIXME - work around RT#113965 in combination with -T on older perls: +# the non-deparsing XS portion of D::D gets confused by some of the IO +# handles trapped in the debug object of DBIC. What a mess. +$Data::Dumper::Deparse = 1; + use_ok('DBICVersion_v1'); my $version_table_name = 'dbix_class_schema_versions'; my $old_table_name = 'SchemaVersions'; -my $ddl_dir = dir(qw/t var/, "versioning_ddl-$$"); -$ddl_dir->mkpath unless -d $ddl_dir; +my $ddl_dir = "t/var/versioning_ddl-$$"; +mkdir_p $ddl_dir unless -d $ddl_dir; my $fn = { - v1 => $ddl_dir->file ('DBICVersion-Schema-1.0-MySQL.sql'), - v2 => $ddl_dir->file ('DBICVersion-Schema-2.0-MySQL.sql'), - v3 => $ddl_dir->file ('DBICVersion-Schema-3.0-MySQL.sql'), - trans_v12 => $ddl_dir->file ('DBICVersion-Schema-1.0-2.0-MySQL.sql'), - trans_v23 => $ddl_dir->file ('DBICVersion-Schema-2.0-3.0-MySQL.sql'), + v1 => "$ddl_dir/DBICVersion-Schema-1.0-MySQL.sql", + v2 => "$ddl_dir/DBICVersion-Schema-2.0-MySQL.sql", + v3 => "$ddl_dir/DBICVersion-Schema-3.0-MySQL.sql", + trans_v12 => "$ddl_dir/DBICVersion-Schema-1.0-2.0-MySQL.sql", + trans_v23 => "$ddl_dir/DBICVersion-Schema-2.0-3.0-MySQL.sql", }; my $schema_v1 = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 }); @@ -282,10 +286,37 @@ is ), 3, "Expected number of connections at end of script" ; -END { - unless ($ENV{DBICTEST_KEEP_VERSIONING_DDL}) { - $ddl_dir->rmtree; +# Test custom HandleError setting on an in-memory instance +{ + my $custom_handler = sub { die $_[0] }; + + # try to setup a custom error handle without unsafe set -- should + # fail, same behavior as regular Schema + throws_ok { + DBICVersion::Schema->connect( 'dbi:SQLite::memory:', undef, undef, { + HandleError => $custom_handler, + ignore_version => 1, + })->deploy; } + qr/Refusing clobbering of \{HandleError\} installed on externally supplied DBI handle/, + 'HandleError with unsafe not set causes an exception' + ; + + # now try it with unsafe set -- should work (see RT #113741) + my $s = DBICVersion::Schema->connect( 'dbi:SQLite::memory:', undef, undef, { + unsafe => 1, + HandleError => $custom_handler, + ignore_version => 1, + }); + + $s->deploy; + + is $s->storage->dbh->{HandleError}, $custom_handler, 'Handler properly set on main schema'; + is $s->{vschema}->storage->dbh->{HandleError}, $custom_handler, 'Handler properly set on version subschema'; +} + +END { + rm_rf $ddl_dir unless $ENV{DBICTEST_KEEP_VERSIONING_DDL}; } done_testing; diff --git a/t/97result_class.t b/t/97result_class.t index faff994c0..b7e3c4783 100644 --- a/t/97result_class.t +++ b/t/97result_class.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/99dbic_sqlt_parser.t b/t/99dbic_sqlt_parser.t index a9e708fe4..f2ac4ca72 100644 --- a/t/99dbic_sqlt_parser.t +++ b/t/99dbic_sqlt_parser.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'deploy'; use strict; @@ -10,7 +11,6 @@ use Test::Warn; use Test::Exception; use Scalar::Util (); -use lib qw(t/lib); use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; @@ -125,6 +125,15 @@ my $idx_exceptions = { my $idx_test = join("\x00", $index->fields); isnt ( $pk_test, $idx_test, "no additional index for the primary columns exists in $source_name"); } + + my $deferrables = grep { + $_->name eq 'track_cd_position' + and $_->type eq 'UNIQUE' + and $_->deferrable == 1 + } + get_table($sqlt_schema, $schema, 'Track')->get_constraints; + + is ($deferrables, 1, "a deferrable unique constraint called track_cd_position exists on Track"); } } @@ -196,7 +205,7 @@ lives_ok (sub { { package DBICTest::PartialSchema; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; __PACKAGE__->load_classes( { 'DBICTest::Schema' => [qw/ diff --git a/t/admin/02ddl.t b/t/admin/02ddl.t index b2414c356..bb354ac42 100644 --- a/t/admin/02ddl.t +++ b/t/admin/02ddl.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( admin deploy ); use strict; @@ -7,11 +8,9 @@ use Test::More; use Test::Exception; use Test::Warn; -use Path::Class; - -use lib qw(t/lib); use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; +use DBICTest::Util 'rm_rf'; use DBIx::Class::Admin; @@ -25,12 +24,12 @@ my @connect_info = ( undef, { on_connect_do => 'PRAGMA synchronous = OFF' }, ); -my $ddl_dir = dir(qw/t var/, "admin_ddl-$$"); +my $ddl_dir = "t/var/admin_ddl-$$"; { # create the schema # make sure we are clean -clean_dir($ddl_dir); +cleanup(); my $admin = DBIx::Class::Admin->new( @@ -49,7 +48,7 @@ lives_ok { { # upgrade schema -clean_dir($ddl_dir); +cleanup(); require DBICVersion_v1; my $admin = DBIx::Class::Admin->new( @@ -91,7 +90,7 @@ is($schema->get_db_version, $DBICVersion::Schema::VERSION, 'Schema and db versio { # install -clean_dir($ddl_dir); +cleanup(); my $admin = DBIx::Class::Admin->new( schema_class => 'DBICVersion::Schema', @@ -114,14 +113,13 @@ warnings_exist ( sub { is($admin->schema->get_db_version, "4.0", 'db thinks its version 4.0'); } -sub clean_dir { - my ($dir) = @_; - $dir->rmtree if -d $dir; +sub cleanup { + rm_rf $ddl_dir if -d $ddl_dir; unlink $db_fn; } END { - clean_dir($ddl_dir); + cleanup(); } done_testing; diff --git a/t/admin/03data.t b/t/admin/03data.t index d73f61987..4be2960cd 100644 --- a/t/admin/03data.t +++ b/t/admin/03data.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'admin'; use strict; @@ -6,7 +7,7 @@ use warnings; use Test::More; use Test::Exception; -use lib 't/lib'; + use DBICTest; use DBIx::Class::Admin; @@ -18,9 +19,13 @@ use DBIx::Class::Admin; sqlite_use_file => 1, ); + my $storage = $schema->storage; + $storage = $storage->master + if $storage->isa('DBIx::Class::Storage::DBI::Replicated'); + my $admin = DBIx::Class::Admin->new( schema_class=> "DBICTest::Schema", - connect_info => $schema->storage->connect_info(), + connect_info => $storage->connect_info(), quiet => 1, _confirm=>1, ); diff --git a/t/cdbi/01-columns.t b/t/cdbi/01-columns.t index 76bce5241..827684d2d 100644 --- a/t/cdbi/01-columns.t +++ b/t/cdbi/01-columns.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/02-Film.t b/t/cdbi/02-Film.t index 7a6f9e9c5..b8159c4cc 100644 --- a/t/cdbi/02-Film.t +++ b/t/cdbi/02-Film.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; @@ -32,7 +33,7 @@ is(Film->__driver, "SQLite", "Driver set correctly"); } eval { my $duh = Film->insert; }; -like $@, qr/Result object instantiation requires a hashref as argument/, "needs a hashref"; +like $@, qr/Result object instantiation requires a single hashref argument/, "needs a hashref"; ok +Film->create_test_film; diff --git a/t/cdbi/03-subclassing.t b/t/cdbi/03-subclassing.t index 8a73a0944..b5ac32f7a 100644 --- a/t/cdbi/03-subclassing.t +++ b/t/cdbi/03-subclassing.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/04-lazy.t b/t/cdbi/04-lazy.t index 2e37827ae..96d574335 100644 --- a/t/cdbi/04-lazy.t +++ b/t/cdbi/04-lazy.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/06-hasa.t b/t/cdbi/06-hasa.t index d191b6589..abad17023 100644 --- a/t/cdbi/06-hasa.t +++ b/t/cdbi/06-hasa.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; @@ -117,7 +118,7 @@ sub fail_with_bad_object { NumExplodingSheep => 23 } ); - } qr/isn't a Director/; + } qr/is not a column on related source 'Director'/; } package Foo; diff --git a/t/cdbi/08-inheritcols.t b/t/cdbi/08-inheritcols.t index bc9b90a9b..eabe09e17 100644 --- a/t/cdbi/08-inheritcols.t +++ b/t/cdbi/08-inheritcols.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/09-has_many.t b/t/cdbi/09-has_many.t index a19500ab3..bac11ed9b 100644 --- a/t/cdbi/09-has_many.t +++ b/t/cdbi/09-has_many.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/11-triggers.t b/t/cdbi/11-triggers.t index cd322e579..5f346d04c 100644 --- a/t/cdbi/11-triggers.t +++ b/t/cdbi/11-triggers.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/12-filter.t b/t/cdbi/12-filter.t index de68fa118..f39b848de 100644 --- a/t/cdbi/12-filter.t +++ b/t/cdbi/12-filter.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/13-constraint.t b/t/cdbi/13-constraint.t index ba9f654db..bd7bb984b 100644 --- a/t/cdbi/13-constraint.t +++ b/t/cdbi/13-constraint.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/14-might_have.t b/t/cdbi/14-might_have.t index 52a2abde1..9b332c7f2 100644 --- a/t/cdbi/14-might_have.t +++ b/t/cdbi/14-might_have.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/15-accessor.t b/t/cdbi/15-accessor.t index 85f8464f4..5b349668c 100644 --- a/t/cdbi/15-accessor.t +++ b/t/cdbi/15-accessor.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/16-reserved.t b/t/cdbi/16-reserved.t index ce8a4b394..cc01d8010 100644 --- a/t/cdbi/16-reserved.t +++ b/t/cdbi/16-reserved.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/18-has_a.t b/t/cdbi/18-has_a.t index dfb5819a1..6304b2c93 100644 --- a/t/cdbi/18-has_a.t +++ b/t/cdbi/18-has_a.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; @@ -109,7 +110,7 @@ is( Rating => 'R', NumExplodingSheep => 23 }); - } qr/isn't a Director/, "Can't have film as codirector"; + } qr/is not a column on related source 'Director'/, "Can't have film as codirector"; is $fail, undef, "We didn't get anything"; my $tastes_bad = YA::Film->create({ diff --git a/t/cdbi/19-set_sql.t b/t/cdbi/19-set_sql.t index a98181087..14cfc37d5 100644 --- a/t/cdbi/19-set_sql.t +++ b/t/cdbi/19-set_sql.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/21-iterator.t b/t/cdbi/21-iterator.t index 14a1b3002..49e8ec9e9 100644 --- a/t/cdbi/21-iterator.t +++ b/t/cdbi/21-iterator.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/22-deflate_order.t b/t/cdbi/22-deflate_order.t index 71d8d7d9c..a54eaf70d 100644 --- a/t/cdbi/22-deflate_order.t +++ b/t/cdbi/22-deflate_order.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( cdbicompat test_rdbms_mysql Time::Piece::MySQL>=0 ); $| = 1; diff --git a/t/cdbi/22-self_referential.t b/t/cdbi/22-self_referential.t index 43ad050ba..a70f5d1a1 100644 --- a/t/cdbi/22-self_referential.t +++ b/t/cdbi/22-self_referential.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/23-cascade.t b/t/cdbi/23-cascade.t index 809f45820..cedf91a15 100644 --- a/t/cdbi/23-cascade.t +++ b/t/cdbi/23-cascade.t @@ -1,10 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; use warnings; use Test::More; -use Data::Dumper; +use DBIx::Class::_Util 'dump_value'; use lib 't/cdbi/testlib'; use Film; @@ -41,8 +42,7 @@ for my $args ({ no_cascade_delete => 1 }, { cascade => "None" }) { is $dir->nasties, 1, "We have one nasty"; ok $dir->delete; - local $Data::Dumper::Terse = 1; - ok +Film->retrieve("Alligator"), 'has_many with ' . Dumper ($args);; + ok +Film->retrieve("Alligator"), 'has_many with ' . dump_value $args; $kk->delete; } diff --git a/t/cdbi/24-meta_info.t b/t/cdbi/24-meta_info.t index 703e3fd8b..7004de142 100644 --- a/t/cdbi/24-meta_info.t +++ b/t/cdbi/24-meta_info.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( cdbicompat Time::Piece>=0 ); use strict; diff --git a/t/cdbi/26-mutator.t b/t/cdbi/26-mutator.t index 54a4229ef..7042731b3 100644 --- a/t/cdbi/26-mutator.t +++ b/t/cdbi/26-mutator.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/30-pager.t b/t/cdbi/30-pager.t index d192d973c..eaac34093 100644 --- a/t/cdbi/30-pager.t +++ b/t/cdbi/30-pager.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/68-inflate_has_a.t b/t/cdbi/68-inflate_has_a.t index 37eac4bf7..639849463 100644 --- a/t/cdbi/68-inflate_has_a.t +++ b/t/cdbi/68-inflate_has_a.t @@ -1,10 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt cdbicompat ); use strict; use warnings; use Test::More; -use lib 't/lib'; + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/cdbi/70_implicit_inflate.t b/t/cdbi/70_implicit_inflate.t index fa53816d9..1c58f2ca2 100644 --- a/t/cdbi/70_implicit_inflate.t +++ b/t/cdbi/70_implicit_inflate.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( cdbicompat rdbms_sqlite ic_dt ); use strict; diff --git a/t/cdbi/71_column_object.t b/t/cdbi/71_column_object.t index e00820b73..54b0f418d 100644 --- a/t/cdbi/71_column_object.t +++ b/t/cdbi/71_column_object.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + # Columns in CDBI could be defined as Class::DBI::Column objects rather than # or as well as with __PACKAGE__->columns(); use DBIx::Class::Optional::Dependencies -skip_all_without => qw( cdbicompat Class::DBI>=3.000005 ); diff --git a/t/cdbi/98-failure.t b/t/cdbi/98-failure.t index 9a993c407..becb8c4d6 100644 --- a/t/cdbi/98-failure.t +++ b/t/cdbi/98-failure.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/DeepAbstractSearch/01_search.t b/t/cdbi/DeepAbstractSearch/01_search.t index f4911c762..5c87cb0bc 100644 --- a/t/cdbi/DeepAbstractSearch/01_search.t +++ b/t/cdbi/DeepAbstractSearch/01_search.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( cdbicompat Class::DBI::Plugin::DeepAbstractSearch>=0 ); use strict; @@ -5,7 +6,6 @@ use warnings; use Test::More; -use lib 't/lib'; use DBICTest; my $DB = DBICTest->_sqlite_dbname(sqlite_use_file => 1);; @@ -19,6 +19,24 @@ my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 0 }); package Music::DBI; use base qw(DBIx::Class::CDBICompat); use Class::DBI::Plugin::DeepAbstractSearch; + +BEGIN { + # offset the warning from DBIx::Class::Schema on 5.8 + # keep the ::Schema default as-is otherwise + DBIx::Class::_ENV_::OLD_MRO + and + ( eval <<'EOS' or die $@ ); + + sub setup_schema_instance { + my $s = shift->next::method(@_); + $s->schema_sanity_checker(''); + $s; + } + + 1; +EOS +} + __PACKAGE__->connection(@DSN); my $sql = <<'SQL_END'; diff --git a/t/cdbi/abstract/search_where.t b/t/cdbi/abstract/search_where.t index 2c15ecc54..28e5b04e2 100644 --- a/t/cdbi/abstract/search_where.t +++ b/t/cdbi/abstract/search_where.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/columns_as_hashes.t b/t/cdbi/columns_as_hashes.t index 9731ae370..a8953c332 100644 --- a/t/cdbi/columns_as_hashes.t +++ b/t/cdbi/columns_as_hashes.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/columns_dont_override_custom_accessors.t b/t/cdbi/columns_dont_override_custom_accessors.t index 5748b6e00..2e99668fd 100644 --- a/t/cdbi/columns_dont_override_custom_accessors.t +++ b/t/cdbi/columns_dont_override_custom_accessors.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/construct.t b/t/cdbi/construct.t index d10e6a1a5..5040b06e2 100644 --- a/t/cdbi/construct.t +++ b/t/cdbi/construct.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/copy.t b/t/cdbi/copy.t index f587ae03d..b1227816b 100644 --- a/t/cdbi/copy.t +++ b/t/cdbi/copy.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; @@ -17,6 +18,11 @@ use lib 't/cdbi/testlib'; __PACKAGE__->set_table('Movies'); __PACKAGE__->columns(All => qw(id title)); + # Disables the implicit autoinc-on-non-supplied-pk behavior + # (and the warning that goes with it) + # This is the same behavior as it was pre 0.082900 + __PACKAGE__->column_info('id')->{is_auto_increment} = 0; + sub create_sql { return qq{ id INTEGER PRIMARY KEY AUTOINCREMENT, diff --git a/t/cdbi/early_column_heisenbug.t b/t/cdbi/early_column_heisenbug.t index e91b40125..8ecea27ba 100644 --- a/t/cdbi/early_column_heisenbug.t +++ b/t/cdbi/early_column_heisenbug.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/has_many_loads_foreign_class.t b/t/cdbi/has_many_loads_foreign_class.t index 5485972cb..be5553dd9 100644 --- a/t/cdbi/has_many_loads_foreign_class.t +++ b/t/cdbi/has_many_loads_foreign_class.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; @@ -6,11 +7,11 @@ use warnings; use Test::More; use lib 't/cdbi/testlib'; +use DBICTest::Util 'class_seems_loaded'; use Director; # Test that has_many() will load the foreign class -require Class::Inspector; -ok !Class::Inspector->loaded( 'Film' ); +ok ! class_seems_loaded('Film'), 'Start non-loaded'; ok eval { Director->has_many( films => 'Film' ); 1; } or diag $@; my $shan_hua = Director->create({ diff --git a/t/cdbi/hasa_without_loading.t b/t/cdbi/hasa_without_loading.t index 3b92c4db1..e365fd519 100644 --- a/t/cdbi/hasa_without_loading.t +++ b/t/cdbi/hasa_without_loading.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/max_min_value_of.t b/t/cdbi/max_min_value_of.t index aba3821f5..aff1dd7d1 100644 --- a/t/cdbi/max_min_value_of.t +++ b/t/cdbi/max_min_value_of.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/mk_group_accessors.t b/t/cdbi/mk_group_accessors.t index 5fc1994a2..fdd960076 100644 --- a/t/cdbi/mk_group_accessors.t +++ b/t/cdbi/mk_group_accessors.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/multi_column_set.t b/t/cdbi/multi_column_set.t index 1f1d1ac6e..cf0632a10 100644 --- a/t/cdbi/multi_column_set.t +++ b/t/cdbi/multi_column_set.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/object_cache.t b/t/cdbi/object_cache.t index db0dc06df..378395aea 100644 --- a/t/cdbi/object_cache.t +++ b/t/cdbi/object_cache.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/retrieve_from_sql_with_limit.t b/t/cdbi/retrieve_from_sql_with_limit.t index 404536155..b209ba0ca 100644 --- a/t/cdbi/retrieve_from_sql_with_limit.t +++ b/t/cdbi/retrieve_from_sql_with_limit.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/set_to_undef.t b/t/cdbi/set_to_undef.t index 5b642e026..149be2c5a 100644 --- a/t/cdbi/set_to_undef.t +++ b/t/cdbi/set_to_undef.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt cdbicompat ); use strict; diff --git a/t/cdbi/set_vs_DateTime.t b/t/cdbi/set_vs_DateTime.t index 2fe087921..05d66b50d 100644 --- a/t/cdbi/set_vs_DateTime.t +++ b/t/cdbi/set_vs_DateTime.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt cdbicompat ); use strict; diff --git a/t/cdbi/sweet/08pager.t b/t/cdbi/sweet/08pager.t index 7f94e51b2..b91f89736 100644 --- a/t/cdbi/sweet/08pager.t +++ b/t/cdbi/sweet/08pager.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; -use lib 't/lib'; + use DBICTest; DBICTest::Schema::CD->load_components(qw/CDBICompat CDBICompat::Pager/); diff --git a/t/cdbi/testlib/Actor.pm b/t/cdbi/testlib/Actor.pm index 83a03b9fe..3bffd09d3 100644 --- a/t/cdbi/testlib/Actor.pm +++ b/t/cdbi/testlib/Actor.pm @@ -13,6 +13,11 @@ __PACKAGE__->columns(All => qw/ Name Film Salary /); __PACKAGE__->columns(TEMP => qw/ nonpersistent /); __PACKAGE__->add_constructor(salary_between => 'salary >= ? AND salary <= ?'); +# Disables the implicit autoinc-on-non-supplied-pk behavior +# (and the warning that goes with it) +# This is the same behavior as it was pre 0.082900 +__PACKAGE__->column_info('id')->{is_auto_increment} = 0; + sub mutator_name_for { "set_$_[1]" } sub create_sql { diff --git a/t/cdbi/testlib/ActorAlias.pm b/t/cdbi/testlib/ActorAlias.pm index 862a410b4..5fb9456d1 100644 --- a/t/cdbi/testlib/ActorAlias.pm +++ b/t/cdbi/testlib/ActorAlias.pm @@ -13,6 +13,11 @@ __PACKAGE__->columns( All => qw/ actor alias / ); __PACKAGE__->has_a( actor => 'Actor' ); __PACKAGE__->has_a( alias => 'Actor' ); +# Disables the implicit autoinc-on-non-supplied-pk behavior +# (and the warning that goes with it) +# This is the same behavior as it was pre 0.082900 +__PACKAGE__->column_info('id')->{is_auto_increment} = 0; + sub create_sql { return qq{ id INTEGER PRIMARY KEY, diff --git a/t/cdbi/testlib/ColumnObject.pm b/t/cdbi/testlib/ColumnObject.pm index 11eeb893e..0811367e0 100644 --- a/t/cdbi/testlib/ColumnObject.pm +++ b/t/cdbi/testlib/ColumnObject.pm @@ -18,6 +18,11 @@ __PACKAGE__->columns( All => ( Class::DBI::Column->new('columnb' => {mutator => 'columnb_as_write'}), )); +# Disables the implicit autoinc-on-non-supplied-pk behavior +# (and the warning that goes with it) +# This is the same behavior as it was pre 0.082900 +__PACKAGE__->column_info('id')->{is_auto_increment} = 0; + sub create_sql { return qq{ id INTEGER PRIMARY KEY, diff --git a/t/cdbi/testlib/DBIC/Test/SQLite.pm b/t/cdbi/testlib/DBIC/Test/SQLite.pm index 76822cdd5..87a17f21b 100644 --- a/t/cdbi/testlib/DBIC/Test/SQLite.pm +++ b/t/cdbi/testlib/DBIC/Test/SQLite.pm @@ -39,11 +39,27 @@ table, and tie it to the class. # change too much BEGIN { $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} = 0 } -use lib 't/lib'; use DBICTest; use base qw/DBIx::Class/; +BEGIN { + # offset the warning from DBIx::Class::Schema on 5.8 + # keep the ::Schema default as-is otherwise + DBIx::Class::_ENV_::OLD_MRO + and + ( eval <<'EOS' or die $@ ); + + sub setup_schema_instance { + my $s = shift->next::method(@_); + $s->schema_sanity_checker(''); + $s; + } + + 1; +EOS +} + __PACKAGE__->load_components(qw/CDBICompat Core DB/); my $DB = DBICTest->_sqlite_dbfilename; diff --git a/t/cdbi/testlib/Film.pm b/t/cdbi/testlib/Film.pm index 3bbd755e0..5c43f5a2a 100644 --- a/t/cdbi/testlib/Film.pm +++ b/t/cdbi/testlib/Film.pm @@ -12,6 +12,11 @@ __PACKAGE__->columns('Essential', qw( Title )); __PACKAGE__->columns('Directors', qw( Director CoDirector )); __PACKAGE__->columns('Other', qw( Rating NumExplodingSheep HasVomit )); +# Disables the implicit autoinc-on-non-supplied-pk behavior +# (and the warning that goes with it) +# This is the same behavior as it was pre 0.082900 +__PACKAGE__->column_info('title')->{is_auto_increment} = 0; + sub create_sql { return qq{ title VARCHAR(255), diff --git a/t/cdbi/testlib/ImplicitInflate.pm b/t/cdbi/testlib/ImplicitInflate.pm index 610e83550..14b2bf854 100644 --- a/t/cdbi/testlib/ImplicitInflate.pm +++ b/t/cdbi/testlib/ImplicitInflate.pm @@ -19,6 +19,12 @@ __PACKAGE__->has_a( update_datetime => 'MyDateStamp', ); + +# Disables the implicit autoinc-on-non-supplied-pk behavior +# (and the warning that goes with it) +# This is the same behavior as it was pre 0.082900 +__PACKAGE__->column_info('id')->{is_auto_increment} = 0; + sub create_sql { # SQLite doesn't support Datetime datatypes. return qq{ diff --git a/t/cdbi/testlib/Log.pm b/t/cdbi/testlib/Log.pm index 362b61e6d..c17b9bbde 100644 --- a/t/cdbi/testlib/Log.pm +++ b/t/cdbi/testlib/Log.pm @@ -17,6 +17,11 @@ __PACKAGE__->has_a( deflate => 'mysql_datetime' ); +# Disables the implicit autoinc-on-non-supplied-pk behavior +# (and the warning that goes with it) +# This is the same behavior as it was pre 0.082900 +__PACKAGE__->column_info('id')->{is_auto_increment} = 0; + __PACKAGE__->add_trigger(before_create => \&set_dts); __PACKAGE__->add_trigger(before_update => \&set_dts); diff --git a/t/cdbi/testlib/MyBase.pm b/t/cdbi/testlib/MyBase.pm index 1fe93178f..106b359db 100644 --- a/t/cdbi/testlib/MyBase.pm +++ b/t/cdbi/testlib/MyBase.pm @@ -5,10 +5,25 @@ use warnings; use strict; use DBI; - -use lib 't/lib'; use DBICTest; +BEGIN { + # offset the warning from DBIx::Class::Schema on 5.8 + # keep the ::Schema default as-is otherwise + DBIx::Class::_ENV_::OLD_MRO + and + ( eval <<'EOS' or die $@ ); + + sub setup_schema_instance { + my $s = shift->next::method(@_); + $s->schema_sanity_checker(''); + $s; + } + + 1; +EOS +} + use base qw(DBIx::Class::CDBICompat); my @connect = (@ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}, { PrintError => 0}); diff --git a/t/cdbi/testlib/MyFilm.pm b/t/cdbi/testlib/MyFilm.pm deleted file mode 100644 index 40ecf7e77..000000000 --- a/t/cdbi/testlib/MyFilm.pm +++ /dev/null @@ -1,27 +0,0 @@ -package # hide from PAUSE - MyFilm; - -use warnings; -use strict; - -use base 'MyBase'; -use MyStarLink; - -__PACKAGE__->set_table(); -__PACKAGE__->columns(All => qw/filmid title/); -__PACKAGE__->has_many(_stars => 'MyStarLink'); -__PACKAGE__->columns(Stringify => 'title'); - -sub _carp { } - -sub stars { map $_->star, shift->_stars } - -sub create_sql { - return qq{ - filmid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY, - title VARCHAR(255) - }; -} - -1; - diff --git a/t/cdbi/testlib/MyFoo.pm b/t/cdbi/testlib/MyFoo.pm index 7df9c6f6d..fa45d7dab 100644 --- a/t/cdbi/testlib/MyFoo.pm +++ b/t/cdbi/testlib/MyFoo.pm @@ -13,6 +13,12 @@ __PACKAGE__->has_a( inflate => sub { Date::Simple->new(shift) }, deflate => 'format', ); + +# Disables the implicit autoinc-on-non-supplied-pk behavior +# (and the warning that goes with it) +# This is the same behavior as it was pre 0.082900 +__PACKAGE__->column_info('myid')->{is_auto_increment} = 0; + #__PACKAGE__->find_column('tdate')->placeholder("IF(1, CURDATE(), ?)"); sub create_sql { diff --git a/t/cdbi/testlib/MyStar.pm b/t/cdbi/testlib/MyStar.pm deleted file mode 100644 index 100fbf4a0..000000000 --- a/t/cdbi/testlib/MyStar.pm +++ /dev/null @@ -1,23 +0,0 @@ -package # hide from PAUSE - MyStar; - -use warnings; -use strict; - -use base 'MyBase'; - -__PACKAGE__->set_table(); -__PACKAGE__->columns(All => qw/starid name/); -__PACKAGE__->has_many(films => [ MyStarLink => 'film' ]); - -# sub films { map $_->film, shift->_films } - -sub create_sql { - return qq{ - starid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY, - name VARCHAR(255) - }; -} - -1; - diff --git a/t/cdbi/testlib/MyStarLink.pm b/t/cdbi/testlib/MyStarLink.pm deleted file mode 100644 index 27254d884..000000000 --- a/t/cdbi/testlib/MyStarLink.pm +++ /dev/null @@ -1,23 +0,0 @@ -package # hide from PAUSE - MyStarLink; - -use warnings; -use strict; - -use base 'MyBase'; - -__PACKAGE__->set_table(); -__PACKAGE__->columns(All => qw/linkid film star/); -__PACKAGE__->has_a(film => 'MyFilm'); -__PACKAGE__->has_a(star => 'MyStar'); - -sub create_sql { - return qq{ - linkid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY, - film TINYINT NOT NULL, - star TINYINT NOT NULL - }; -} - -1; - diff --git a/t/cdbi/testlib/MyStarLinkMCPK.pm b/t/cdbi/testlib/MyStarLinkMCPK.pm deleted file mode 100644 index 1173163be..000000000 --- a/t/cdbi/testlib/MyStarLinkMCPK.pm +++ /dev/null @@ -1,30 +0,0 @@ -package # hide from PAUSE - MyStarLinkMCPK; - -use warnings; -use strict; - -use base 'MyBase'; - -use MyStar; -use MyFilm; - -# 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 - -__PACKAGE__->set_table(); -__PACKAGE__->columns(Primary => qw/film star/); -__PACKAGE__->columns(All => qw/film star/); -__PACKAGE__->has_a(film => 'MyFilm'); -__PACKAGE__->has_a(star => 'MyStar'); - -sub create_sql { - return qq{ - film INTEGER NOT NULL, - star INTEGER NOT NULL, - PRIMARY KEY (film, star) - }; -} - -1; - diff --git a/t/cdbi/testlib/OtherFilm.pm b/t/cdbi/testlib/OtherFilm.pm deleted file mode 100644 index a0afdd8b5..000000000 --- a/t/cdbi/testlib/OtherFilm.pm +++ /dev/null @@ -1,23 +0,0 @@ -package # hide from PAUSE - OtherFilm; - -use warnings; -use strict; - -use base 'Film'; - -__PACKAGE__->set_table('Different_Film'); - -sub create_sql { - return qq{ - title VARCHAR(255), - director VARCHAR(80), - codirector VARCHAR(80), - rating CHAR(5), - numexplodingsheep INTEGER, - hasvomit CHAR(1) - }; -} - -1; - diff --git a/t/count/count_rs.t b/t/count/count_rs.t index 174f6307f..7afd11e8d 100644 --- a/t/count/count_rs.t +++ b/t/count/count_rs.t @@ -1,8 +1,8 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib qw(t/lib); - use Test::More; use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/count/distinct.t b/t/count/distinct.t index e916ab941..edd3d35d4 100644 --- a/t/count/distinct.t +++ b/t/count/distinct.t @@ -1,11 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); - use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/count/group_by_func.t b/t/count/group_by_func.t index 661cc9ec2..14f3f8ae7 100644 --- a/t/count/group_by_func.t +++ b/t/count/group_by_func.t @@ -1,10 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; - -use lib qw(t/lib); - use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/count/grouped_pager.t b/t/count/grouped_pager.t index 6bb61531b..5c23fad63 100644 --- a/t/count/grouped_pager.t +++ b/t/count/grouped_pager.t @@ -1,10 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; - -use lib qw(t/lib); - use DBICTest; plan tests => 7; diff --git a/t/count/in_subquery.t b/t/count/in_subquery.t index 85f48d083..765815d9f 100644 --- a/t/count/in_subquery.t +++ b/t/count/in_subquery.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/count/joined.t b/t/count/joined.t index bb8eb4c48..e6f3afa85 100644 --- a/t/count/joined.t +++ b/t/count/joined.t @@ -1,10 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; - -use lib qw(t/lib); - use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/count/prefetch.t b/t/count/prefetch.t index eb18236d8..07a5d2825 100644 --- a/t/count/prefetch.t +++ b/t/count/prefetch.t @@ -1,8 +1,8 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib qw(t/lib); - use Test::More; use DBICTest ':DiffSQL'; diff --git a/t/count/search_related.t b/t/count/search_related.t index 11f5796c6..0ebf8e454 100644 --- a/t/count/search_related.t +++ b/t/count/search_related.t @@ -1,10 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; - -use lib qw(t/lib); - use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/delete/cascade_missing.t b/t/delete/cascade_missing.t index 8bd8a769b..54270e8a5 100644 --- a/t/delete/cascade_missing.t +++ b/t/delete/cascade_missing.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -5,7 +7,7 @@ use Test::More; use Test::Warn; use Test::Exception; -use lib 't/lib'; + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/delete/complex.t b/t/delete/complex.t index 149bcf1d2..11ef35b4d 100644 --- a/t/delete/complex.t +++ b/t/delete/complex.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/delete/m2m.t b/t/delete/m2m.t index 7a1628d76..cd2951882 100644 --- a/t/delete/m2m.t +++ b/t/delete/m2m.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/delete/related.t b/t/delete/related.t index d4dc26b5e..f009709ff 100644 --- a/t/delete/related.t +++ b/t/delete/related.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/icdt/core.t b/t/icdt/core.t index 8f0c83c01..5af1ac3f9 100644 --- a/t/icdt/core.t +++ b/t/icdt/core.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( test_rdbms_sqlite ic_dt ); use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/icdt/datetime_missing_deps.t b/t/icdt/datetime_missing_deps.t index 680a3f1b1..f2f864a08 100644 --- a/t/icdt/datetime_missing_deps.t +++ b/t/icdt/datetime_missing_deps.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $no_class = '_DBICTEST_NONEXISTENT_CLASS_'; diff --git a/t/icdt/engine_specific/firebird.t b/t/icdt/engine_specific/firebird.t index 05ef3812d..5ce1d8f59 100644 --- a/t/icdt/engine_specific/firebird.t +++ b/t/icdt/engine_specific/firebird.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt _rdbms_firebird_common ); use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); + use DBICTest; my $env2optdep = { @@ -27,14 +28,11 @@ my $schema; for my $prefix (keys %$env2optdep) { SKIP: { - my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; - - next unless $dsn; + DBIx::Class::Optional::Dependencies->skip_without( $env2optdep->{$prefix} ); 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}); + my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; $schema = DBICTest::Schema->connect($dsn, $user, $pass, { quote_char => '"', diff --git a/t/icdt/engine_specific/informix.t b/t/icdt/engine_specific/informix.t index 4a6231c05..2ca980c0b 100644 --- a/t/icdt/engine_specific/informix.t +++ b/t/icdt/engine_specific/informix.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt test_rdbms_informix ); use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_INFORMIX_${_}" } qw/DSN USER PASS/}; diff --git a/t/icdt/engine_specific/msaccess.t b/t/icdt/engine_specific/msaccess.t index 9e647fbe9..8f304ca2b 100644 --- a/t/icdt/engine_specific/msaccess.t +++ b/t/icdt/engine_specific/msaccess.t @@ -1,12 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt _rdbms_msaccess_common ); use strict; use warnings; use Test::More; -use Try::Tiny; use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); + use DBICTest; my @tdeps = qw( test_rdbms_msaccess_odbc test_rdbms_msaccess_ado ); @@ -38,7 +38,7 @@ for my $connect_info (@connect_info) { my $guard = scope_guard { cleanup($schema) }; - try { local $^W = 0; $schema->storage->dbh->do('DROP TABLE track') }; + eval { local $^W = 0; $schema->storage->dbh->do('DROP TABLE track') }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE track ( trackid AUTOINCREMENT PRIMARY KEY, diff --git a/t/icdt/engine_specific/mssql.t b/t/icdt/engine_specific/mssql.t index e65a994ea..3ba9d128b 100644 --- a/t/icdt/engine_specific/mssql.t +++ b/t/icdt/engine_specific/mssql.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt _rdbms_mssql_common ); use strict; @@ -5,9 +6,8 @@ use warnings; use Test::More; use Test::Exception; -use Try::Tiny; use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); + use DBICTest; my @tdeps = qw( test_rdbms_mssql_odbc test_rdbms_mssql_sybase test_rdbms_mssql_ado ); @@ -55,7 +55,7 @@ for my $connect_info (@connect_info) { my $guard = scope_guard { cleanup($schema) }; # $^W because DBD::ADO is a piece of crap - try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE track") }; + eval { local $^W = 0; $schema->storage->dbh->do("DROP TABLE track") }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE track ( trackid INT IDENTITY PRIMARY KEY, @@ -64,14 +64,14 @@ CREATE TABLE track ( last_updated_at DATETIME, ) SQL - try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE event_small_dt") }; + eval { local $^W = 0; $schema->storage->dbh->do("DROP TABLE event_small_dt") }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE event_small_dt ( id INT IDENTITY PRIMARY KEY, small_dt SMALLDATETIME, ) SQL - try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE event") }; + eval { local $^W = 0; $schema->storage->dbh->do("DROP TABLE event") }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE event ( id int IDENTITY(1,1) NOT NULL, diff --git a/t/icdt/engine_specific/oracle.t b/t/icdt/engine_specific/oracle.t index 4dc94b3d3..778a5785a 100644 --- a/t/icdt/engine_specific/oracle.t +++ b/t/icdt/engine_specific/oracle.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt test_rdbms_oracle ); use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; # DateTime::Format::Oracle needs this set diff --git a/t/icdt/engine_specific/sqlanywhere.t b/t/icdt/engine_specific/sqlanywhere.t index 0bac9dc53..00e9d563d 100644 --- a/t/icdt/engine_specific/sqlanywhere.t +++ b/t/icdt/engine_specific/sqlanywhere.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt _rdbms_sqlanywhere_common ); use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); + use DBICTest; my @tdeps = qw( test_rdbms_sqlanywhere test_rdbms_sqlanywhere_odbc ); diff --git a/t/icdt/engine_specific/sqlite.t b/t/icdt/engine_specific/sqlite.t index f9b321036..1c8b9215c 100644 --- a/t/icdt/engine_specific/sqlite.t +++ b/t/icdt/engine_specific/sqlite.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt test_rdbms_sqlite ); use strict; @@ -5,8 +6,7 @@ use warnings; use Test::More; use Test::Warn; -use Try::Tiny; -use lib qw(t/lib); + use DBICTest; # Test offline parser determination (formerly t/inflate/datetime_determine_parser.t) @@ -17,7 +17,7 @@ use DBICTest; my $storage = $schema->storage; - if ($ENV{DBICTEST_VIA_REPLICATED}) { + if( $storage->isa('DBIx::Class::Storage::DBI::Replicated') ) { $storage = $storage->master; } else { diff --git a/t/icdt/engine_specific/sybase.t b/t/icdt/engine_specific/sybase.t index c63944e17..f4b8c7bb3 100644 --- a/t/icdt/engine_specific/sybase.t +++ b/t/icdt/engine_specific/sybase.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt test_rdbms_ase ); use strict; @@ -5,8 +6,8 @@ use warnings; use Test::More; use Test::Exception; -use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); +use DBIx::Class::_Util qw( scope_guard set_subname ); + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_${_}" } qw/DSN USER PASS/}; @@ -93,7 +94,7 @@ SQL %$create_extra, })); ok( $row = $schema->resultset($source) - ->search({ $pk => $row->$pk }, { select => [$col] }) + ->search({ $pk => $row->$pk }, { select => [$pk, $col] }) ->first ); is( $row->$col, $dt, "$type roundtrip" ); @@ -101,6 +102,46 @@ SQL cmp_ok( $row->$col->nanosecond, '==', $sample_dt->{nanosecond}, 'DateTime fractional portion roundtrip' ) if exists $sample_dt->{nanosecond}; + + # Testing an ugly half-solution + # + # copy() uses get_columns() + # + # The values should survive a roundtrip also, but they don't + # because the Sybase ICDT setup is asymmetric + # One *has* to force an inflation/deflation cycle to make the + # values usable to the database + # + # This can be done by marking the columns as dirty, and there + # are tests for this already in t/inflate/serialize.t + # + # But even this isn't enough - one has to reload the RDBMS-formatted + # values once done, otherwise the copy is just as useless... sigh + # + # Adding the test here to validate the technique works + # UGH! + { + no warnings 'once'; + local *DBICTest::BaseResult::copy = set_subname 'DBICTest::BaseResult::copy' => sub { + my $self = shift; + + $self->make_column_dirty($_) for keys %{{ $self->get_inflated_columns }}; + + my $cp = $self->next::method(@_); + + $cp->discard_changes({ columns => [ keys %{{ $cp->get_columns }} ] }); + }; + Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; + + my $cp = $row->copy; + ok( $cp->in_storage ); + is( $cp->$col, $dt, "$type copy logical roundtrip" ); + + $cp->discard_changes({ select => [ $pk, $col ] }); + is( $cp->$col, $dt, "$type copy server roundtrip" ); + } + + Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; } # test a computed datetime column diff --git a/t/icdt/offline_mysql.t b/t/icdt/offline_mysql.t index 91bd3f65a..c9d519707 100644 --- a/t/icdt/offline_mysql.t +++ b/t/icdt/offline_mysql.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt_mysql ); use strict; @@ -6,7 +7,7 @@ use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest; use DBICTest::Schema; use DBIx::Class::_Util 'sigwarn_silencer'; @@ -19,7 +20,7 @@ use DBIx::Class::_Util 'sigwarn_silencer'; my $schema = DBICTest->init_schema(); -# Test "timezone" parameter +# Test "time_zone" parameter foreach my $tbl (qw/EventTZ EventTZDeprecated/) { my $event_tz = $schema->resultset($tbl)->create({ starts_at => DateTime->new(year=>2007, month=>12, day=>31, time_zone => "America/Chicago" ), @@ -33,25 +34,25 @@ foreach my $tbl (qw/EventTZ EventTZDeprecated/) { is ($event_tz->created_on->month_name, "January", 'Default locale loaded: month_name'); my $starts_at = $event_tz->starts_at; - is("$starts_at", '2007-12-31T00:00:00', 'Correct date/time using timezone'); + is("$starts_at", '2007-12-31T00:00:00', 'Correct date/time using time zone'); my $created_on = $event_tz->created_on; - is("$created_on", '2006-01-31T12:34:56', 'Correct timestamp using timezone'); - is($event_tz->created_on->time_zone->name, "America/Chicago", "Correct timezone"); + is("$created_on", '2006-01-31T12:34:56', 'Correct timestamp using time zone'); + is($event_tz->created_on->time_zone->name, "America/Chicago", "Correct time zone"); my $loaded_event = $schema->resultset($tbl)->find( $event_tz->id ); isa_ok($loaded_event->starts_at, 'DateTime', 'DateTime returned'); $starts_at = $loaded_event->starts_at; - is("$starts_at", '2007-12-31T00:00:00', 'Loaded correct date/time using timezone'); - is($starts_at->time_zone->name, 'America/Chicago', 'Correct timezone'); + is("$starts_at", '2007-12-31T00:00:00', 'Loaded correct date/time using time zone'); + is($starts_at->time_zone->name, 'America/Chicago', 'Correct time zone'); isa_ok($loaded_event->created_on, 'DateTime', 'DateTime returned'); $created_on = $loaded_event->created_on; - is("$created_on", '2006-01-31T12:34:56', 'Loaded correct timestamp using timezone'); - is($created_on->time_zone->name, 'America/Chicago', 'Correct timezone'); + is("$created_on", '2006-01-31T12:34:56', 'Loaded correct timestamp using time zone'); + is($created_on->time_zone->name, 'America/Chicago', 'Correct time zone'); - # Test floating timezone warning + # Test floating time zone warning # We expect one warning SKIP: { skip "ENV{DBIC_FLOATING_TZ_OK} was set, skipping", 1 if $ENV{DBIC_FLOATING_TZ_OK}; @@ -62,8 +63,8 @@ foreach my $tbl (qw/EventTZ EventTZDeprecated/) { created_on => DateTime->new(year=>2006, month=>1, day=>31, hour => 13, minute => 34, second => 56 ), }); }, - qr/You're using a floating timezone, please see the documentation of DBIx::Class::InflateColumn::DateTime for an explanation/, - 'Floating timezone warning' + qr/You're using a floating time zone, please see the documentation of DBIx::Class::InflateColumn::DateTime for an explanation/, + 'Floating time zone warning' ); }; diff --git a/t/icdt/offline_pg.t b/t/icdt/offline_pg.t index 0c0cb9b41..bfd931ce6 100644 --- a/t/icdt/offline_pg.t +++ b/t/icdt/offline_pg.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt_pg ); use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; DBICTest::Schema->load_classes('EventTZPg'); @@ -22,6 +23,13 @@ DBICTest::Schema->load_classes('EventTZPg'); my $parser = $s->storage->datetime_parser; is( $parser, 'DateTime::Format::Pg', 'datetime_parser is as expected'); + my $colinfo = $s->source('EventTZPg')->column_info('created_on'); + is ( + $colinfo->{timezone}, + $colinfo->{time_zone}, + 'Legacy timezone key is still present in colinfo', + ); + ok (!$s->storage->_dbh, 'still not connected'); } diff --git a/t/inflate/file_column.t b/t/inflate/file_column.t index 1b69e51de..453adeefe 100644 --- a/t/inflate/file_column.t +++ b/t/inflate/file_column.t @@ -1,12 +1,14 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } +use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_file ); + use strict; use warnings; use Test::More; -use lib qw(t/lib); - use DBICTest; use DBICTest::Schema; +use File::Temp (); use File::Compare; use Path::Class qw/file/; @@ -19,8 +21,6 @@ use Path::Class qw/file/; use warnings; use base qw/DBICTest::BaseResult/; - use File::Temp qw/tempdir/; - __PACKAGE__->load_components (qw/InflateColumn::File/); __PACKAGE__->table('file_columns'); @@ -29,7 +29,7 @@ use Path::Class qw/file/; file => { data_type => 'varchar', is_file_column => 1, - file_column_path => tempdir(CLEANUP => 1), + file_column_path => File::Temp->newdir( CLEANUP => 1, DIR => DBICTest::Util::tmpdir() ), size => 255 } ); diff --git a/t/inflate/hri.t b/t/inflate/hri.t index b5e9d2f54..0564cad36 100644 --- a/t/inflate/hri.t +++ b/t/inflate/hri.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -11,7 +13,7 @@ BEGIN { } use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/inflate/hri_torture.t b/t/inflate/hri_torture.t index 92aa2d8af..610a47b40 100644 --- a/t/inflate/hri_torture.t +++ b/t/inflate/hri_torture.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Deep; -use lib qw(t/lib); + use DBICTest; # More tests like this in t/prefetch/manual.t @@ -38,6 +40,7 @@ $schema->resultset('CD')->create({ title => 'Oxygene', year => 1976, artist => { name => 'JMJ' }, + artwork => {}, tracks => [ { title => 'o2', position => 2}, # the position should not be needed here, bug in MC ], @@ -328,6 +331,43 @@ cmp_deeply 'collapsing 1:1:1:M:M chain ' . $rs->result_class, ; +cmp_deeply + [ $rs->search_rs ( + { + 'tracks.title' => 'e2', + 'cds.title' => 'Oxygene', + }, + { + collapse => 1, + join => [ + 'tracks', + { single_track => { cd => 'mandatory_artwork' } }, + { artist => { cds => 'mandatory_artwork'} }, + ], + columns => { + cdid => 'cdid', + 'single_track.cd.mandatory_artwork.cd_id' => 'mandatory_artwork.cd_id', + 'artist.cds.mandatory_artwork.cd_id' => 'mandatory_artwork_2.cd_id', + }, + }, + )->all ], + [ + { + cdid => 3, + single_track => { + cd => { + mandatory_artwork => { cd_id => 2 }, + }, + }, + artist => { + cds => [ + { mandatory_artwork => { cd_id => 2 } } + ] + }, + }, + ], +; + } done_testing; diff --git a/t/inflate/serialize.t b/t/inflate/serialize.t index 63c31aaa9..2da03476a 100644 --- a/t/inflate/serialize.t +++ b/t/inflate/serialize.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/lib/ANFANG.pm b/t/lib/ANFANG.pm new file mode 100644 index 000000000..c429d740d --- /dev/null +++ b/t/lib/ANFANG.pm @@ -0,0 +1,206 @@ +package # hide from pauses + ANFANG; + +# load-time critical +BEGIN { + if ( $ENV{RELEASE_TESTING} ) { + require warnings and warnings->import; + require strict and strict->import; + } +} + +# +# FROM THIS POINT ONWARD EVERYTHING HAPPENS LINEARLY AT RUNTIME +# +our $anfang_loaded; + +# this allows the obscure but possible call case to behave correctly: +# +# perl -It/lib -MANFANG -e 'do "./t/lib/ANFANG.pm" or die ( $@ || $! )' +# +return 1 if $anfang_loaded; + +# cover even more bases +$INC{$_} ||= __FILE__ for (qw( ANFANG.pm t/lib/ANFANG.pm ./t/lib/ANFANG.pm )); + +{ + # load-me-first sanity check + if ( + + # nobody shut us off + ! $ENV{DBICTEST_ANFANG_DEFANG} + + and + + # if these are set - all bets are off + ! ( + $ENV{PERL5OPT} + or + scalar grep { $_ =~ m| \/ sitecustomize\.pl $ |x } keys %INC + ) + + and + + # -d:Confess / -d:TraceUse and the like + ! $^P + + and + + # a ghetto way of recognizing cperl without loading Config.pm + # the $] guard is there because touching $^V on pre-5.10 loads + # the entire utf8 stack (wtf!!!) + ( "$]" < 5.010 or $^V !~ /\d+c$/ ) + + and + + # just don't check anything under RELEASE_TESTING + # a naive approach would be to simply whitelist both + # strict and warnings, but pre 5.10 there were even + # more modules loaded by these two: + # + # perlbrew exec perl -Mstrict -Mwarnings -e 'warn join "\n", sort keys %INC' + # + ! $ENV{RELEASE_TESTING} + + and + + my @undesirables = grep { + + ($INC{$_}||'') ne __FILE__ + + and + + # allow direct loads via -M + $_ !~ m{^ DBICTest (?: /Schema )? \.pm $}x + + } keys %INC + + ) { + + my ( $fr, @frame ); + while (@frame = caller(++$fr)) { + last if $frame[1] !~ m{ (?: \A | [\/\\] ) t [\/\\] lib [\/\\] }x; + } + + die __FILE__ . " must be loaded before any other module (i.e. @{[ join ', ', map { qq('$_') } sort @undesirables ]}) at $frame[1] line $frame[2]\n"; + } + + + if ( $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY} ) { + my $ov = UNIVERSAL->can("VERSION"); + + require Carp; + + # in case we loaded warnings.pm / used -w + # ( do not do `no warnings ...` as it is also a load ) + local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /redefined/ }; + + *UNIVERSAL::VERSION = sub { + Carp::carp( 'Argument "blah bleh bloh" isn\'t numeric in subroutine entry' ); + &$ov; + }; + } + + + if ( + $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} + or + # keep it always on during CI + ( + ($ENV{TRAVIS}||'') eq 'true' + and + ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/dbix-class$| + ) + ) { + # two levels of if() because of taint mode tangling the %ENV-checks + # with the require() call, sigh... + + if ( eval { require Try::Tiny } ) { + my $orig = \&Try::Tiny::try; + + # in case we loaded warnings.pm / used -w + # ( do not do `no warnings ...` as it is also a load ) + local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /redefined/ }; + + *Try::Tiny::try = sub (&;@) { + my ($fr, $first_pkg) = 0; + while( $first_pkg = caller($fr++) ) { + last if $first_pkg !~ /^ + __ANON__ + | + \Q(eval)\E + $/x; + } + + if ($first_pkg =~ /DBIx::Class/) { + require Test::Builder; + Test::Builder->new->ok(0, + 'Using try{} within DBIC internals is a mistake - use dbic_internal_try{} instead' + ); + } + + goto $orig; + }; + } + } +} + + +unshift @INC, 't/lib'; + + +# everything expects this to be there +! -d 't/var' + and +( + mkdir 't/var' + or + # creation is inherently racy + do { + my $err = $!; + require Errno; + die "Unable to create 't/var': $err\n" + unless $err == Errno::EEXIST(); + } +); + + +# Back in ab340f7f ribasushi stupidly introduced a "did you check your deps" +# verification tied very tightly to Module::Install. The check went away, and +# so eventually will M::I, but bisecting can bring all of this back from the +# dead. In order to reduce hair-pulling make sure that ./inc/ is always there +-f 'Makefile.PL' and mkdir 'inc' and mkdir 'inc/.author'; + +END { + if( my @finalest_tasks = ( + + ( !$ENV{DBICTEST_DIRTY_EXIT} ? () : sub { + + my $exit = $?; + require POSIX; + + # Crucial flushes in case we are piping things out (e.g. prove) + # Otherwise the last lines will never arrive at the receiver + close($_) for \*STDOUT, \*STDERR; + + POSIX::_exit($exit); + } ), + + )) { + + # in the case of an early skip_all B may very well not have loaded + unless( $INC{"B.pm"} ) { + local ( $!, $^E, $?, $@ ); + require B; + } + + # Make sure we run after any cleanup in other END blocks + # ( push-to-end twice in a row ) + push @{ B::end_av()->object_2svref }, sub { + push @{ B::end_av()->object_2svref }, @finalest_tasks; + } + } +} + +# make absolutely sure this is last +$anfang_loaded = 1; diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index c0c91c276..cfc18df97 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -1,16 +1,54 @@ package # hide from PAUSE DBICTest; +# load early so that `perl -It/lib -MDBICTest` keeps working +use ANFANG; + use strict; use warnings; -use DBICTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); -use DBICTest::Schema; + +# this noop trick initializes the STDOUT, so that the TAP::Harness +# issued IO::Select->can_read calls (which are blocking wtf wtf wtf) +# keep spinning and scheduling jobs +# This results in an overall much smoother job-queue drainage, since +# the Harness blocks less +# (ideally this needs to be addressed in T::H, but a quick patchjob +# broke everything so tabling it for now) +BEGIN { + # FIXME - there probably is some way to determine a harness run (T::H or + # prove) but I do not know it offhand, especially on older environments + # Go with the safer option + if ($INC{'Test/Builder.pm'}) { + select( ( select(\*STDOUT), $|=1 )[0] ); + print STDOUT "#\n"; + } +} + + +use DBICTest::Util qw( + local_umask slurp_bytes tmpdir await_flock + dbg DEBUG_TEST_CONCURRENCY_LOCKS PEEPEENESS +); use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; -use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard ); + +# The actual ASSERT logic is in BaseSchema for pesky load-order reasons +# Hence run this through once, *before* DBICTest::Schema and friends load +BEGIN { + if ( + DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + or + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + ) { + require DBIx::Class::Row; + require DBICTest::BaseSchema; + DBICTest::BaseSchema->connect( sub {} ); + } +} + +use DBICTest::Schema; +use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard modver_gt_or_eq ); use Carp; -use Path::Class::File (); -use File::Spec; use Fcntl qw/:DEFAULT :flock/; use Config; @@ -20,9 +58,12 @@ DBICTest - Library to be used by DBIx::Class test scripts =head1 SYNOPSIS - use lib qw(t/lib); - use DBICTest; + BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + + use warnings; + use strict; use Test::More; + use DBICTest; my $schema = DBICTest->init_schema(); @@ -80,7 +121,7 @@ our ($global_lock_fh, $global_exclusive_lock); sub import { my $self = shift; - my $lockpath = DBICTest::RunMode->tmpdir->file('_dbictest_global.lock'); + my $lockpath = tmpdir . '_dbictest_global.lock'; { my $u = local_umask(0); # so that the file opens as 666, and any user can lock @@ -125,36 +166,21 @@ sub import { } END { - # referencing here delays destruction even more - if ($global_lock_fh) { - DEBUG_TEST_CONCURRENCY_LOCKS > 1 - and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)"; - 1; - } -} - -{ - my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var'); - $dir->mkpath unless -d "$dir"; - $dir = "$dir"; - - sub _sqlite_dbfilename { - my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$; - $holder = $$ if $holder == -1; + # referencing here delays destruction even more + if ($global_lock_fh) { + DEBUG_TEST_CONCURRENCY_LOCKS > 1 + and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)"; + 1; + } - # useful for missing cleanup debugging - #if ( $holder == $$) { - # my $x = $0; - # $x =~ s/\//#/g; - # $holder .= "-$x"; - #} + _cleanup_dbfile(); +} - return "$dir/DBIxClass-$holder.db"; - } +sub _sqlite_dbfilename { + my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$; + $holder = $$ if $holder == -1; - END { - _cleanup_dbfile(); - } + return "t/var/DBIxClass-$holder.db"; } $SIG{INT} = sub { _cleanup_dbfile(); exit 1 }; @@ -253,7 +279,7 @@ sub __mk_disconnect_guard { return if ( # this perl leaks handles, delaying DESTROY, can't work right - DBIx::Class::_ENV_::PEEPEENESS + PEEPEENESS or ! -f $db_file ); @@ -264,7 +290,7 @@ sub __mk_disconnect_guard { my $clan_connect_caller = '*UNKNOWN*'; my $i; - while ( my ($pack, $file, $line) = caller(++$i) ) { + while ( my ($pack, $file, $line) = CORE::caller(++$i) ) { next if $file eq __FILE__; next if $pack =~ /^DBIx::Class|^Try::Tiny/; $clan_connect_caller = "$file line $line"; @@ -338,8 +364,11 @@ sub init_schema { my $schema; if ( - $ENV{DBICTEST_VIA_REPLICATED} &&= - ( !$args{storage_type} && !defined $args{sqlite_use_file} ) + $ENV{DBICTEST_VIA_REPLICATED} &&= ( + !$args{storage_type} + && + ( ! defined $args{sqlite_use_file} or $args{sqlite_use_file} ) + ) ) { $args{storage_type} = ['::DBI::Replicated', { balancer_type => '::Random' }]; $args{sqlite_use_file} = 1; @@ -363,8 +392,19 @@ sub init_schema { if ( !$args{no_connect} ) { $schema->connection(@dsn); - $schema->storage->connect_replicants(\@dsn) - if $ENV{DBICTEST_VIA_REPLICATED}; + if( $ENV{DBICTEST_VIA_REPLICATED} ) { + + # add explicit ReadOnly=1 if we can support it + $dsn[0] =~ /^dbi:SQLite:/i + and + require DBD::SQLite + and + modver_gt_or_eq('DBD::SQLite', '1.49_05') + and + $dsn[0] =~ s/^dbi:SQLite:/dbi:SQLite(ReadOnly=1):/i; + + $schema->storage->connect_replicants(\@dsn); + } } if ( !$args{no_deploy} ) { @@ -412,9 +452,7 @@ sub deploy_schema { if ($ENV{"DBICTEST_SQLT_DEPLOY"}) { $schema->deploy($args); } else { - my $filename = Path::Class::File->new(__FILE__)->dir - ->file('sqlite.sql')->stringify; - my $sql = do { local (@ARGV, $/) = $filename ; <> }; + my $sql = slurp_bytes( 't/lib/sqlite.sql' ); for my $chunk ( split (/;\s*\n+/, $sql) ) { if ( $chunk =~ / ^ (?! --\s* ) \S /xm ) { # there is some real sql in the chunk - a non-space at the start of the string which is not a comment $schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n"; diff --git a/t/lib/DBICTest/Base.pm b/t/lib/DBICTest/Base.pm index 7d2cb5605..861020886 100644 --- a/t/lib/DBICTest/Base.pm +++ b/t/lib/DBICTest/Base.pm @@ -4,9 +4,10 @@ package #hide from pause use strict; use warnings; -# must load before any DBIx::Class* namespaces -use DBICTest::RunMode; +use DBICTest::Util; +# FIXME - Carp::Skip should somehow allow for augmentation based on +# mro::get_linear_isa or somesuch... sub _skip_namespace_frames { '^DBICTest' } 1; diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index f210c2d65..3ccd016e8 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -6,20 +6,83 @@ use warnings; use base qw(DBICTest::Base DBIx::Class::Schema); use Fcntl qw(:DEFAULT :seek :flock); -use Time::HiRes 'sleep'; -use DBIx::Class::_Util 'scope_guard'; +use IO::Handle (); +use DBIx::Class::_Util qw( emit_loud_diag scope_guard set_subname get_subname ); use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry); -use DBICTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); +use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); +use Scalar::Util qw( refaddr weaken ); +use Devel::GlobalDestruction (); use namespace::clean; +# Unless we are running assertions there is no value in checking ourselves +# during regular tests - the CI will do it for us +# +if ( + DBIx::Class::_ENV_::ASSERT_NO_FAILING_SANITY_CHECKS + and + # full-blown 5.8 sanity-checking is waaaaaay too slow, even for CI + ( + ! DBIx::Class::_ENV_::OLD_MRO + or + # still run a couple test with this, even on 5.8 + $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} + ) +) { + + __PACKAGE__->schema_sanity_checker('DBIx::Class::Schema::SanityChecker'); + + # Repeat the check on going out of scope (will catch weird runtime tinkering) + # Add only in case we will be using it, as it slows tests down + eval <<'EOD' or die $@; + + sub DESTROY { + if ( + ! Devel::GlobalDestruction::in_global_destruction() + and + my $checker = $_[0]->schema_sanity_checker + ) { + $checker->perform_schema_sanity_checks($_[0]); + } + + # *NOT* using next::method here - it (currently) will confuse Class::C3 + # in some obscure cases ( 5.8 naturally ) + shift->SUPER::DESTROY(); + } + + 1; + +EOD + +} +else { + # otherwise just unset the default + __PACKAGE__->schema_sanity_checker(''); +} + + if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { - __PACKAGE__->exception_action( sub { + my $ea = __PACKAGE__->exception_action( sub { + + # Can not rely on $^S here at all - the exception_action + # itself is always called in an eval so that the goto-guard + # can work (see 7cb35852) - my ( $fr_num, $disarmed, $throw_exception_fr_num ); + my ( $fr_num, $disarmed, $throw_exception_fr_num, $eval_fr_num ); while( ! $disarmed and my @fr = caller(++$fr_num) ) { $throw_exception_fr_num ||= ( - $fr[3] eq 'DBIx::Class::ResultSource::throw_exception' + $fr[3] =~ /^DBIx::Class::(?:ResultSource|Schema|Storage|Exception)::throw(?:_exception)?$/ + and + # there may be evals in the throwers themselves - skip those + ( $eval_fr_num ) = ( undef ) + and + $fr_num + ); + + # now that the above stops un-setting us, we can find the first + # ineresting eval + $eval_fr_num ||= ( + $fr[3] eq '(eval)' and $fr_num ); @@ -52,10 +115,41 @@ if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { '', ' You almost certainly used eval/try instead of dbic_internal_try()', " Adjust *one* of the eval-ish constructs in the callstack starting" . DBICTest::Util::stacktrace($throw_exception_fr_num||()) - ) unless $disarmed; + ) if ( + ! $disarmed + and + ( + $eval_fr_num + or + ! $throw_exception_fr_num + ) + ); DBIx::Class::Exception->throw( $_[0] ); - }) + }); + + my $interesting_ns_rx = qr/^ (?: main$ | DBIx::Class:: | DBICTest:: ) /x; + + # hard-set $SIG{__DIE__} to the class-wide exception_action + # with a little escape preceeding it + $SIG{__DIE__} = sub { + + # without this there would be false positives everywhere :( + die @_ if ( + # blindly rethrow if nobody is waiting for us + ( defined $^S and ! $^S ) + or + (caller(0))[0] !~ $interesting_ns_rx + or + ( + caller(0) eq 'main' + and + ( (caller(1))[0] || '' ) !~ $interesting_ns_rx + ) + ); + + &$ea; + }; } sub capture_executed_sql_bind { @@ -170,7 +264,19 @@ END { } } -my $weak_registry = {}; +my ( $weak_registry, $assertion_arounds ) = ( {}, {} ); + +sub DBICTest::__RsrcRedefiner_iThreads_handler__::CLONE { + if( DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE ) { + %$assertion_arounds = map { + (defined $_) + ? ( refaddr($_) => $_ ) + : () + } values %$assertion_arounds; + + weaken($_) for values %$assertion_arounds; + } +} sub connection { my $self = shift->next::method(@_); @@ -204,7 +310,7 @@ sub connection { and ref($_[0]) ne 'CODE' and - ($_[0]||'') !~ /^ (?i:dbi) \: SQLite \: (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x + ($_[0]||'') !~ /^ (?i:dbi) \: SQLite (?: \: | \W ) .*? (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x ) { my $locktype; @@ -216,12 +322,18 @@ sub connection { # we need to work with a forced fresh clone so that we do not upset any state # of the main $schema (some tests examine it quite closely) local $SIG{__WARN__} = sub {}; + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; # this will either give us an undef $locktype or will determine things # properly with a default ( possibly connecting in the process ) eval { - my $s = ref($self)->connect(@{$self->storage->connect_info})->storage; + my $cur_storage = $self->storage; + + $cur_storage = $cur_storage->master + if $cur_storage->isa('DBIx::Class::Storage::DBI::Replicated'); + + my $s = ref($self)->connect(@{$cur_storage->connect_info})->storage; $locktype = $s->sqlt_type || 'generic'; @@ -243,7 +355,7 @@ sub connection { undef $locker; - my $lockpath = DBICTest::RunMode->tmpdir->file("_dbictest_$locktype.lock"); + my $lockpath = tmpdir . "_dbictest_$locktype.lock"; DEBUG_TEST_CONCURRENCY_LOCKS and dbg "Waiting for $locktype LOCK: $lockpath..."; @@ -273,7 +385,7 @@ sub connection { for (1..50) { kill (0, $old_pid) or last; - sleep 0.1; + select( undef, undef, undef, 0.1 ); } DEBUG_TEST_CONCURRENCY_LOCKS @@ -311,6 +423,169 @@ sub connection { ]); } + # + # Check an explicit level of indirection: makes sure that folks doing + # use `base "DBIx::Class::Core"; __PACKAGE__->add_column("foo")` + # will see the correct error message + # + # In the future this all is likely to be folded into a single method in + # some way, but that's a fight for another maint + # + if( DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE ) { + + for my $class_of_interest ( + 'DBIx::Class::Row', + map { $self->class($_) } ($self->sources) + ) { + + my $orig_rsrc = $class_of_interest->can('result_source') + or die "How did we get here?!"; + + unless ( $assertion_arounds->{refaddr $orig_rsrc} ) { + + my ($origin) = get_subname($orig_rsrc); + + no warnings 'redefine'; + no strict 'refs'; + + *{"${origin}::result_source"} = my $replacement = set_subname "${origin}::result_source" => sub { + + + @_ > 1 + and + (CORE::caller(0))[1] !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x + and + emit_loud_diag( + msg => 'Incorrect indirect call of result_source() as setter must be changed to result_source_instance()', + confess => 1, + ); + + + grep { + ! (CORE::caller($_))[7] + and + ( (CORE::caller($_))[3] || '' ) eq '(eval)' + and + ( (CORE::caller($_))[1] || '' ) !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x + } (0..2) + and + # these evals are legit + ( (CORE::caller(4))[3] || '' ) !~ /^ (?: + DBIx::Class::Schema::_ns_get_rsrc_instance + | + DBIx::Class::Relationship::BelongsTo::belongs_to + | + DBIx::Class::Relationship::HasOne::_has_one + | + Class::C3::Componentised::.+ + ) $/x + and + emit_loud_diag( + # not much else we can do (aside from exit(1) which is too obnoxious) + msg => 'Incorrect call of result_source() in an eval', + emit_dups => 1, + ); + + + &$orig_rsrc; + }; + + weaken( $assertion_arounds->{refaddr $replacement} = $replacement ); + + attributes->import( + $origin, + $replacement, + attributes::get($orig_rsrc) + ); + } + + + # no rsrc_instance to mangle + next if $class_of_interest eq 'DBIx::Class::Row'; + + + my $orig_rsrc_instance = $class_of_interest->can('result_source_instance') + or die "How did we get here?!"; + + # Do the around() per definition-site as result_source_instance is a CAG inherited cref + unless ( $assertion_arounds->{refaddr $orig_rsrc_instance} ) { + + my ($origin) = get_subname($orig_rsrc_instance); + + no warnings 'redefine'; + no strict 'refs'; + + *{"${origin}::result_source_instance"} = my $replacement = set_subname "${origin}::result_source_instance" => sub { + + + @_ == 1 + and + # special cased as we do not care whether there is a source + ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Schema::_register_source' + and + # special case because I am paranoid + ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Row::throw_exception' + and + ( (CORE::caller(1))[3] || '' ) !~ / ^ DBIx::Class:: (?: + Row::result_source + | + Row::throw_exception + | + ResultSourceProxy::Table:: (?: _init_result_source_instance | table ) + | + ResultSourceHandle::STORABLE_thaw + ) $ /x + and + (CORE::caller(0))[1] !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x + and + emit_loud_diag( + msg => 'Incorrect direct call of result_source_instance() as getter must be changed to result_source()', + confess => 1 + ); + + + grep { + ! (CORE::caller($_))[7] + and + ( (CORE::caller($_))[3] || '' ) eq '(eval)' + and + ( (CORE::caller($_))[1] || '' ) !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x + } (0..2) + and + # special cased as we do not care whether there is a source + ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Schema::_register_source' + and + # special case because I am paranoid + ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Row::throw_exception' + and + # special case for Storable, which in turn calls from an eval + ( (CORE::caller(1))[3] || '' ) ne 'DBIx::Class::ResultSourceHandle::STORABLE_thaw' + and + emit_loud_diag( + # not much else we can do (aside from exit(1) which is too obnoxious) + msg => 'Incorrect call of result_source_instance() in an eval', + skip_frames => 1, + emit_dups => 1, + ); + + &$orig_rsrc_instance; + }; + + weaken( $assertion_arounds->{refaddr $replacement} = $replacement ); + + attributes->import( + $origin, + $replacement, + attributes::get($orig_rsrc_instance) + ); + } + } + + Class::C3::initialize if DBIx::Class::_ENV_::OLD_MRO; + } + # + # END Check an explicit level of indirection + return $self; } diff --git a/t/lib/DBICTest/DeployComponent.pm b/t/lib/DBICTest/DeployComponent.pm index 590fc25ab..99fbbd743 100644 --- a/t/lib/DBICTest/DeployComponent.pm +++ b/t/lib/DBICTest/DeployComponent.pm @@ -1,9 +1,14 @@ # belongs to t/86sqlt.t package # hide from PAUSE DBICTest::DeployComponent; + use warnings; use strict; +# Part of a test, important to remain as-is +# see also DBICTest::Schema::Track +use base 'DBIx::Class::Core'; + our $hook_cb; sub sqlt_deploy_hook { diff --git a/t/lib/DBICTest/RunMode.pm b/t/lib/DBICTest/RunMode.pm index 93f917c5b..82da4df23 100644 --- a/t/lib/DBICTest/RunMode.pm +++ b/t/lib/DBICTest/RunMode.pm @@ -4,242 +4,12 @@ package # hide from PAUSE use strict; use warnings; -BEGIN { - if ($INC{'DBIx/Class.pm'}) { - my ($fr, @frame) = 1; - while (@frame = caller($fr++)) { - last if $frame[1] !~ m|^t/lib/DBICTest|; - } - - die __PACKAGE__ . " must be loaded before DBIx::Class (or modules using DBIx::Class) at $frame[1] line $frame[2]\n"; - } - - if ( $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY} ) { - my $ov = UNIVERSAL->can("VERSION"); - - require Carp; - - no warnings 'redefine'; - *UNIVERSAL::VERSION = sub { - Carp::carp( 'Argument "blah bleh bloh" isn\'t numeric in subroutine entry' ); - &$ov; - }; - } - - if ( - $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} - or - # keep it always on during CI - ( - ($ENV{TRAVIS}||'') eq 'true' - and - ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/dbix-class$| - ) - ) { - require Try::Tiny; - my $orig = \&Try::Tiny::try; - - no warnings 'redefine'; - *Try::Tiny::try = sub (&;@) { - my ($fr, $first_pkg) = 0; - while( $first_pkg = caller($fr++) ) { - last if $first_pkg !~ /^ - __ANON__ - | - \Q(eval)\E - $/x; - } - - if ($first_pkg =~ /DBIx::Class/) { - require Test::Builder; - Test::Builder->new->ok(0, - 'Using try{} within DBIC internals is a mistake - use dbic_internal_try{} instead' - ); - } - - goto $orig; - }; - } -} - -use Path::Class qw/file dir/; -use Fcntl ':DEFAULT'; -use File::Spec (); -use File::Temp (); -use DBICTest::Util 'local_umask'; - -_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 { - - # works but not always - my $dir = dir(File::Spec->tmpdir); - my $reason_dir_unusable; - - my @parts = File::Spec->splitdir($dir); - if (@parts == 2 and $parts[1] =~ /^ [\/\\]? $/x ) { - $reason_dir_unusable = - 'File::Spec->tmpdir returned a root directory instead of a designated ' - . 'tempdir (possibly https://rt.cpan.org/Ticket/Display.html?id=76663)'; - } - else { - # make sure we can actually create and sysopen a file in this dir - local $@; - my $u = local_umask(0); # match the umask we use in DBICTest(::Schema) - my $tempfile = ''; - eval { - $tempfile = File::Temp->new( - TEMPLATE => '_dbictest_writability_test_XXXXXX', - DIR => "$dir", - UNLINK => 1, - ); - close $tempfile or die "closing $tempfile failed: $!\n"; - - sysopen (my $tempfh2, "$tempfile", O_RDWR) or die "reopening $tempfile failed: $!\n"; - print $tempfh2 'deadbeef' x 1024 or die "printing to $tempfile failed: $!\n"; - close $tempfh2 or die "closing $tempfile failed: $!\n"; - 1; - } or do { - chomp( my $err = $@ ); - my @x_tests = map { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' } map {(-e, -d, -f, -r, -w, -x, -o)} ("$dir", "$tempfile"); - $reason_dir_unusable = sprintf <<"EOE", "$tempfile"||'', $err, scalar $>, scalar $), umask(), (stat($dir))[4,5,2], @x_tests; -File::Spec->tmpdir returned a directory which appears to be non-writeable: -Error encountered while testing '%s': %s -Process EUID/EGID: %s / %s -Effective umask: %o -TmpDir UID/GID: %s / %s -TmpDir StatMode: %o -TmpDir X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s -TmpFile X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s -EOE - }; - } - - if ($reason_dir_unusable) { - # 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 or failing outright - my $local_dir = _find_co_root()->subdir('t')->subdir('var'); - $local_dir->mkpath; - - warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n"; - $dir = $local_dir; - } - - $dir->stringify; - }); -} - - -# Die if the author did not update his makefile -# -# This is pretty heavy handed, so the check is pretty solid: -# -# 1) Assume that this particular module is loaded from -I <$root>/t/lib -# 2) Make sure <$root>/Makefile.PL exists -# 3) Make sure we can stat() <$root>/Makefile.PL -# -# If all of the above is satisfied -# -# *) die if <$root>/inc does not exist -# *) die if no stat() results for <$root>/Makefile (covers no Makefile) -# *) die if Makefile.PL mtime > Makefile mtime -# -sub _check_author_makefile { - - my $root = _find_co_root() - or return; - - my $optdeps = file('lib/DBIx/Class/Optional/Dependencies.pm'); - - # not using file->stat as it invokes File::stat which in turn breaks stat(_) - my ($mf_pl_mtime, $mf_mtime, $optdeps_mtime) = ( map - { (stat ($root->file ($_)) )[9] || undef } # stat returns () on nonexistent files - (qw|Makefile.PL Makefile|, $optdeps) - ); - - return unless $mf_pl_mtime; # something went wrong during co_root detection ? - - my @fail_reasons; - - if(not -d $root->subdir ('inc')) { - push @fail_reasons, "Missing ./inc directory"; - } - - if(not $mf_mtime) { - push @fail_reasons, "Missing ./Makefile"; - } - else { - if($mf_mtime < $mf_pl_mtime) { - push @fail_reasons, "./Makefile.PL is newer than ./Makefile"; - } - if($mf_mtime < $optdeps_mtime) { - push @fail_reasons, "./$optdeps is newer than ./Makefile"; - } - } - - if (@fail_reasons) { - print STDERR <<'EOE'; - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -======================== FATAL ERROR =========================== -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -We have a number of reasons to believe that this is a development -checkout and that you, the user, did not run `perl Makefile.PL` -before using this code. You absolutely _must_ perform this step, -to ensure you have all required dependencies present. Not doing -so often results in a lot of wasted time for other contributors -trying to assist you with spurious "its broken!" problems. - -By default DBICs Makefile.PL turns all optional dependencies into -*HARD REQUIREMENTS*, in order to make sure that the entire test -suite is executed, and no tests are skipped due to missing modules. -If you for some reason need to disable this behavior - supply the ---skip_author_deps option when running perl Makefile.PL - -If you are seeing this message unexpectedly (i.e. you are in fact -attempting a regular installation be it through CPAN or manually), -please report the situation to either the mailing list or to the -irc channel as described in - -http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT - -The DBIC team - - -Reasons you received this message: - -EOE - - foreach my $r (@fail_reasons) { - print STDERR " * $r\n"; - } - print STDERR "\n\n\n"; - - require Time::HiRes; - Time::HiRes::sleep(0.005); - print STDOUT "\nBail out!\n"; - exit 1; - } -} - # Mimic $Module::Install::AUTHOR sub is_author { - - my $root = _find_co_root() - or return undef; - return ( - ( not -d $root->subdir ('inc') ) + ! -d 'inc/Module' or - ( -e $root->subdir ('inc')->subdir ($^O eq 'VMS' ? '_author' : '.author') ) + -e 'inc/.author' ); } @@ -271,28 +41,4 @@ sub is_plain { ) } -# Try to determine the root of a checkout/untar if possible -# or return undef -sub _find_co_root { - - my @mod_parts = split /::/, (__PACKAGE__ . '.pm'); - my $rel_path = join ('/', @mod_parts); # %INC stores paths with / regardless of OS - - return undef unless ($INC{$rel_path}); - - # a bit convoluted, but what we do here essentially is: - # - get the file name of this particular module - # - do 'cd ..' as many times as necessary to get to t/lib/../.. - - my $root = dir ($INC{$rel_path}); - for (1 .. @mod_parts + 2) { - $root = $root->parent; - } - - return (-f $root->file ('Makefile.PL') ) - ? $root - : undef - ; -} - 1; diff --git a/t/lib/DBICTest/Schema.pm b/t/lib/DBICTest/Schema.pm index 2e783a759..1b436f633 100644 --- a/t/lib/DBICTest/Schema.pm +++ b/t/lib/DBICTest/Schema.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema; +# load early so that `perl -It/lib -MDBICTest::Schema` keeps working +use ANFANG; + use strict; use warnings; no warnings 'qw'; diff --git a/t/lib/DBICTest/Schema/Artist.pm b/t/lib/DBICTest/Schema/Artist.pm index 00c1ef670..808e05a2c 100644 --- a/t/lib/DBICTest/Schema/Artist.pm +++ b/t/lib/DBICTest/Schema/Artist.pm @@ -5,6 +5,8 @@ use warnings; use strict; use base 'DBICTest::BaseResult'; +use mro 'c3'; + use DBICTest::Util 'check_customcond_args'; __PACKAGE__->table('artist'); diff --git a/t/lib/DBICTest/Schema/ArtistSourceName.pm b/t/lib/DBICTest/Schema/ArtistSourceName.pm index 3e6a7e657..cf1b5de6d 100644 --- a/t/lib/DBICTest/Schema/ArtistSourceName.pm +++ b/t/lib/DBICTest/Schema/ArtistSourceName.pm @@ -5,6 +5,8 @@ use warnings; use strict; use base 'DBICTest::Schema::Artist'; +use mro 'c3'; + __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 e1b97fa40..31062b5e9 100644 --- a/t/lib/DBICTest/Schema/ArtistSubclass.pm +++ b/t/lib/DBICTest/Schema/ArtistSubclass.pm @@ -5,6 +5,7 @@ use warnings; use strict; use base 'DBICTest::Schema::Artist'; +use mro 'c3'; __PACKAGE__->table(__PACKAGE__->table); diff --git a/t/lib/DBICTest/Schema/BooksInLibrary.pm b/t/lib/DBICTest/Schema/BooksInLibrary.pm index cd6f37531..c69ea5ddf 100644 --- a/t/lib/DBICTest/Schema/BooksInLibrary.pm +++ b/t/lib/DBICTest/Schema/BooksInLibrary.pm @@ -9,8 +9,11 @@ use base qw/DBICTest::BaseResult/; __PACKAGE__->table('books'); __PACKAGE__->add_columns( 'id' => { + # part of a test (auto-retrieval of PK regardless of autoinc status) + # DO NOT define + #is_auto_increment => 1, + data_type => 'integer', - is_auto_increment => 1, }, 'source' => { data_type => 'varchar', diff --git a/t/lib/DBICTest/Schema/CustomSql.pm b/t/lib/DBICTest/Schema/CustomSql.pm index d22b3febf..d179464a4 100644 --- a/t/lib/DBICTest/Schema/CustomSql.pm +++ b/t/lib/DBICTest/Schema/CustomSql.pm @@ -5,6 +5,7 @@ use warnings; use strict; use base qw/DBICTest::Schema::Artist/; +use mro 'c3'; __PACKAGE__->table('dummy'); diff --git a/t/lib/DBICTest/Schema/EventTZ.pm b/t/lib/DBICTest/Schema/EventTZ.pm index 4c6c48a2e..d63586845 100644 --- a/t/lib/DBICTest/Schema/EventTZ.pm +++ b/t/lib/DBICTest/Schema/EventTZ.pm @@ -11,7 +11,9 @@ __PACKAGE__->table('event'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, - starts_at => { data_type => 'datetime', timezone => "America/Chicago", locale => 'de_DE', datetime_undef_if_invalid => 1 }, + starts_at => { data_type => 'datetime', time_zone => "America/Chicago", locale => 'de_DE', datetime_undef_if_invalid => 1 }, + + # DO NOT change 'timezone' - there to test the legacy syntax created_on => { data_type => 'timestamp', timezone => "America/Chicago", floating_tz_ok => 1 }, ); diff --git a/t/lib/DBICTest/Schema/EventTZDeprecated.pm b/t/lib/DBICTest/Schema/EventTZDeprecated.pm index c66cd0707..70ac7c7c3 100644 --- a/t/lib/DBICTest/Schema/EventTZDeprecated.pm +++ b/t/lib/DBICTest/Schema/EventTZDeprecated.pm @@ -11,7 +11,9 @@ __PACKAGE__->table('event'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, - starts_at => { data_type => 'datetime', extra => { timezone => "America/Chicago", locale => 'de_DE' } }, + starts_at => { data_type => 'datetime', extra => { time_zone => "America/Chicago", locale => 'de_DE' } }, + + # DO NOT change 'timezone' - there to test the legacy syntax created_on => { data_type => 'timestamp', extra => { timezone => "America/Chicago", floating_tz_ok => 1 } }, ); diff --git a/t/lib/DBICTest/Schema/EventTZPg.pm b/t/lib/DBICTest/Schema/EventTZPg.pm index 1f191afb0..07a2d1f9a 100644 --- a/t/lib/DBICTest/Schema/EventTZPg.pm +++ b/t/lib/DBICTest/Schema/EventTZPg.pm @@ -11,8 +11,8 @@ __PACKAGE__->table('event'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, - starts_at => { data_type => 'datetime', timezone => "America/Chicago", locale => 'de_DE' }, - created_on => { data_type => 'timestamp with time zone', timezone => "America/Chicago" }, + starts_at => { data_type => 'datetime', time_zone => "America/Chicago", locale => 'de_DE' }, + created_on => { data_type => 'timestamp with time zone', time_zone => "America/Chicago" }, ts_without_tz => { data_type => 'timestamp without time zone' }, ); diff --git a/t/lib/DBICTest/Schema/SelfRef.pm b/t/lib/DBICTest/Schema/SelfRef.pm index 41ae6d91b..8bcd24312 100644 --- a/t/lib/DBICTest/Schema/SelfRef.pm +++ b/t/lib/DBICTest/Schema/SelfRef.pm @@ -20,5 +20,6 @@ __PACKAGE__->add_columns( __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many( aliases => 'DBICTest::Schema::SelfRefAlias' => 'self_ref' ); +__PACKAGE__->has_many( aliases_no_copy => 'DBICTest::Schema::SelfRefAlias' => 'self_ref', { cascade_copy => 0 } ); 1; diff --git a/t/lib/DBICTest/Schema/TimestampPrimaryKey.pm b/t/lib/DBICTest/Schema/TimestampPrimaryKey.pm index 8ec4cf981..a52f0db07 100644 --- a/t/lib/DBICTest/Schema/TimestampPrimaryKey.pm +++ b/t/lib/DBICTest/Schema/TimestampPrimaryKey.pm @@ -12,6 +12,7 @@ __PACKAGE__->add_columns( 'id' => { data_type => 'timestamp', default_value => \'current_timestamp', + retrieve_on_insert => 1, }, ); diff --git a/t/lib/DBICTest/Schema/Track.pm b/t/lib/DBICTest/Schema/Track.pm index 10d49f7b4..2787a7e9c 100644 --- a/t/lib/DBICTest/Schema/Track.pm +++ b/t/lib/DBICTest/Schema/Track.pm @@ -7,6 +7,8 @@ use strict; use base 'DBICTest::BaseResult'; use DBICTest::Util 'check_customcond_args'; +# The component order is Part of a test, +# important to remain as-is __PACKAGE__->load_components(qw{ +DBICTest::DeployComponent InflateColumn::DateTime @@ -42,7 +44,10 @@ __PACKAGE__->add_columns( ); __PACKAGE__->set_primary_key('trackid'); -__PACKAGE__->add_unique_constraint([ qw/cd position/ ]); +__PACKAGE__->add_unique_constraint({ + columns => [ qw/cd position/ ], + sqlt_extra => { deferrable => 1 } +}); __PACKAGE__->add_unique_constraint([ qw/cd title/ ]); __PACKAGE__->position_column ('position'); diff --git a/t/lib/DBICTest/Schema/Year2000CDs.pm b/t/lib/DBICTest/Schema/Year2000CDs.pm index 6ee67d58d..1cf1b3736 100644 --- a/t/lib/DBICTest/Schema/Year2000CDs.pm +++ b/t/lib/DBICTest/Schema/Year2000CDs.pm @@ -6,6 +6,11 @@ use strict; use base qw/DBICTest::Schema::CD/; +# FIXME not entirely sure *why* this particular bit trips up tests +# and even more mysteriously: only a single oracle test... +# Running out of time and no local Oracle so can't investigate :/ +use mro 'c3'; + __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year2000cds'); diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index f747210c0..e268b3b21 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -3,37 +3,45 @@ package DBICTest::Util; use warnings; use strict; -# this noop trick initializes the STDOUT, so that the TAP::Harness -# issued IO::Select->can_read calls (which are blocking wtf wtf wtf) -# keep spinning and scheduling jobs -# This results in an overall much smoother job-queue drainage, since -# the Harness blocks less -# (ideally this needs to be addressed in T::H, but a quick patchjob -# broke everything so tabling it for now) -BEGIN { - if ($INC{'Test/Builder.pm'}) { - local $| = 1; - print "#\n"; - } -} - -use constant DEBUG_TEST_CONCURRENCY_LOCKS => - ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0] - || - 0 -; +use ANFANG; use Config; use Carp qw(cluck confess croak); -use Fcntl ':flock'; -use Scalar::Util qw(blessed refaddr); -use DBIx::Class::_Util 'scope_guard'; +use Fcntl qw( :DEFAULT :flock ); +use Scalar::Util qw( blessed refaddr openhandle ); +use DBIx::Class::_Util qw( scope_guard parent_dir ); + +use constant { + + DEBUG_TEST_CONCURRENCY_LOCKS => ( + ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0] + || + 0 + ), + + # During 5.13 dev cycle HELEMs started to leak on copy + # add an escape for these perls ON SMOKERS - a user/CI will still get death + # constname a homage to http://theoatmeal.com/comics/working_home + PEEPEENESS => ( + ( + DBIx::Class::_ENV_::PERL_VERSION >= 5.013005 + and + DBIx::Class::_ENV_::PERL_VERSION <= 5.013006 + ) + and + require DBICTest::RunMode + and + DBICTest::RunMode->is_smoker + and + ! DBICTest::RunMode->is_ci + ), +}; use base 'Exporter'; our @EXPORT_OK = qw( - dbg stacktrace - local_umask - visit_namespaces + dbg stacktrace class_seems_loaded + local_umask slurp_bytes tmpdir find_co_root rm_rf + capture_stderr PEEPEENESS check_customcond_args await_flock DEBUG_TEST_CONCURRENCY_LOCKS ); @@ -68,7 +76,7 @@ sub dbg ($) { # This figure esentially means "how long can a single test hold a # resource before everyone else gives up waiting and aborts" or # in other words "how long does the longest test-group legitimally run?" -my $lock_timeout_minutes = 15; # yes, that's long, I know +my $lock_timeout_minutes = 30; # yes, that's long, I know my $wait_step_seconds = 0.25; sub await_flock ($$) { @@ -84,9 +92,25 @@ sub await_flock ($$) { # "say something" every 10 cycles to work around RT#108390 # jesus christ our tooling is such a crock of shit :( - print "#\n" if not $tries % 10; + unless ( $tries % 10 ) { + + # Turning on autoflush is crucial: if stars align just right buffering + # will ensure we never actually call write() underneath until the grand + # timeout is reached (and that's too long). Reproducible via + # + # DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1 \ + # DBICTEST_RUN_ALL_TESTS=1 \ + # strace -f \ + # prove -lj10 xt/extra/internals/ + # + select( ( select(\*STDOUT), $|=1 )[0] ); + print STDOUT "#\n"; + } } + print STDERR "Lock timeout of $lock_timeout_minutes minutes reached: " + unless $res; + return $res; } @@ -98,10 +122,10 @@ sub local_umask ($) { if ! defined wantarray; my $old_umask = umask($_[0]); - die "Setting umask failed: $!" unless defined $old_umask; + croak "Setting umask failed: $!" unless defined $old_umask; scope_guard(sub { - local ($@, $!, $?); + local ( $!, $^E, $?, $@ ); eval { defined(umask $old_umask) or die "nope"; @@ -112,6 +136,254 @@ sub local_umask ($) { }); } +# Try to determine the root of a checkout/untar if possible +# OR throws an exception +my $co_root; +sub find_co_root () { + + $co_root ||= do { + + my @mod_parts = split /::/, (__PACKAGE__ . '.pm'); + my $inc_key = join ('/', @mod_parts); # %INC stores paths with / regardless of OS + + # a bit convoluted, but what we do here essentially is: + # - get the file name of this particular module + # - do 'cd ..' as many times as necessary to get to t/lib/../.. + + my $root = $INC{$inc_key} + or croak "\$INC{'$inc_key'} seems to be missing, this can't happen..."; + + $root = parent_dir $root + for 1 .. @mod_parts + 2; + + # do the check twice so that the exception is more informative in the + # very unlikely case of realpath returning garbage + # (Paththools are in really bad shape - handholding all the way down) + for my $call_realpath (0,1) { + + require Cwd and $root = ( Cwd::realpath($root) . '/' ) + if $call_realpath; + + croak "Unable to find root of DBIC checkout/untar: '${root}Makefile.PL' does not exist" + unless -f "${root}Makefile.PL"; + } + + # at this point we are pretty sure this is the right thing - detaint + ($root =~ /(.+)/)[0]; + } +} + +my $tempdir; +sub tmpdir () { + $tempdir ||= do { + + require File::Spec; + my $dir = File::Spec->tmpdir; + $dir .= '/' unless $dir =~ / [\/\\] $ /x; + + # the above works but not always, test it to bits + my $reason_dir_unusable; + + # 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 @parts = File::Spec->splitdir($dir); + + # deal with how 'C:\\\\\\\\\\\\\\' decomposes + pop @parts while @parts and ! length $parts[-1]; + + if ( + @parts < 2 + or + ( @parts == 2 and $parts[1] =~ /^ [\/\\] $/x ) + ) { + $reason_dir_unusable = + 'File::Spec->tmpdir returned a root directory instead of a designated ' + . 'tempdir (possibly https://rt.cpan.org/Ticket/Display.html?id=76663)'; + } + else { + # make sure we can actually create and sysopen a file in this dir + + my $fn = $dir . "_dbictest_writability_test_$$"; + + my $u = local_umask(0); # match the umask we use in DBICTest(::Schema) + my $g = scope_guard { unlink $fn }; + + eval { + + if (-e $fn) { + unlink $fn or die "Unable to unlink pre-existing $fn: $!\n"; + } + + sysopen (my $tmpfh, $fn, O_RDWR|O_CREAT) or die "Opening $fn failed: $!\n"; + + print $tmpfh 'deadbeef' x 1024 or die "Writing to $fn failed: $!\n"; + + close $tmpfh or die "Closing $fn failed: $!\n"; + + 1; + } + or + do { + chomp( my $err = $@ ); + + my @x_tests = map + { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' } + map + { (-e, -d, -f, -r, -w, -x, -o)} + ($dir, $fn) + ; + + $reason_dir_unusable = sprintf <<"EOE", $fn, $err, scalar $>, scalar $), umask(), (stat($dir))[4,5,2], @x_tests; +File::Spec->tmpdir returned a directory which appears to be non-writeable: + +Error encountered while testing '%s': %s +Process EUID/EGID: %s / %s +Effective umask: %o +TmpDir UID/GID: %s / %s +TmpDir StatMode: %o +TmpDir X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s +TmpFile X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s +EOE + }; + } + + if ($reason_dir_unusable) { + # Replace with our local project tmpdir. This will make multiple tests + # from different runs conflict with each other, but is much better than + # polluting the root dir with random crap or failing outright + my $local_dir = find_co_root . 't/var/'; + + # Generlly this should be handled by ANFANG, but double-check ourselves + # Not using mkdir_p here: we *know* everything else up until 'var' exists + # If it doesn't - we better fail outright + # (also saves an extra File::Path require(), small enough as it is) + -d $local_dir + or + mkdir $local_dir + or + die "Unable to create build-local tempdir '$local_dir': $!\n"; + + warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n\n"; + $dir = $local_dir; + } + + $dir; + }; +} + +sub capture_stderr (&) { + open(my $stderr_copy, '>&', *STDERR) or croak "Unable to dup STDERR: $!"; + + require File::Temp; + my $tf = File::Temp->new( UNLINK => 1, DIR => tmpdir() ); + + my $err_out; + + { + my $guard = scope_guard { + close STDERR; + + open(STDERR, '>&', $stderr_copy) or do { + my $msg = "\n\nPANIC!!!\nFailed restore of STDERR: $!\n"; + print $stderr_copy $msg; + print STDOUT $msg; + die; + }; + + close $stderr_copy; + }; + + close STDERR; + open( STDERR, '>&', $tf ); + + $_[0]->(); + } + + slurp_bytes( "$tf" ); +} + +sub slurp_bytes ($) { + croak "Expecting a file name, not a filehandle" if openhandle $_[0]; + croak "'$_[0]' is not a readable filename" unless -f $_[0] && -r $_[0]; + open my $fh, '<:raw', $_[0] or croak "Unable to open '$_[0]': $!"; + local $/ unless wantarray; + <$fh>; +} + + +sub rm_rf ($) { + croak "No argument supplied to rm_rf()" unless length "$_[0]"; + + return unless -e $_[0]; + +### I do not trust myself - check for subsuming ( the right way ) +### Avoid things like https://rt.cpan.org/Ticket/Display.html?id=111637 + require Cwd; + + my ($target, $tmp, $co_tmp) = map { + + my $abs_fn = Cwd::abs_path("$_"); + + if ( $^O eq 'MSWin32' and length $abs_fn ) { + + # sometimes we can get a short/longname mix, normalize everything to longnames + $abs_fn = Win32::GetLongPathName($abs_fn); + + # Fixup for unixy (as opposed to native) slashes + $abs_fn =~ s|\\|/|g; + } + + $abs_fn =~ s| (?is_smoker +# Not added to EXPORT_OK on purpose +sub can_alloc_MB ($) { + my $arg = shift; + $arg = 'UNDEF' if not defined $arg; + + croak "Expecting a positive integer, got '$arg'" + if $arg !~ /^[1-9][0-9]*$/; + + my ($perl) = $^X =~ /(.+)/; + local $ENV{PATH}; + local $ENV{PERL5LIB} = join ($Config{path_sep}, @INC); + + local ( $!, $^E, $?, $@ ); + + system( $perl, qw( -It/lib -MANFANG -e ), <<'EOS', $arg ); +$0 = 'malloc_canary'; +my $tail_character_of_reified_megastring = substr( ( join '', map chr, 0..255 ) x (4 * 1024 * $ARGV[0]), -1 ); +EOS + + !!( $? == 0 ) +} + sub stacktrace { my $frame = shift; $frame++; @@ -173,34 +445,27 @@ sub check_customcond_args ($) { $args; } -sub visit_namespaces { - my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; - - my $visited_count = 1; - - # A package and a namespace are subtly different things - $args->{package} ||= 'main'; - $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x; - $args->{package} =~ s/^:://; - - if ( $args->{action}->($args->{package}) ) { - my $ns = - ( ($args->{package} eq 'main') ? '' : $args->{package} ) - . - '::' - ; - - $visited_count += visit_namespaces( %$args, package => $_ ) for - grep - # this happens sometimes on %:: traversal - { $_ ne '::main' } - map - { $_ =~ /^(.+?)::$/ ? "$ns$1" : () } - do { no strict 'refs'; keys %$ns } - ; - } +# +# Replicate the *heuristic* (important!!!) implementation found in various +# forms within Class::Load / Module::Inspector / Class::C3::Componentised +# +sub class_seems_loaded ($) { + + croak "Function expects a class name as plain string (no references)" + unless defined $_[0] and not length ref $_[0]; + + no strict 'refs'; + + return 1 if defined ${"$_[0]::VERSION"}; + + return 1 if @{"$_[0]::ISA"}; + + return 1 if $INC{ (join ('/', split ('::', $_[0]) ) ) . '.pm' }; + + ( !!*{"$_[0]::$_"}{CODE} ) and return 1 + for keys %{"$_[0]::"}; - return $visited_count; + return 0; } 1; diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index b1de109e6..49621ebc0 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -3,14 +3,20 @@ package DBICTest::Util::LeakTracer; use warnings; use strict; +use ANFANG; use Carp; use Scalar::Util qw(isweak weaken blessed reftype); -use DBIx::Class::_Util qw(refcount hrefaddr refdesc); -use DBIx::Class::Optional::Dependencies; -use Data::Dumper::Concise; -use DBICTest::Util qw( stacktrace visit_namespaces ); +use DBIx::Class::_Util qw(refcount hrefaddr refdesc dump_value visit_namespaces); +use DBICTest::RunMode; +use DBICTest::Util 'stacktrace'; use constant { - CV_TRACING => !DBICTest::RunMode->is_plain && DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'), + CV_TRACING => !!( + !DBICTest::RunMode->is_plain + && + require DBIx::Class::Optional::Dependencies + && + DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy') + ), }; use base 'Exporter'; @@ -42,17 +48,23 @@ sub populate_weakregistry { for keys %$reg; } + return $target if ( + DBIx::Class::_ENV_::BROKEN_WEAK_SCALARREF_VALUES + and + ref $target eq 'SCALAR' + ); + if (! defined $weak_registry->{$refaddr}{weakref}) { + + # replace slot entirely $weak_registry->{$refaddr} = { stacktrace => stacktrace(1), weakref => $target, }; - # on perl < 5.8.3 sometimes a weaken can throw (can't find RT) - # so guard against that unlikely event - local $@; - eval { weaken( $weak_registry->{$refaddr}{weakref} ); $refs_traced++ } - or delete $weak_registry->{$refaddr}; + weaken( $weak_registry->{$refaddr}{weakref} ); + + $refs_traced++; } my $desc = refdesc $target; @@ -66,7 +78,7 @@ sub populate_weakregistry { } # Regenerate the slots names on a thread spawn -sub CLONE { +sub DBICTest::__LeakTracer_iThreads_handler__::CLONE { my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs; %reg_of_regs = (); @@ -127,6 +139,7 @@ sub visit_refs { my $type = reftype $r; + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; eval { if ($type eq 'HASH') { @@ -148,7 +161,16 @@ sub visit_refs { } values %{ scalar PadWalker::closed_over($r) } ] }); # scalar due to RT#92269 } 1; - } or warn "Could not descend into @{[ refdesc $r ]}: $@\n"; + } or ( + # this is some bizarre old DBI autosplit thing, no point mentioning it + $@ !~ m{ ^Can't \s locate \s (?: + auto/DBI/FIRSTKEY.al + | + \Qobject method "FIRSTKEY" via package "DBI"\E + )}x + and + warn "Could not descend into @{[ refdesc $r ]}: $@\n" + ); } $visited_cnt; } @@ -237,13 +259,13 @@ sub assert_empty_weakregistry { # the symtable walk is very expensive # if we are $quiet (running in an END block) we do not really need to be - # that thorough - can get by with only %Sub::Quote::QUOTED + # that thorough - can get by with our own registry delete $weak_registry->{$_} for $quiet ? do { my $refs = {}; visit_refs ( # only look at the closed over stuffs - refs => [ grep { length ref $_ } map { values %{$_->[2]} } grep { ref $_ eq 'ARRAY' } values %Sub::Quote::QUOTED ], + refs => [ values %DBIx::Class::_Util::refs_closed_over_by_quote_sub_installed_crefs ], seen_refs => $refs, action => sub { 1 }, ); @@ -271,7 +293,7 @@ sub assert_empty_weakregistry { ref($weak_registry->{$addr}{weakref}) eq 'CODE' and B::svref_2object($weak_registry->{$addr}{weakref})->XSUB - ) ? '__XSUB__' : Dumper( $weak_registry->{$addr}{weakref} ) + ) ? '__XSUB__' : dump_value $weak_registry->{$addr}{weakref} ; }; diff --git a/t/lib/DBICTest/WithTaint.pm b/t/lib/DBICTest/WithTaint.pm index abad25d79..b3cd66c1a 100644 --- a/t/lib/DBICTest/WithTaint.pm +++ b/t/lib/DBICTest/WithTaint.pm @@ -1,4 +1,3 @@ -# keep stricture tests happy -use strict; -use warnings; +package DBICTest::WithTaint; + 1; diff --git a/t/lib/testinclude/DBICTestAdminInc.pm b/t/lib/testinclude/DBICTestAdminInc.pm index 212d33dc6..710dab057 100644 --- a/t/lib/testinclude/DBICTestAdminInc.pm +++ b/t/lib/testinclude/DBICTestAdminInc.pm @@ -5,6 +5,6 @@ use strict; use base 'DBICTest::BaseSchema'; -sub connect { exit 70 } # this is what the test will expect to see +sub connection { exit 70 } # this is what the test will expect to see 1; diff --git a/t/lib/testinclude/DBICTestConfig.pm b/t/lib/testinclude/DBICTestConfig.pm index e531dc4be..e59982f40 100644 --- a/t/lib/testinclude/DBICTestConfig.pm +++ b/t/lib/testinclude/DBICTestConfig.pm @@ -5,7 +5,7 @@ use strict; use base 'DBICTest::BaseSchema'; -sub connect { +sub connection { my($self, @opt) = @_; @opt == 4 and $opt[0] eq 'klaatu' diff --git a/t/multi_create/cd_single.t b/t/multi_create/cd_single.t index 746eaab32..2549cb7e3 100644 --- a/t/multi_create/cd_single.t +++ b/t/multi_create/cd_single.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/multi_create/diamond.t b/t/multi_create/diamond.t index 499f7a13b..ce0efab42 100644 --- a/t/multi_create/diamond.t +++ b/t/multi_create/diamond.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; sub mc_diag { diag (@_) if $ENV{DBIC_MULTICREATE_DEBUG} }; diff --git a/t/multi_create/existing_in_chain.t b/t/multi_create/existing_in_chain.t index 292dd6b7c..e7a7d4732 100644 --- a/t/multi_create/existing_in_chain.t +++ b/t/multi_create/existing_in_chain.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/multi_create/find_or_multicreate.t b/t/multi_create/find_or_multicreate.t index 762b96275..6efc97448 100644 --- a/t/multi_create/find_or_multicreate.t +++ b/t/multi_create/find_or_multicreate.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema( no_populate => 1 ); diff --git a/t/multi_create/has_many.t b/t/multi_create/has_many.t index 2878ff77c..2e40d7b79 100644 --- a/t/multi_create/has_many.t +++ b/t/multi_create/has_many.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/multi_create/in_memory.t b/t/multi_create/in_memory.t index 9533af506..c96db6892 100644 --- a/t/multi_create/in_memory.t +++ b/t/multi_create/in_memory.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/multi_create/insert_defaults.t b/t/multi_create/insert_defaults.t index 3425b8ac5..d7839c113 100644 --- a/t/multi_create/insert_defaults.t +++ b/t/multi_create/insert_defaults.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; diff --git a/t/multi_create/m2m.t b/t/multi_create/m2m.t index 26934c9fe..879453f29 100644 --- a/t/multi_create/m2m.t +++ b/t/multi_create/m2m.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; plan tests => 4; diff --git a/t/multi_create/multilev_single_PKeqFK.t b/t/multi_create/multilev_single_PKeqFK.t index 9a5adbe92..301e80b6b 100644 --- a/t/multi_create/multilev_single_PKeqFK.t +++ b/t/multi_create/multilev_single_PKeqFK.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; sub mc_diag { diag (@_) if $ENV{DBIC_MULTICREATE_DEBUG} }; diff --git a/t/multi_create/standard.t b/t/multi_create/standard.t index 54cf04ee3..784a40962 100644 --- a/t/multi_create/standard.t +++ b/t/multi_create/standard.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/multi_create/torture.t b/t/multi_create/torture.t index 79338d7f6..269a0621d 100644 --- a/t/multi_create/torture.t +++ b/t/multi_create/torture.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; plan tests => 23; diff --git a/t/ordered/cascade_delete.t b/t/ordered/cascade_delete.t index b6633c70c..62463fa7f 100644 --- a/t/ordered/cascade_delete.t +++ b/t/ordered/cascade_delete.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/ordered/unordered_movement.t b/t/ordered/unordered_movement.t index dc083068a..1684b2f2b 100644 --- a/t/ordered/unordered_movement.t +++ b/t/ordered/unordered_movement.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/attrs_untouched.t b/t/prefetch/attrs_untouched.t index b2f25c38c..7b5034488 100644 --- a/t/prefetch/attrs_untouched.t +++ b/t/prefetch/attrs_untouched.t @@ -1,12 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; -use lib qw(t/lib); -use DBICTest; -use Data::Dumper; -$Data::Dumper::Sortkeys = 1; +use DBICTest; +use DBIx::Class::_Util 'dump_value'; my $schema = DBICTest->init_schema(); @@ -17,11 +17,11 @@ plan tests => 3; my $search = { 'artist.name' => 'Caterwauler McCrae' }; my $attr = { prefetch => [ qw/artist liner_notes/ ], order_by => 'me.cdid' }; -my $search_str = Dumper($search); -my $attr_str = Dumper($attr); +my $search_str = dump_value $search; +my $attr_str = dump_value $attr; my $rs = $schema->resultset("CD")->search($search, $attr); -is(Dumper($search), $search_str, 'Search hash untouched after search()'); -is(Dumper($attr), $attr_str, 'Attribute hash untouched after search()'); +is( dump_value $search, $search_str, 'Search hash untouched after search()'); +is( dump_value $attr, $attr_str, 'Attribute hash untouched after search()'); cmp_ok($rs + 0, '==', 3, 'Correct number of records returned'); diff --git a/t/prefetch/correlated.t b/t/prefetch/correlated.t index 5196620db..e941b12a9 100644 --- a/t/prefetch/correlated.t +++ b/t/prefetch/correlated.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Deep; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/count.t b/t/prefetch/count.t index f973575f1..8a32b4108 100644 --- a/t/prefetch/count.t +++ b/t/prefetch/count.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/diamond.t b/t/prefetch/diamond.t index f7a21e037..dc3e22c20 100644 --- a/t/prefetch/diamond.t +++ b/t/prefetch/diamond.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + # Test if prefetch and join in diamond relationship fetching the correct rows use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/double_prefetch.t b/t/prefetch/double_prefetch.t index fa0b79f51..2942d2395 100644 --- a/t/prefetch/double_prefetch.t +++ b/t/prefetch/double_prefetch.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/empty_cache.t b/t/prefetch/empty_cache.t index 9f42d5a11..c7cda22c4 100644 --- a/t/prefetch/empty_cache.t +++ b/t/prefetch/empty_cache.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/false_colvalues.t b/t/prefetch/false_colvalues.t index 468a27a85..a87de706a 100644 --- a/t/prefetch/false_colvalues.t +++ b/t/prefetch/false_colvalues.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; use Test::Deep; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema( no_populate => 1 ); diff --git a/t/prefetch/grouped.t b/t/prefetch/grouped.t index 0f6f59a29..c0d2224e9 100644 --- a/t/prefetch/grouped.t +++ b/t/prefetch/grouped.t @@ -1,9 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; @@ -100,7 +101,7 @@ my @cdids = sort $cd_rs->get_column ('cdid')->all; # add an extra track to one of the cds, and then make sure we can get it on top # (check if limit works) - my $top_cd = $cd_rs->slice (1,1)->next; + my $top_cd = $cd_rs->search({}, { order_by => 'cdid' })->slice (1,1)->next; $top_cd->create_related ('tracks', { title => 'over the top', }); diff --git a/t/prefetch/incomplete.t b/t/prefetch/incomplete.t index 63e431aa9..114ccfb29 100644 --- a/t/prefetch/incomplete.t +++ b/t/prefetch/incomplete.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Deep; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/join_type.t b/t/prefetch/join_type.t index f2980e788..5165e09b6 100644 --- a/t/prefetch/join_type.t +++ b/t/prefetch/join_type.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/lazy_cursor.t b/t/prefetch/lazy_cursor.t index de6e9361e..411248839 100644 --- a/t/prefetch/lazy_cursor.t +++ b/t/prefetch/lazy_cursor.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); @@ -62,7 +64,7 @@ $rs->next; my @objs = $rs->all; is (@objs, $initial_artists_cnt + 3, '->all resets everything correctly'); is ( ($rs->cursor->next)[0], 1, 'Cursor auto-rewound after all()'); -is ($rs->{_stashed_rows}, undef, 'Nothing else left in $rs stash'); +ok (! @{ $rs->{_stashed_rows} || [] }, 'Nothing else left in $rs stash'); my $unordered_rs = $rs->search({}, { order_by => 'cds.title' }); diff --git a/t/prefetch/manual.t b/t/prefetch/manual.t index e051ce37c..83870ae93 100644 --- a/t/prefetch/manual.t +++ b/t/prefetch/manual.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -5,7 +7,7 @@ use Test::More; use Test::Deep; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; delete $ENV{DBIC_COLUMNS_INCLUDE_FILTER_RELS}; diff --git a/t/prefetch/multiple_hasmany.t b/t/prefetch/multiple_hasmany.t index 665005b75..7af0888a3 100644 --- a/t/prefetch/multiple_hasmany.t +++ b/t/prefetch/multiple_hasmany.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/multiple_hasmany_torture.t b/t/prefetch/multiple_hasmany_torture.t index d3998e098..cd503ddd2 100644 --- a/t/prefetch/multiple_hasmany_torture.t +++ b/t/prefetch/multiple_hasmany_torture.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Deep; use Test::Exception; -use lib qw(t/lib); + use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; diff --git a/t/prefetch/o2m_o2m_order_by_with_limit.t b/t/prefetch/o2m_o2m_order_by_with_limit.t index 65a2c3986..5f0fffb7c 100644 --- a/t/prefetch/o2m_o2m_order_by_with_limit.t +++ b/t/prefetch/o2m_o2m_order_by_with_limit.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; +use List::Util 'min'; -use lib qw(t/lib); use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; @@ -131,7 +133,7 @@ for ( is_deeply( $rs->all_hri, - [ @{$hri_contents}[$offset .. List::Util::min( $used_limit+$offset-1, $#$hri_contents)] ], + [ @{$hri_contents}[$offset .. min( $used_limit+$offset-1, $#$hri_contents)] ], "Correct slice of the resultset returned with limit '$limit', offset '$offset'", ); } diff --git a/t/prefetch/one_to_many_to_one.t b/t/prefetch/one_to_many_to_one.t index f79b38e2c..f8a4fcdae 100644 --- a/t/prefetch/one_to_many_to_one.t +++ b/t/prefetch/one_to_many_to_one.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/refined_search_on_relation.t b/t/prefetch/refined_search_on_relation.t index 729dbdebd..e27687c01 100644 --- a/t/prefetch/refined_search_on_relation.t +++ b/t/prefetch/refined_search_on_relation.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/restricted_children_set.t b/t/prefetch/restricted_children_set.t index 9b0f3ee0d..5ad56bf8b 100644 --- a/t/prefetch/restricted_children_set.t +++ b/t/prefetch/restricted_children_set.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/standard.t b/t/prefetch/standard.t index 75107c706..bf863157c 100644 --- a/t/prefetch/standard.t +++ b/t/prefetch/standard.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/via_search_related.t b/t/prefetch/via_search_related.t index 316035d4b..846b3338f 100644 --- a/t/prefetch/via_search_related.t +++ b/t/prefetch/via_search_related.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/with_limit.t b/t/prefetch/with_limit.t index 28b3b8a89..5b1bb83ce 100644 --- a/t/prefetch/with_limit.t +++ b/t/prefetch/with_limit.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + # Test to ensure we get a consistent result set wether or not we use the # prefetch option in combination rows (LIMIT). use strict; @@ -5,7 +7,7 @@ use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/relationship/after_update.t b/t/relationship/after_update.t index 7ec8d005a..cc4e4be2a 100644 --- a/t/relationship/after_update.t +++ b/t/relationship/after_update.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/relationship/core.t b/t/relationship/core.t index 87f635e6a..6ebf94fa4 100644 --- a/t/relationship/core.t +++ b/t/relationship/core.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); @@ -137,22 +139,6 @@ throws_ok { $new_bookmark->new_related( no_such_rel => {} ); } qr/No such relationship 'no_such_rel'/, 'creating in uknown rel throws'; -{ - local $TODO = "relationship checking needs fixing"; - # try to add a bogus relationship using the wrong cols - throws_ok { - DBICTest::Schema::Artist->add_relationship( - tracks => 'DBICTest::Schema::Track', - { 'foreign.cd' => 'self.cdid' } - ); - } qr/Unknown column/, 'failed when creating a rel with invalid key, ok'; -} - -# another bogus relationship using no join condition -throws_ok { - DBICTest::Schema::Artist->add_relationship( tracks => 'DBICTest::Track' ); -} qr/join condition/, 'failed when creating a rel without join condition, ok'; - # many_to_many helper tests $cd = $schema->resultset("CD")->find(1); my @producers = $cd->producers(undef, { order_by => 'producerid'} ); @@ -209,7 +195,8 @@ warnings_like { qr/\Qsearch( %condition ) is deprecated/ ], 'Warning properly bubbled from search()'; -$cd->set_producers([$schema->resultset('Producer')->all]); +# the undef-attr-arg at the end is deliberate: this is what FormFu does +$cd->set_producers([$schema->resultset('Producer')->all], undef); is( $cd->producers->count(), $prod_before_count+2, 'many_to_many set_$rel(\@objs) count ok' ); $cd->set_producers([$schema->resultset('Producer')->find(1)]); @@ -279,7 +266,11 @@ is($undir_maps->count, 1, 'found 1 undirected map for artist 2'); { my $artist_to_mangle = $schema->resultset('Artist')->find(2); - $artist_to_mangle->set_from_related( artist_undirected_maps => { id1 => 42 } ); + throws_ok { + $artist_to_mangle->set_from_related( artist_undirected_maps => { id1 => 42 } ) + } qr/\QUnable to complete value inferrence - relationship 'artist_undirected_maps' on source 'Artist' results in expression(s) instead of definitive values: ( artistid = ? OR artistid IS NULL )/, + 'Expected exception on unresovable set_from_related' + ; ok( ! $artist_to_mangle->is_changed, 'Unresolvable set_from_related did not alter object' ); diff --git a/t/relationship/custom.t b/t/relationship/custom.t index b9bf5fa13..264650576 100644 --- a/t/relationship/custom.t +++ b/t/relationship/custom.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); @@ -160,7 +162,7 @@ lives_ok { # try to create_related a 80s cd throws_ok { $artist->create_related('cds_80s', { title => 'related creation 1' }); -} qr/\QUnable to complete value inferrence - custom relationship 'cds_80s' on source 'Artist' returns conditions instead of values for column(s): 'year'/, +} qr/\QUnable to complete value inferrence - relationship 'cds_80s' on source 'Artist' results in expression(s) instead of definitive values: ( year < ? AND year > ? )/, 'Create failed - complex cond'; # now supply an explicit arg overwriting the ambiguous cond diff --git a/t/relationship/custom_opaque.t b/t/relationship/custom_opaque.t index 1139c6aa2..6e701c437 100644 --- a/t/relationship/custom_opaque.t +++ b/t/relationship/custom_opaque.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib 't/lib'; + use DBICTest; my $schema = DBICTest->init_schema( no_populate => 1, quote_names => 1 ); diff --git a/t/relationship/custom_with_null_in_cond.t b/t/relationship/custom_with_null_in_cond.t index e7a7acb25..b396014e8 100644 --- a/t/relationship/custom_with_null_in_cond.t +++ b/t/relationship/custom_with_null_in_cond.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib 't/lib'; + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/relationship/doesnt_exist.t b/t/relationship/doesnt_exist.t index 7575122eb..9133deeff 100644 --- a/t/relationship/doesnt_exist.t +++ b/t/relationship/doesnt_exist.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/relationship/dynamic_foreign_columns.t b/t/relationship/dynamic_foreign_columns.t index a9fc25451..ecc24c50a 100644 --- a/t/relationship/dynamic_foreign_columns.t +++ b/t/relationship/dynamic_foreign_columns.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; require DBICTest::DynamicForeignCols::TestComputer; diff --git a/t/relationship/info.t b/t/relationship/info.t index 4f349d45e..fd1bfa8f6 100644 --- a/t/relationship/info.t +++ b/t/relationship/info.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; # diff --git a/t/relationship/proxy.t b/t/relationship/proxy.t index ec9847db9..93a0a6699 100644 --- a/t/relationship/proxy.t +++ b/t/relationship/proxy.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/relationship/set_column_on_fk.t b/t/relationship/set_column_on_fk.t index 9f49427d5..df2adc914 100644 --- a/t/relationship/set_column_on_fk.t +++ b/t/relationship/set_column_on_fk.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/relationship/update_or_create_multi.t b/t/relationship/update_or_create_multi.t index 5dde83db1..59861268f 100644 --- a/t/relationship/update_or_create_multi.t +++ b/t/relationship/update_or_create_multi.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/relationship/update_or_create_single.t b/t/relationship/update_or_create_single.t index a0e31fbb3..bb4f80857 100644 --- a/t/relationship/update_or_create_single.t +++ b/t/relationship/update_or_create_single.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/resultset/as_query.t b/t/resultset/as_query.t index 3b43e9c2f..09b51864c 100644 --- a/t/resultset/as_query.t +++ b/t/resultset/as_query.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/resultset/as_subselect_rs.t b/t/resultset/as_subselect_rs.t index 6d7597756..edfcae767 100644 --- a/t/resultset/as_subselect_rs.t +++ b/t/resultset/as_subselect_rs.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/resultset/bind_attr.t b/t/resultset/bind_attr.t index 7f25d99b1..a636cfc15 100644 --- a/t/resultset/bind_attr.t +++ b/t/resultset/bind_attr.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema; diff --git a/t/resultset/create_with_rs_inherited_values.t b/t/resultset/create_with_rs_inherited_values.t index 8a0acd377..bc4795094 100644 --- a/t/resultset/create_with_rs_inherited_values.t +++ b/t/resultset/create_with_rs_inherited_values.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -5,7 +7,7 @@ use Test::More; use Test::Exception; use Math::BigInt; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/resultset/find.t b/t/resultset/find.t new file mode 100644 index 000000000..8244a6da4 --- /dev/null +++ b/t/resultset/find.t @@ -0,0 +1,47 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +use DBICTest; + +my $schema = DBICTest->init_schema(); + +# this has been warning for 4 years, killing +throws_ok { + $schema->resultset('Artist')->find(artistid => 4); +} qr|expects either a column/value hashref, or a list of values corresponding to the columns of the specified unique constraint|; + +{ + my $exception_callback_count = 0; + + my $ea = $schema->exception_action(sub { + $exception_callback_count++; + die @_; + }); + + # No, this is not a great idea. + # Yes, people do it anyway. + # Might as well test that we have fixed it for good, by never invoking + # a potential __DIE__ handler in internal_try() stacks + local $SIG{__DIE__} = sub { $ea->(@_) }; + + # test find on non-unique non-existing value + is ( + $schema->resultset('Artist')->find({ rank => 666 }), + undef + ); + + # test find on an unresolvable condition + is( + $schema->resultset('Artist')->find({ artistid => [ -and => 1, 2 ]}), + undef + ); + + is $exception_callback_count, 0, 'exception_callback never invoked'; +} + +done_testing; diff --git a/t/resultset/find_on_subquery_cond.t b/t/resultset/find_on_subquery_cond.t index af2ca51aa..ec02d6b0a 100644 --- a/t/resultset/find_on_subquery_cond.t +++ b/t/resultset/find_on_subquery_cond.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/resultset/inflate_result_api.t b/t/resultset/inflate_result_api.t index e6bedc2b1..d4a0f8e3d 100644 --- a/t/resultset/inflate_result_api.t +++ b/t/resultset/inflate_result_api.t @@ -1,10 +1,13 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; no warnings 'exiting'; use Test::More; use Test::Deep; -use lib qw(t/lib); +use Test::Exception; + use DBICTest; my $schema = DBICTest->init_schema(no_populate => 1); @@ -37,6 +40,7 @@ $schema->resultset('CD')->create({ title => 'Oxygene', year => 1976, artist => { name => 'JMJ' }, + artwork => {}, tracks => [ { title => 'o2', position => 2}, # the position should not be needed here, bug in MC ], @@ -467,6 +471,49 @@ INFTYPE: for ('', '(native inflator)') { ], "Expected output of collapsing 1:M with empty root selection $native_inflator", ); + + cmp_structures ( + rs_contents( $schema->resultset ('CD')->search_rs ( + { + 'tracks.title' => 'e2', + 'cds.title' => 'Oxygene', + }, + { + collapse => 1, + join => [ + 'tracks', + { single_track => { cd => 'mandatory_artwork' } }, + { artist => { cds => 'mandatory_artwork'} }, + ], + columns => { + cdid => 'cdid', + 'single_track.cd.mandatory_artwork.cd_id' => 'mandatory_artwork.cd_id', + 'artist.cds.mandatory_artwork.cd_id' => 'mandatory_artwork_2.cd_id', + }, + }, + )), + [[ + { cdid => 3 }, + { + single_track => [ + undef, + { cd => [ + undef, + { mandatory_artwork => [ { cd_id => 2 } ] } + ] } + ], + artist => [ + undef, + { cds => [ + [ + undef, + { mandatory_artwork => [ { cd_id => 2 } ] } + ] + ] }, + ], + } + ]], + ); } sub null_branch { @@ -502,6 +549,7 @@ sub cmp_structures { cmp_deeply($left, $right, $msg||()) or next INFTYPE; } + { package DBICTest::_DoubleResult; @@ -529,4 +577,18 @@ is_deeply( })->all_hri}) x 2 ], ); + +{ + package DBICTest::_DieTrying; + + sub inflate_result { + die "nyah nyah nyah"; + } +} + +throws_ok { + $schema->resultset('CD')->search({}, { result_class => 'DBICTest::_DieTrying' })->all +} qr/nyah nyah nyah/, 'Exception in custom inflate_result propagated correctly'; + + done_testing; diff --git a/t/resultset/inflatemap_abuse.t b/t/resultset/inflatemap_abuse.t index 9c60765d2..0289891e7 100644 --- a/t/resultset/inflatemap_abuse.t +++ b/t/resultset/inflatemap_abuse.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; # From http://lists.scsys.co.uk/pipermail/dbix-class/2013-February/011119.html diff --git a/t/resultset/is_ordered.t b/t/resultset/is_ordered.t index 39595a4d3..a18345844 100644 --- a/t/resultset/is_ordered.t +++ b/t/resultset/is_ordered.t @@ -1,7 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib qw(t/lib); + use Test::More; use DBICTest; diff --git a/t/resultset/is_paged.t b/t/resultset/is_paged.t index 4f6af63fc..020afa076 100644 --- a/t/resultset/is_paged.t +++ b/t/resultset/is_paged.t @@ -1,7 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib qw(t/lib); + use Test::More; use DBICTest; diff --git a/t/resultset/misled_rowparser.t b/t/resultset/misled_rowparser.t new file mode 100644 index 000000000..2c76aeda1 --- /dev/null +++ b/t/resultset/misled_rowparser.t @@ -0,0 +1,63 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +use DBICTest; +my $schema = DBICTest->init_schema(); + +# The nullchecks metadata for this collapse resolution is: +# +# mandatory => { 0 => 1 } +# from_first_encounter => [ [ 1, 2, 3 ] ] +# all_or_nothing => [ { 1 => 1, 2 => 1 } ] +# +my $rs = $schema->resultset('Artist')->search({}, { + collapse => 1, + join => { cds => 'tracks' }, + columns => [qw( + me.artistid + cds.artist + cds.title + ), + { 'cds.tracks.title' => 'tracks.title' }, + ], +}); + +my @cases = ( + "'artistid'" + => [ undef, 0, 0, undef ], + + "'artistid', 'cds.title'" + => [ undef, 0, undef, undef ], + + "'artistid', 'cds.artist'" + => [ undef, undef, 0, undef ], + + "'cds.artist'" + => [ 0, undef, 0, 0 ], + + "'cds.title'" + => [ 0, 0, undef, 0 ], + + # petrhaps need to report cds.title here as well, but that'll complicate checks even more... + "'cds.artist'" + => [ 0, undef, undef, 0 ], +); + +while (@cases) { + my ($err, $cursor) = splice @cases, 0, 2; + + $rs->{_stashed_rows} = [ $cursor ]; + + throws_ok + { $rs->next } + qr/\Qthe following columns are declared (or defaulted to) non-nullable within DBIC but NULLs were retrieved from storage: $err within data row/, + "Correct exception on non-nullable-yet-NULL $err" + ; +} + +done_testing; diff --git a/t/resultset/nulls_only.t b/t/resultset/nulls_only.t index 7f53d6d1f..a8d965c37 100644 --- a/t/resultset/nulls_only.t +++ b/t/resultset/nulls_only.t @@ -1,7 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib qw(t/lib); + use Test::More; use DBICTest; diff --git a/t/resultset/plus_select.t b/t/resultset/plus_select.t index db55ac48e..d63adad51 100644 --- a/t/resultset/plus_select.t +++ b/t/resultset/plus_select.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Math::BigInt; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/resultset/rowparser_internals.t b/t/resultset/rowparser_internals.t index e89369fb2..67215eb09 100644 --- a/t/resultset/rowparser_internals.t +++ b/t/resultset/rowparser_internals.t @@ -1,20 +1,14 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; use B::Deparse; use DBIx::Class::_Util 'perlstring'; -# globally set for the rest of test -# the rowparser maker does not order its hashes by default for the miniscule -# speed gain. But it does not disable sorting either - for this test -# everything will be ordered nicely, and the hash randomization of 5.18 -# will not trip up anything -use Data::Dumper; -$Data::Dumper::Sortkeys = 1; - my $schema = DBICTest->init_schema(no_deploy => 1); my $infmap = [qw/ single_track.cd.artist.name @@ -265,12 +259,46 @@ is_same_src ( ( $_[1] and $_[1]->() ) ) ) { + + # NULL checks + # mandatory => { 4 => 1, 5 => 1 } + # from_first_encounter => [ [ 1, 3, 0 ] ] + # + ( defined( $cur_row_data->[4] ) or $_[3]->{4} = 1 ), + + ( defined( $cur_row_data->[5] ) or $_[3]->{5} = 1 ), + + ( + ( not defined $cur_row_data->[1] ) + ? ( + ( not defined $cur_row_data->[3] ) + and + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{1} = 1 ) + ) + : ( not defined $cur_row_data->[3] ) + ? ( + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{3} = 1 ) + ) + : () + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + ( @cur_row_ids{0,1,3,4,5} = ( ( $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0" ), ( $cur_row_data->[1] // "\0NULL\xFF$rows_pos\xFF1\0" ), ( $cur_row_data->[3] // "\0NULL\xFF$rows_pos\xFF3\0" ), - ( $cur_row_data->[4] // "\0NULL\xFF$rows_pos\xFF4\0" ), - ( $cur_row_data->[5] // "\0NULL\xFF$rows_pos\xFF5\0" ), + ( $cur_row_data->[4] ), + ( $cur_row_data->[5] ), ) ), # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2] @@ -339,6 +367,40 @@ is_same_src ( ( $_[1] and $_[1]->() ) ) ) { + + # NULL checks + # mandatory => { 4 => 1, 5 => 1 } + # from_first_encounter => [ [ 1, 3, 0 ] ] + # + ( defined( $cur_row_data->[4] ) or $_[3]->{4} = 1 ), + + ( defined( $cur_row_data->[5] ) or $_[3]->{5} = 1 ), + + ( + ( not defined $cur_row_data->[1] ) + ? ( + ( not defined $cur_row_data->[3] ) + and + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{1} = 1 ) + ) + : ( not defined $cur_row_data->[3] ) + ? ( + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{3} = 1 ) + ) + : () + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + ( @cur_row_ids{0, 1, 3, 4, 5} = @{$cur_row_data}[0, 1, 3, 4, 5] ), # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2] @@ -349,10 +411,10 @@ is_same_src ( # prefetch data of single_track (placed in root) ( (! defined($cur_row_data->[1]) ) ? $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}}{single_track} = undef : do { - ( $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}}{single_track} //= $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} ), + ( $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}}{single_track} //= $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = {} ), # prefetch data of cd (placed in single_track) - ( $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}{cd} //= $collapse_idx[2]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} ), + ( $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}{cd} //= $collapse_idx[2]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = {} ), # prefetch data of artist ( placed in single_track->cd) ( $collapse_idx[2]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}{artist} //= $collapse_idx[3]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = { artistid => $cur_row_data->[1] } ), @@ -470,9 +532,51 @@ is_same_src ( ( $_[1] and $_[1]->() ) ) ) { + + # NULL checks + # mandatory => { 1 => 1 } + # from_first_encounter => [ [6, 8], [5, 10, 0] ], + # + ( defined( $cur_row_data->[1] ) or $_[3]->{1} = 1 ), + + ( + ( not defined $cur_row_data->[6] ) + ? ( + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{6} = 1 ) + ) + : () + ), + + ( + ( not defined $cur_row_data->[5] ) + ? ( + ( not defined $cur_row_data->[10] ) + and + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{5} = 1 ) + ) + : ( not defined $cur_row_data->[10] ) + ? ( + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{10} = 1 ) + ) + : () + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + ( @cur_row_ids{0, 1, 5, 6, 8, 10} = ( $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0", - $cur_row_data->[1] // "\0NULL\xFF$rows_pos\xFF1\0", + $cur_row_data->[1], $cur_row_data->[5] // "\0NULL\xFF$rows_pos\xFF5\0", $cur_row_data->[6] // "\0NULL\xFF$rows_pos\xFF6\0", $cur_row_data->[8] // "\0NULL\xFF$rows_pos\xFF8\0", @@ -555,6 +659,48 @@ is_same_src ( ( $_[1] and $_[1]->() ) ) ) { + + # NULL checks + # mandatory => { 1 => 1 } + # from_first_encounter => [ [6, 8], [5, 10, 0] ], + # + ( defined( $cur_row_data->[1] ) or $_[3]->{1} = 1 ), + + ( + ( not defined $cur_row_data->[6] ) + ? ( + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{6} = 1 ) + ) + : () + ), + + ( + ( not defined $cur_row_data->[5] ) + ? ( + ( not defined $cur_row_data->[10] ) + and + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{5} = 1 ) + ) + : ( not defined $cur_row_data->[10] ) + ? ( + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{10} = 1 ) + ) + : () + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + ( @cur_row_ids{( 0, 1, 5, 6, 8, 10 )} = @{$cur_row_data}[( 0, 1, 5, 6, 8, 10 )] ), # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2] @@ -686,6 +832,49 @@ is_same_src ( ( $_[1] and $_[1]->() ) ) ) { + + # NULL checks + # + # from_first_encounter => [ [0, 4, 8] ] + # all_or_nothing => [ { 2 => 1, 3 => 1 } ] + ( + ( not defined $cur_row_data->[0] ) + ? ( + ( not defined $cur_row_data->[4] ) + and + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{0} = 1 ) + ) + : ( not defined $cur_row_data->[4] ) + ? ( + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{4} = 1 ) + ) + : () + ), + + ( + ( + ( not defined $cur_row_data->[2] ) + and + ( not defined $cur_row_data->[3] ) + ) + or + ( + ( defined($cur_row_data->[2]) or $_[3]->{2} = 1 ), + ( defined($cur_row_data->[3]) or $_[3]->{3} = 1 ), + ) + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + ( @cur_row_ids{( 0, 2, 3, 4, 8 )} = ( $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0", $cur_row_data->[2] // "\0NULL\xFF$rows_pos\xFF2\0", @@ -772,6 +961,49 @@ is_same_src ( ( $_[1] and $_[1]->() ) ) ) { + + # NULL checks + # + # from_first_encounter => [ [0, 4, 8] ] + # all_or_nothing => [ { 2 => 1, 3 => 1 } ] + ( + ( not defined $cur_row_data->[0] ) + ? ( + ( not defined $cur_row_data->[4] ) + and + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{0} = 1 ) + ) + : ( not defined $cur_row_data->[4] ) + ? ( + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{4} = 1 ) + ) + : () + ), + + ( + ( + ( not defined $cur_row_data->[2] ) + and + ( not defined $cur_row_data->[3] ) + ) + or + ( + ( defined($cur_row_data->[2]) or $_[3]->{2} = 1 ), + ( defined($cur_row_data->[3]) or $_[3]->{3} = 1 ), + ) + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + # do not care about nullability here ( @cur_row_ids{( 0, 2, 3, 4, 8 )} = @{$cur_row_data}[( 0, 2, 3, 4, 8 )] ), @@ -793,7 +1025,7 @@ is_same_src ( ( $collapse_idx[0]{$cur_row_ids{10}}{single_track} //= ($collapse_idx[1]{$cur_row_ids{0}} = { trackid => $$cur_row_data[0] }) ), - ( $collapse_idx[1]{$cur_row_ids{0}}{cd} //= $collapse_idx[2]{$cur_row_ids{0}} ), + ( $collapse_idx[1]{$cur_row_ids{0}}{cd} //= $collapse_idx[2]{$cur_row_ids{0}} = {} ), ( $collapse_idx[2]{$cur_row_ids{0}}{artist} //= ($collapse_idx[3]{$cur_row_ids{0}} = { artistid => $$cur_row_data[6] }) ), @@ -834,6 +1066,226 @@ is_same_src ( 'Multiple has_many on multiple branches with underdefined root, HRI-direct torture test', ); + +$infmap = [ + 'single_track.lyrics.track_id', # (0) random optional 1:1:1 chain + 'year', # (1) non-unique + 'tracks.cd', # (2) \ together both uniqueness for second multirel + 'tracks.title', # (3) / and definitive link back to root + 'single_track.cd.artist.cds.cdid', # (4) to give uniquiness to ...tracks.title below + 'single_track.cd.artist.cds.year', # (5) non-unique + 'single_track.cd.artist.artistid', # (6) uniqufies entire parental chain + 'single_track.cd.artist.cds.genreid', # (7) nullable + 'single_track.cd.artist.cds.tracks.title', # (8) unique when combined with ...cds.cdid above + 'single_track.lyrics.lyric_versions.text', # (9) unique combined with the single_track.lyrics 1:1:1 +]; + +is_deeply ( + $schema->source('CD')->_resolve_collapse({ as => {map { $infmap->[$_] => $_ } 0 .. $#$infmap} }), + { + -identifying_columns => [], + -identifying_columns_variants => [ + [ 2 ], [ 6 ], + ], + single_track => { + -identifying_columns => [ 6 ], + -is_optional => 1, + -is_single => 1, + cd => { + -identifying_columns => [ 6 ], + -is_single => 1, + artist => { + -identifying_columns => [ 6 ], + -is_single => 1, + cds => { + -identifying_columns => [ 4, 6 ], + -is_optional => 1, + tracks => { + -identifying_columns => [ 4, 6, 8 ], + -is_optional => 1, + } + } + } + }, + lyrics => { + -identifying_columns => [ 0, 6 ], + -is_optional => 1, + -is_single => 1, + lyric_versions => { + -identifying_columns => [ 0, 6, 9 ], + -is_optional => 1, + }, + }, + }, + tracks => { + -identifying_columns => [ 2, 3 ], + -is_optional => 1, + } + }, + 'Correct underdefined root tripple-has-many-torture collapse map constructed' +); + +is_same_src ( + ($schema->source ('CD')->_mk_row_parser({ + inflate_map => $infmap, + collapse => 1, + hri_style => 1, + prune_null_branches => 1, + }))[0], + ' my $rows_pos = 0; + my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids); + + while ($cur_row_data = ( + ( + $rows_pos >= 0 + and + ( + $_[0][$rows_pos++] + or + ( ($rows_pos = -1), undef ) + ) + ) + or + ( $_[1] and $_[1]->() ) + ) ) { + + # NULL checks + # + # from_first_encounter => [ [6, 4, 8], [6, 0, 9] ] + # all_or_nothing => [ { 2 => 1, 3 => 1 } ] + ( + ( not defined $cur_row_data->[6] ) + ? ( + ( not defined $cur_row_data->[4] ) + and + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{6} = 1 ) + ) + : ( not defined $cur_row_data->[4] ) + ? ( + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{4} = 1 ) + ) + : () + ), + + ( + ( not defined $cur_row_data->[6] ) + ? ( + ( not defined $cur_row_data->[0] ) + and + ( not defined $cur_row_data->[9] ) + or + ( $_[3]->{6} = 1 ) + ) + : ( not defined $cur_row_data->[0] ) + ? ( + ( not defined $cur_row_data->[9] ) + or + ( $_[3]->{0} = 1 ) + ) + : () + ), + + ( + ( + ( not defined $cur_row_data->[2] ) + and + ( not defined $cur_row_data->[3] ) + ) + or + ( + ( defined($cur_row_data->[2]) or $_[3]->{2} = 1 ), + ( defined($cur_row_data->[3]) or $_[3]->{3} = 1 ), + ) + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + + # do not care about nullability here + ( @cur_row_ids{( 0, 2, 3, 4, 6, 8, 9 )} = @{$cur_row_data}[( 0, 2, 3, 4, 6, 8, 9 )] ), + + # cache expensive set of ops in a non-existent rowid slot + ( $cur_row_ids{11} = ( + ( ( defined $cur_row_data->[2] ) && (join "\xFF", q{}, $cur_row_ids{2}, q{} )) + or + ( ( defined $cur_row_data->[6] ) && (join "\xFF", q{}, $cur_row_ids{6}, q{} )) + or + "\0$rows_pos\0" + )), + + # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2] + ( $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{11}} and (unshift @{$_[2]}, $cur_row_data) and last ), + + ( $collapse_idx[0]{$cur_row_ids{11}} //= $_[0][$result_pos++] = { year => $$cur_row_data[1] } ), + + ( (! defined $cur_row_data->[6] ) ? $collapse_idx[0]{$cur_row_ids{11}}{single_track} = undef : do { + + ( $collapse_idx[0]{$cur_row_ids{11}}{single_track} //= ( $collapse_idx[1]{$cur_row_ids{6}} = {} ) ), + + ( $collapse_idx[1]{$cur_row_ids{6}}{cd} //= $collapse_idx[2]{$cur_row_ids{6}} = {} ), + + ( $collapse_idx[2]{$cur_row_ids{6}}{artist} //= ($collapse_idx[3]{$cur_row_ids{6}} = { artistid => $$cur_row_data[6] }) ), + + ( (! defined $cur_row_data->[4] ) ? $collapse_idx[3]{$cur_row_ids{6}}{cds} = [] : do { + + ( + (! $collapse_idx[4]{$cur_row_ids{4}}{$cur_row_ids{6}} ) + and + push @{$collapse_idx[3]{$cur_row_ids{6}}{cds}}, ( + $collapse_idx[4]{$cur_row_ids{4}}{$cur_row_ids{6}} = { cdid => $$cur_row_data[4], genreid => $$cur_row_data[7], year => $$cur_row_data[5] } + ) + ), + + ( (! defined $cur_row_data->[8] ) ? $collapse_idx[4]{$cur_row_ids{4}}{$cur_row_ids{6}}{tracks} = [] : do { + + (! $collapse_idx[5]{$cur_row_ids{4}}{$cur_row_ids{6}}{$cur_row_ids{8}} ) + and + push @{$collapse_idx[4]{$cur_row_ids{4}}{$cur_row_ids{6}}{tracks}}, ( + $collapse_idx[5]{$cur_row_ids{4}}{$cur_row_ids{6}}{$cur_row_ids{8}} = { title => $$cur_row_data[8] } + ), + } ), + } ), + + ( ( ! defined $cur_row_data->[0] ) ? $collapse_idx[1]{ $cur_row_ids{6} }{"lyrics"} = undef : do { + + ( $collapse_idx[1]{ $cur_row_ids{6} }{"lyrics"} //= ( $collapse_idx[6]{ $cur_row_ids{0} }{ $cur_row_ids{6} } = { "track_id" => $cur_row_data->[0] } ) ), + + ( ( ! defined $cur_row_data->[9] ) ? $collapse_idx[6]{ $cur_row_ids{0} }{ $cur_row_ids{6} }{"lyric_versions"} = [] : do { + ( + (! $collapse_idx[7]{ $cur_row_ids{0} }{ $cur_row_ids{6} }{ $cur_row_ids{9} }) + and + push @{$collapse_idx[6]{ $cur_row_ids{0} }{ $cur_row_ids{6} }{"lyric_versions"}}, ( + $collapse_idx[7]{ $cur_row_ids{0} }{ $cur_row_ids{6} }{ $cur_row_ids{9} } = { "text" => $cur_row_data->[9] } + ), + ), + } ), + } ), + } ), + + ( (! defined $cur_row_data->[2] ) ? $collapse_idx[0]{$cur_row_ids{11}}{tracks} = [] : do { + ( + (! $collapse_idx[8]{$cur_row_ids{2}}{$cur_row_ids{3}} ) + and + push @{$collapse_idx[0]{$cur_row_ids{11}}{tracks}}, ( + $collapse_idx[8]{$cur_row_ids{2}}{$cur_row_ids{3}} = { cd => $$cur_row_data[2], title => $$cur_row_data[3] } + ) + ), + } ), + } + + $#{$_[0]} = $result_pos - 1; + ', + 'Tripple multiple has_many on multiple branches with underdefined root, HRI-direct torture test', +); + is_same_src ( ($schema->source ('Owners')->_mk_row_parser({ inflate_map => [qw( books.title books.owner )], @@ -883,12 +1335,116 @@ is_same_src ( 'Non-premultiplied implicit collapse with missing join columns', ); +is_same_src ( + ($schema->source('Artist')->_mk_row_parser({ + inflate_map => [qw( artistid cds.artist cds.title cds.tracks.title )], + collapse => 1, + prune_null_branches => 1, + }))[0], + ' my $rows_pos = 0; + my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids ); + + while ($cur_row_data = ( + ( + $rows_pos >= 0 + and + ( + $_[0][$rows_pos++] + or + ( ($rows_pos = -1), undef ) + ) + ) + or + ( $_[1] and $_[1]->() ) + ) ) { + + # NULL checks + # + # mandatory => { 0 => 1 } + # from_first_encounter => [ [1, 2, 3] ] + # all_or_nothing => [ { 1 => 1, 2 => 1 } ] + + ( defined( $cur_row_data->[0] ) or $_[3]->{0} = 1 ), + + ( + ( not defined $cur_row_data->[1] ) + ? ( + ( not defined $cur_row_data->[2] ) + and + ( not defined $cur_row_data->[3] ) + or + $_[3]->{1} = 1 + ) + : ( not defined $cur_row_data->[2] ) + ? ( + ( not defined $cur_row_data->[3] ) + or + $_[3]->{2} = 1 + ) + : () + ), + + ( + ( + ( not defined $cur_row_data->[1] ) + and + ( not defined $cur_row_data->[2] ) + ) + or + ( + ( defined($cur_row_data->[1]) or $_[3]->{1} = 1 ), + ( defined($cur_row_data->[2]) or $_[3]->{2} = 1 ), + ) + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + + ( @cur_row_ids{( 0, 1, 2, 3 )} = @{$cur_row_data}[ 0, 1, 2, 3 ] ), + + ( $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{0}} and (unshift @{$_[2]}, $cur_row_data) and last ), + + ( $collapse_idx[0]{ $cur_row_ids{0} } + //= $_[0][$result_pos++] = [ { "artistid" => $cur_row_data->[0] } ] + ), + + ( ( ! defined $cur_row_data->[1] ) ? $collapse_idx[0]{ $cur_row_ids{0} }[1]{"cds"} = [] : do { + + ( + ! $collapse_idx[1]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{2} } + and + push @{$collapse_idx[0]{ $cur_row_ids{0} }[1]{"cds"}}, + $collapse_idx[1]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{2} } + = [ { "artist" => $cur_row_data->[1], "title" => $cur_row_data->[2] } ] + ), + + ( ( ! defined $cur_row_data->[3] ) ? $collapse_idx[1]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{2} }[1]{"tracks"} = [] : do { + ( + ! $collapse_idx[2]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{2} }{ $cur_row_ids{3} } + and + push @{$collapse_idx[1]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{2} }[1]{"tracks"}}, + $collapse_idx[2]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{2} }{ $cur_row_ids{3} } + = [ { "title" => $cur_row_data->[3] } ] + ), + } ), + } ), + } + + $#{$_[0]} = $result_pos - 1 + ', + 'A rolled out version of inflate map of misled_rowparser.t' +); + done_testing; my $deparser; sub is_same_src { SKIP: { - skip "Skipping comparison of unicode-posioned source", 1 + skip "Skipping comparison of unicode-poisoned source", 1 if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE; $deparser ||= B::Deparse->new; @@ -901,7 +1457,7 @@ sub is_same_src { SKIP: { $expect =~ s/__NBC__/perlstring($DBIx::Class::ResultSource::RowParser::Util::null_branch_class)/ge; - $expect = " { use strict; use warnings FATAL => 'uninitialized';\n$expect\n }"; + $expect = "sub { use strict; use warnings FATAL => 'uninitialized';\n$expect\n }"; my @normalized = map { my $cref = eval "sub { $_ }" or do { diff --git a/t/resultset/update_delete.t b/t/resultset/update_delete.t index 30e379743..46f690af7 100644 --- a/t/resultset/update_delete.t +++ b/t/resultset/update_delete.t @@ -1,7 +1,8 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib qw(t/lib); use Test::More; use Test::Exception; diff --git a/t/resultset_class.t b/t/resultset_class.t index 607c1f254..3d7902239 100644 --- a/t/resultset_class.t +++ b/t/resultset_class.t @@ -1,21 +1,20 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use Class::Inspector (); - -unshift(@INC, './t/lib'); -use lib 't/lib'; use DBICTest; +use DBICTest::Util 'class_seems_loaded'; is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICTest::BaseResultSet', 'default resultset class'); -ok(!Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded'); +ok(! class_seems_loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded'); DBICTest::Schema->source('Artist')->resultset_class('DBICNSTest::ResultSet::A'); -ok(!Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded on SET'); +ok(! class_seems_loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded on SET'); is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICNSTest::ResultSet::A', 'custom resultset class set'); -ok(Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class loaded on GET'); +ok(class_seems_loaded('DBICNSTest::ResultSet::A'), 'custom resultset class loaded on GET'); my $schema = DBICTest->init_schema; my $resultset = $schema->resultset('Artist')->search; diff --git a/t/resultset_overload.t b/t/resultset_overload.t index 164d2ee66..8fb22e3d4 100644 --- a/t/resultset_overload.t +++ b/t/resultset_overload.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/resultsource/add_column_on_instance.t b/t/resultsource/add_column_on_instance.t new file mode 100644 index 000000000..9ae95165c --- /dev/null +++ b/t/resultsource/add_column_on_instance.t @@ -0,0 +1,22 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; + +use DBICTest; + +my $ar = DBICTest->init_schema->resultset("Artist")->find(1); + +ok (! $ar->can("not_yet_there_column"), "No accessor for nonexitentcolumn" ); + +$ar->add_column("not_yet_there_column"); +ok ($ar->has_column("not_yet_there_column"), "Metadata correct after nonexitentcolumn addition" ); +ok ($ar->can("not_yet_there_column"), "Accessor generated for nonexitentcolumn" ); + +$ar->not_yet_there_column('I EXIST \o/'); + +is { $ar->get_columns }->{not_yet_there_column}, 'I EXIST \o/', "Metadata propagates to mutli-column methods"; + +done_testing; diff --git a/t/resultsource/bare_resultclass_exception.t b/t/resultsource/bare_resultclass_exception.t index 6b8d72c58..0db9efd04 100644 --- a/t/resultsource/bare_resultclass_exception.t +++ b/t/resultsource/bare_resultclass_exception.t @@ -1,10 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib 't/lib'; use DBICTest; { diff --git a/t/resultsource/instance_equivalence.t b/t/resultsource/instance_equivalence.t new file mode 100644 index 000000000..90621f960 --- /dev/null +++ b/t/resultsource/instance_equivalence.t @@ -0,0 +1,25 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +BEGIN { $ENV{DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE} = 0 } + +use strict; +use warnings; +no warnings 'qw'; + +use Test::More; + +use DBICTest; + +my $schema = DBICTest->init_schema; +my $rsrc = $schema->source("Artist"); + +is( (eval($_)||die $@), $rsrc, "Same source object after $_" ) for qw( + $rsrc->resultset->result_source, + $rsrc->resultset->next->result_source, + $rsrc->resultset->next->result_source_instance, + $schema->resultset("Artist")->result_source, + $schema->resultset("Artist")->next->result_source, + $schema->resultset("Artist")->next->result_source_instance, +); + +done_testing; diff --git a/t/resultsource/rsrc_proxy_invocation.t b/t/resultsource/rsrc_proxy_invocation.t new file mode 100644 index 000000000..dc4c9d479 --- /dev/null +++ b/t/resultsource/rsrc_proxy_invocation.t @@ -0,0 +1,61 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +$ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS} = 1; + +use strict; +use warnings; + +use Test::More; + +use DBICTest; +use Sub::Quote 'quote_sub'; + +my $colinfo = DBICTest::Schema::Artist->result_source->column_info('artistid'); + +my $schema = DBICTest->init_schema ( no_deploy => 1 ); +my $rsrc = $schema->source("Artist"); + +for my $overrides_marked_mandatory (0, 1) { + my $call_count; + my @methods_to_override = qw( + add_columns columns_info + ); + + my $attr = { attributes => [ + $overrides_marked_mandatory + ? 'DBIC_method_is_mandatory_resultsource_proxy' + : 'DBIC_method_is_bypassable_resultsource_proxy' + ] }; + + for (@methods_to_override) { + $call_count->{$_} = 0; + + quote_sub( "DBICTest::Schema::Artist::$_", <<'EOC', { '$cnt' => \\($call_count->{$_}) }, $attr ); + $$cnt++; + shift->next::method(@_); +EOC + } + + Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; + + is_deeply + $rsrc->columns_info->{artistid}, + $colinfo, + 'Expected result from rsrc getter', + ; + + $rsrc->add_columns("bar"); + + is_deeply + $call_count, + { + add_columns => ($overrides_marked_mandatory ? 1 : 0), + + # ResultSourceProxy::add_columns will call colinfos as well + columns_info => ($overrides_marked_mandatory ? 2 : 0), + }, + 'expected rsrc proxy override callcounts', + ; +} + +done_testing; diff --git a/t/resultsource/set_primary_key.t b/t/resultsource/set_primary_key.t index 1f9de7df3..e46ad642d 100644 --- a/t/resultsource/set_primary_key.t +++ b/t/resultsource/set_primary_key.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib 't/lib'; + use DBICTest; throws_ok { diff --git a/t/row/copy_with_extra_selection.t b/t/row/copy_with_extra_selection.t index c1e3df4d2..86c49b672 100644 --- a/t/row/copy_with_extra_selection.t +++ b/t/row/copy_with_extra_selection.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/row/filter_column.t b/t/row/filter_column.t index 7823fa53e..cf7e24582 100644 --- a/t/row/filter_column.t +++ b/t/row/filter_column.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $from_storage_ran = 0; @@ -130,6 +132,72 @@ CACHE_TEST: { is $from_storage_ran, ++$expected_from, 'from did run'; is $to_storage_ran, $expected_to, 'to did not run'; + ok ! $artist->is_changed, 'object clean'; + is_deeply + { $artist->get_dirty_columns }, + {}, + 'dirty columns as expected', + ; + + is $from_storage_ran, $expected_from, 'from did not run'; + is $to_storage_ran, $expected_to, 'to did not run'; + + $artist->charfield(42); + + is $from_storage_ran, $expected_from, 'from did not run'; + is $to_storage_ran, ++$expected_to, 'to ran once, determining dirtyness'; + + is $artist->charfield, 42, 'setting once works'; + ok $artist->is_column_changed('charfield'), 'column changed'; + ok $artist->is_changed, 'object changed'; + is_deeply + { $artist->get_dirty_columns }, + { charfield => 21 }, + 'dirty columns as expected', + ; + + is $from_storage_ran, $expected_from, 'from did not run'; + is $to_storage_ran, $expected_to, 'to did not run'; + + $artist->charfield(66); + is $artist->charfield, 66, 'setting twice works'; + ok $artist->is_column_changed('charfield'), 'column changed'; + ok $artist->is_changed, 'object changed'; + + is $from_storage_ran, $expected_from, 'from did not run'; + is $to_storage_ran, $expected_to, 'to did not run a second time on dirty column'; + + is_deeply + { $artist->get_dirty_columns }, + { charfield => 33 }, + 'dirty columns as expected', + ; + is $from_storage_ran, $expected_from, 'from did not run'; + is $to_storage_ran, ++$expected_to, 'to did run producing a new dirty_columns set'; + + is_deeply + { $artist->get_dirty_columns }, + { charfield => 33 }, + 'dirty columns still as expected', + ; + is $from_storage_ran, $expected_from, 'from did not run'; + is $to_storage_ran, $expected_to, 'to did not run on re-invoked get_dirty_columns'; + + $artist->update; + is $artist->charfield, 66, 'value still there'; + + is $from_storage_ran, $expected_from, 'from did not run'; + is $to_storage_ran, $expected_to, 'to did not run '; + + $artist->discard_changes; + + is $from_storage_ran, $expected_from, 'from did not run after discard_changes'; + is $to_storage_ran, $expected_to, 'to did not run after discard_changes'; + + is $artist->charfield, 66, 'value still there post reload'; + + is $from_storage_ran, ++$expected_from, 'from did run'; + is $to_storage_ran, $expected_to, 'to did not run'; } # test in-memory operations @@ -137,6 +205,7 @@ for my $artist_maker ( sub { $schema->resultset('Artist')->new({ charfield => 42 }) }, sub { my $art = $schema->resultset('Artist')->new({}); $art->charfield(42); $art }, ) { + $schema->resultset('Artist')->delete; my $expected_from = $from_storage_ran; my $expected_to = $to_storage_ran; @@ -150,6 +219,14 @@ for my $artist_maker ( ok( $artist->has_column_loaded('charfield'), 'Filtered column marked as loaded under new' ); is( $artist->charfield, 42, 'Proper unfiltered value' ); is( $artist->get_column('charfield'), 21, 'Proper filtered value' ); + + $artist->insert; + ($raw_db_charfield) = $schema->resultset('Artist') + ->search ($artist->ident_condition) + ->get_column('charfield') + ->next; + + is $raw_db_charfield, 21, 'Proper value in database'; } # test literals diff --git a/t/row/find_one_has_many.t b/t/row/find_one_has_many.t index ea7767f73..51d8db4ff 100644 --- a/t/row/find_one_has_many.t +++ b/t/row/find_one_has_many.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/row/inflate_result.t b/t/row/inflate_result.t index 3327b706f..b6503025a 100644 --- a/t/row/inflate_result.t +++ b/t/row/inflate_result.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; -use lib qw(t/lib); + use DBICTest; package My::Schema::Result::User; @@ -18,9 +20,8 @@ my $admin_class = __PACKAGE__ . '::Admin'; __PACKAGE__->table('users'); __PACKAGE__->add_columns( - qw/user_id email password - firstname lastname active - admin/ + user_id => { retrieve_on_insert => 1 }, + qw( email password firstname lastname active admin ), ); __PACKAGE__->set_primary_key('user_id'); @@ -58,7 +59,7 @@ sub do_admin_stuff { package My::Schema; -use base qw/DBIx::Class::Schema/; +use base qw/DBICTest::BaseSchema/; My::Schema->register_class( Admin => 'My::Schema::Result::User::Admin' ); My::Schema->register_class( User => 'My::Schema::Result::User' ); diff --git a/t/row/pkless.t b/t/row/pkless.t index ac090deb4..f11f31cc4 100644 --- a/t/row/pkless.t +++ b/t/row/pkless.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/row/set_extra_column.t b/t/row/set_extra_column.t index 0debaaf5b..cd953057a 100644 --- a/t/row/set_extra_column.t +++ b/t/row/set_extra_column.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/row/sourceless.t b/t/row/sourceless.t index 85ae3eeae..4da089966 100644 --- a/t/row/sourceless.t +++ b/t/row/sourceless.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $row = DBICTest::Schema::CD->new({ title => 'foo' }); diff --git a/t/schema/anon.t b/t/schema/anon.t index 4d74aceb2..18b04b58b 100644 --- a/t/schema/anon.t +++ b/t/schema/anon.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; lives_ok (sub { diff --git a/t/schema/clone.t b/t/schema/clone.t index 86b7a47d8..877da18e5 100644 --- a/t/schema/clone.t +++ b/t/schema/clone.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/search/distinct.t b/t/search/distinct.t index 4a8026769..08c67172e 100644 --- a/t/search/distinct.t +++ b/t/search/distinct.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/search/empty_attrs.t b/t/search/empty_attrs.t index 3b5248736..cb4cff738 100644 --- a/t/search/empty_attrs.t +++ b/t/search/empty_attrs.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/search/preserve_original_rs.t b/t/search/preserve_original_rs.t index 9f6704f35..9a087e720 100644 --- a/t/search/preserve_original_rs.t +++ b/t/search/preserve_original_rs.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::_Util 'serialize'; diff --git a/t/search/reentrancy.t b/t/search/reentrancy.t index 879060322..ad4b4e5d6 100644 --- a/t/search/reentrancy.t +++ b/t/search/reentrancy.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/search/related_has_many.t b/t/search/related_has_many.t index 91b1fb7da..572aebfa7 100644 --- a/t/search/related_has_many.t +++ b/t/search/related_has_many.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/search/related_strip_prefetch.t b/t/search/related_strip_prefetch.t index 5e34fe980..cf80061bc 100644 --- a/t/search/related_strip_prefetch.t +++ b/t/search/related_strip_prefetch.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/search/select_chains.t b/t/search/select_chains.t index ed8f23b45..31692d3d0 100644 --- a/t/search/select_chains.t +++ b/t/search/select_chains.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/search/select_chains_unbalanced.t b/t/search/select_chains_unbalanced.t index 63de73cf9..471cae2ae 100644 --- a/t/search/select_chains_unbalanced.t +++ b/t/search/select_chains_unbalanced.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/search/stack_cond.t b/t/search/stack_cond.t index 9a0e8062b..6989c6fdd 100644 --- a/t/search/stack_cond.t +++ b/t/search/stack_cond.t @@ -1,14 +1,14 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + +use DBIx::Class::_Util 'dump_value'; use DBICTest ':DiffSQL'; use SQL::Abstract qw(is_plain_value is_literal_value); use List::Util 'shuffle'; -use Data::Dumper; -$Data::Dumper::Terse = 1; -$Data::Dumper::Useqq = 1; $Data::Dumper::Indent = 0; my $schema = DBICTest->init_schema(); @@ -72,9 +72,7 @@ for my $c ( SELECT me.title FROM cd me WHERE - ( genreid != 42 OR genreid IS NULL ) - AND - ( genreid != 42 OR genreid IS NULL ) + ( genreid IS NULL OR genreid != 42 ) AND title != bar AND @@ -85,7 +83,7 @@ for my $c ( year $c->{sql} )", \@bind, - 'Double condition correctly collapsed for steps' . Dumper \@query_steps, + 'Double condition correctly collapsed for steps:' . join( '', map { "\n\t" . dump_value($_) } @query_steps ), ); } diff --git a/t/search/subquery.t b/t/search/subquery.t index 8c3fcf777..8b785e4f0 100644 --- a/t/search/subquery.t +++ b/t/search/subquery.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; use DBIx::Class::_Util 'sigwarn_silencer'; diff --git a/t/sqlmaker/bind_transport.t b/t/sqlmaker/bind_transport.t index 30971914d..93b3c1655 100644 --- a/t/sqlmaker/bind_transport.t +++ b/t/sqlmaker/bind_transport.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -5,7 +7,7 @@ use Test::More; use Test::Exception; use Math::BigInt; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; @@ -16,6 +18,17 @@ my ($ROWS, $OFFSET) = ( my $schema = DBICTest->init_schema(); +$schema->is_executed_sql_bind( + sub { $schema->resultset('Artist')->find( Math::BigInt->new(42) ) }, + [ + [ + 'SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE me.artistid = ?', + [ { dbic_colname => "me.artistid", sqlt_datatype => "integer" } + => Math::BigInt->new(42) ], + ] + ] +); + my $rs = $schema->resultset('CD')->search({ -and => [ 'me.artist' => { '!=', '666' }, 'me.artist' => { '!=', \[ '?', [ _ne => 'bar' ] ] }, diff --git a/t/sqlmaker/core.t b/t/sqlmaker/core.t index 1c2a1c35c..4e19ed783 100644 --- a/t/sqlmaker/core.t +++ b/t/sqlmaker/core.t @@ -1,10 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(no_deploy => 1); diff --git a/t/sqlmaker/core_quoted.t b/t/sqlmaker/core_quoted.t index 8e455660d..86820931d 100644 --- a/t/sqlmaker/core_quoted.t +++ b/t/sqlmaker/core_quoted.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; +use Test::Warn; -use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); @@ -352,4 +354,15 @@ is_same_sql_bind( 'bracket quoted table names for UPDATE' ); + +# Warning and sane behavior on ... select => [] ... +warnings_exist { + local $TODO = "Some day we need to stop issuing implicit SELECT *"; + is_same_sql_bind( + $schema->resultset("Artist")->search({}, { columns => [] })->as_query, + '( SELECT 42 FROM [artist] [me] )', + [], + ); +} qr/\QResultSets with an empty selection are deprecated (you almost certainly did not mean to do that): if this is indeed your intent you must explicitly supply/; + done_testing; diff --git a/t/sqlmaker/hierarchical/oracle.t b/t/sqlmaker/hierarchical/oracle.t index 3495e85a4..62e6776cb 100644 --- a/t/sqlmaker/hierarchical/oracle.t +++ b/t/sqlmaker/hierarchical/oracle.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'id_shortener'; use strict; @@ -5,7 +6,6 @@ use warnings; use Test::More; -use lib qw(t/lib); use DBICTest::Schema::Artist; BEGIN { DBICTest::Schema::Artist->add_column('parentid'); diff --git a/t/sqlmaker/legacy_joins.t b/t/sqlmaker/legacy_joins.t index 1c93c3596..2ecc0effd 100644 --- a/t/sqlmaker/legacy_joins.t +++ b/t/sqlmaker/legacy_joins.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::_Util 'sigwarn_silencer'; diff --git a/t/sqlmaker/limit_dialects/basic.t b/t/sqlmaker/limit_dialects/basic.t index 7098f1d06..85872bbe7 100644 --- a/t/sqlmaker/limit_dialects/basic.t +++ b/t/sqlmaker/limit_dialects/basic.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/sqlmaker/limit_dialects/custom.t b/t/sqlmaker/limit_dialects/custom.t index 89c4788bc..da6da39f4 100644 --- a/t/sqlmaker/limit_dialects/custom.t +++ b/t/sqlmaker/limit_dialects/custom.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; # This is legacy stuff from SQL::Absract::Limit diff --git a/t/sqlmaker/limit_dialects/fetch_first.t b/t/sqlmaker/limit_dialects/fetch_first.t index ab3e17034..625a46470 100644 --- a/t/sqlmaker/limit_dialects/fetch_first.t +++ b/t/sqlmaker/limit_dialects/fetch_first.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema; diff --git a/t/sqlmaker/limit_dialects/first_skip.t b/t/sqlmaker/limit_dialects/first_skip.t index acaf770ef..5eff5858e 100644 --- a/t/sqlmaker/limit_dialects/first_skip.t +++ b/t/sqlmaker/limit_dialects/first_skip.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/sqlmaker/limit_dialects/generic_subq.t b/t/sqlmaker/limit_dialects/generic_subq.t index 2d4bedad2..916ef35af 100644 --- a/t/sqlmaker/limit_dialects/generic_subq.t +++ b/t/sqlmaker/limit_dialects/generic_subq.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use List::Util 'min'; use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/sqlmaker/limit_dialects/mssql_torture.t b/t/sqlmaker/limit_dialects/mssql_torture.t index e45295344..67cdbcd40 100644 --- a/t/sqlmaker/limit_dialects/mssql_torture.t +++ b/t/sqlmaker/limit_dialects/mssql_torture.t @@ -1,7 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; my $OFFSET = DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype; diff --git a/t/sqlmaker/limit_dialects/rno.t b/t/sqlmaker/limit_dialects/rno.t index b3177926e..4cbe91f3d 100644 --- a/t/sqlmaker/limit_dialects/rno.t +++ b/t/sqlmaker/limit_dialects/rno.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/sqlmaker/limit_dialects/rownum.t b/t/sqlmaker/limit_dialects/rownum.t index 806bba493..b7bb9df5c 100644 --- a/t/sqlmaker/limit_dialects/rownum.t +++ b/t/sqlmaker/limit_dialects/rownum.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/sqlmaker/limit_dialects/skip_first.t b/t/sqlmaker/limit_dialects/skip_first.t index a87b95e43..91f1f9898 100644 --- a/t/sqlmaker/limit_dialects/skip_first.t +++ b/t/sqlmaker/limit_dialects/skip_first.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/sqlmaker/limit_dialects/toplimit.t b/t/sqlmaker/limit_dialects/toplimit.t index 3fb03d9eb..e1c40b853 100644 --- a/t/sqlmaker/limit_dialects/toplimit.t +++ b/t/sqlmaker/limit_dialects/toplimit.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema; diff --git a/t/sqlmaker/limit_dialects/torture.t b/t/sqlmaker/limit_dialects/torture.t index 4dac672e9..03c8822a1 100644 --- a/t/sqlmaker/limit_dialects/torture.t +++ b/t/sqlmaker/limit_dialects/torture.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::_Util 'deep_clone'; diff --git a/t/sqlmaker/literal_with_bind.t b/t/sqlmaker/literal_with_bind.t index 1024a62b9..a3dbcc716 100644 --- a/t/sqlmaker/literal_with_bind.t +++ b/t/sqlmaker/literal_with_bind.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(no_populate => 1); diff --git a/t/sqlmaker/msaccess.t b/t/sqlmaker/msaccess.t index 179b3f31e..8797b1e62 100644 --- a/t/sqlmaker/msaccess.t +++ b/t/sqlmaker/msaccess.t @@ -1,7 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; # the entire point of the subclass is that parenthesis have to be diff --git a/t/sqlmaker/mysql.t b/t/sqlmaker/mysql.t index 0e2ad2961..f1e3bfb23 100644 --- a/t/sqlmaker/mysql.t +++ b/t/sqlmaker/mysql.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest::Schema->connect (DBICTest->_database, { quote_char => '`' }); diff --git a/t/sqlmaker/nest_deprec.t b/t/sqlmaker/nest_deprec.t index a6edeeec3..6d430ca3f 100644 --- a/t/sqlmaker/nest_deprec.t +++ b/t/sqlmaker/nest_deprec.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); @@ -15,7 +17,7 @@ my $sql_maker = $schema->storage->sql_maker; for my $expect_warn (1, 0) { warnings_like ( sub { - my ($sql, @bind) = $sql_maker->select ('foo', undef, { -nest => \ 'bar' } ); + my ($sql, @bind) = $sql_maker->select ('foo', '*', { -nest => \ 'bar' } ); is_same_sql_bind ( $sql, \@bind, 'SELECT * FROM foo WHERE ( bar )', [], diff --git a/t/sqlmaker/oracle.t b/t/sqlmaker/oracle.t index cd3e629c6..0fef7fba7 100644 --- a/t/sqlmaker/oracle.t +++ b/t/sqlmaker/oracle.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'id_shortener'; use strict; @@ -5,8 +6,8 @@ use warnings; use Test::More; use Test::Exception; -use Data::Dumper::Concise; -use lib qw(t/lib); + +use DBIx::Class::_Util 'dump_value'; use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::Oracle; @@ -67,7 +68,7 @@ for my $case (@handle_tests) { sub { ( $stmt, @bind ) = $sqla_oracle->_recurse_where( $case->{connect_by} ); is_same_sql_bind( $stmt, \@bind, $case->{stmt}, $case->{bind},$msg ) - || diag "Search term:\n" . Dumper $case->{connect_by}; + || diag "Search term:\n" . dump_value $case->{connect_by}; } ,sprintf("lives is ok from '%s'",$msg)); } diff --git a/t/sqlmaker/oraclejoin.t b/t/sqlmaker/oraclejoin.t index 11298b026..de49bbfbb 100644 --- a/t/sqlmaker/oraclejoin.t +++ b/t/sqlmaker/oraclejoin.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'id_shortener'; use strict; @@ -5,7 +6,6 @@ use warnings; use Test::More; -use lib qw(t/lib); use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::OracleJoins; diff --git a/t/sqlmaker/order_by_bindtransport.t b/t/sqlmaker/order_by_bindtransport.t index 24da80ed9..08afe42e9 100644 --- a/t/sqlmaker/order_by_bindtransport.t +++ b/t/sqlmaker/order_by_bindtransport.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use Data::Dumper::Concise; -use lib qw(t/lib); + +use DBIx::Class::_Util 'dump_value'; use DBICTest ':DiffSQL'; sub test_order { @@ -41,7 +43,7 @@ sub test_order { ? map { [ { dbic_colname => $_->[0] } => $_->[1] ] } @{ $args->{bind} } : () ], - ) || diag Dumper $args->{order_by}; + ) || diag dump_value $args->{order_by}; }; } diff --git a/t/sqlmaker/order_by_func.t b/t/sqlmaker/order_by_func.t index 96092195b..3ba4a17b5 100644 --- a/t/sqlmaker/order_by_func.t +++ b/t/sqlmaker/order_by_func.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/sqlmaker/pg.t b/t/sqlmaker/pg.t new file mode 100644 index 000000000..83a6fe950 --- /dev/null +++ b/t/sqlmaker/pg.t @@ -0,0 +1,78 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; + +use DBICTest ':DiffSQL'; + +my $schema = DBICTest->init_schema( + no_deploy => 1, + quote_names => 1, + storage_type => 'DBIx::Class::Storage::DBI::Pg' +); + +my $rs = $schema->resultset('Artist')->search_related('cds_unordered', + { "me.rank" => 13 }, + { + prefetch => 'tracks', + join => 'genre', + order_by => [ 'genre.name', { -desc => \ 'tracks.title' }, { -asc => "me.name" }, { -desc => [qw(year cds_unordered.title)] } ], # me. is the artist, *NOT* the cd + rows => 1, + }, +); + +{ + # THIS IS AN OFFLINE TEST + # We only need this so that the thing can be verified to work without PG_DSN + # Executing it while "lying" this way won't work + local $rs->result_source->related_source('tracks')->column_info('title')->{data_type} = 'bool'; + local $rs->result_source->related_source('genre')->column_info('name')->{data_type} = 'BOOLEAN'; + + is_same_sql_bind( + $rs->as_query, + q{( + SELECT "cds_unordered"."cdid", "cds_unordered"."artist", "cds_unordered"."title", "cds_unordered"."year", "cds_unordered"."genreid", "cds_unordered"."single_track", + "tracks"."trackid", "tracks"."cd", "tracks"."position", "tracks"."title", "tracks"."last_updated_on", "tracks"."last_updated_at" + FROM "artist" "me" + JOIN ( + SELECT "cds_unordered"."cdid", "cds_unordered"."artist", "cds_unordered"."title", "cds_unordered"."year", "cds_unordered"."genreid", "cds_unordered"."single_track" + FROM "artist" "me" + JOIN cd "cds_unordered" + ON "cds_unordered"."artist" = "me"."artistid" + LEFT JOIN "genre" "genre" + ON "genre"."genreid" = "cds_unordered"."genreid" + LEFT JOIN "track" "tracks" + ON "tracks"."cd" = "cds_unordered"."cdid" + WHERE "me"."rank" = ? + GROUP BY "cds_unordered"."cdid", "cds_unordered"."artist", "cds_unordered"."title", "cds_unordered"."year", "cds_unordered"."genreid", "cds_unordered"."single_track", "me"."name" + ORDER BY BOOL_AND("genre"."name"), + BOOL_OR( tracks.title ) DESC, + "me"."name" ASC, + "year" DESC, + "cds_unordered"."title" DESC + LIMIT ? + ) "cds_unordered" + ON "cds_unordered"."artist" = "me"."artistid" + LEFT JOIN "genre" "genre" + ON "genre"."genreid" = "cds_unordered"."genreid" + LEFT JOIN "track" "tracks" + ON "tracks"."cd" = "cds_unordered"."cdid" + WHERE "me"."rank" = ? + ORDER BY "genre"."name", + tracks.title DESC, + "me"."name" ASC, + "year" DESC, + "cds_unordered"."title" DESC + )}, + [ + [ { sqlt_datatype => 'integer', dbic_colname => 'me.rank' } => 13 ], + [ DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype => 1 ], + [ { sqlt_datatype => 'integer', dbic_colname => 'me.rank' } => 13 ], + ], + 'correct SQL with aggregate boolean order on Pg', + ); +} + +done_testing; diff --git a/t/sqlmaker/quotes.t b/t/sqlmaker/quotes.t index 4a5357b7d..f76ffb9ad 100644 --- a/t/sqlmaker/quotes.t +++ b/t/sqlmaker/quotes.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema( no_deploy => 1 ); diff --git a/t/sqlmaker/sqlite.t b/t/sqlmaker/sqlite.t index 9c0b904d4..1c948c5f5 100644 --- a/t/sqlmaker/sqlite.t +++ b/t/sqlmaker/sqlite.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema; diff --git a/t/storage/base.t b/t/storage/base.t index b7650a875..df59e9127 100644 --- a/t/storage/base.t +++ b/t/storage/base.t @@ -1,12 +1,14 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; -use Data::Dumper; +use DBIx::Class::_Util 'dump_value'; my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); @@ -16,7 +18,7 @@ is( ref($storage), 'DBIx::Class::Storage::DBI::SQLite', 'Storage reblessed correctly into DBIx::Class::Storage::DBI::SQLite' -) unless $ENV{DBICTEST_VIA_REPLICATED}; +) unless $storage->isa('DBIx::Class::Storage::DBI::Replicated'); throws_ok { $schema->storage->throw_exception('test_exception_42'); @@ -54,7 +56,6 @@ throws_ok { }; } - # testing various invocations of connect_info ([ ... ]) my $coderef = sub { 42 }; @@ -155,8 +156,7 @@ for my $type (keys %$invocations) { # we can not use a cloner portably because of the coderef # so compare dumps instead - local $Data::Dumper::Sortkeys = 1; - my $arg_dump = Dumper ($invocations->{$type}{args}); + my $arg_dump = dump_value $invocations->{$type}{args}; warnings_exist ( sub { $storage->connect_info ($invocations->{$type}{args}) }, @@ -164,7 +164,11 @@ for my $type (keys %$invocations) { 'Warned about ignored attributes', ); - is ($arg_dump, Dumper ($invocations->{$type}{args}), "$type didn't modify passed arguments"); + is ( + $arg_dump, + dump_value $invocations->{$type}{args}, + "$type didn't modify passed arguments", + ); is_deeply ($storage->_dbi_connect_info, $invocations->{$type}{dbi_connect_info}, "$type produced correct _dbi_connect_info"); ok ( (not $storage->auto_savepoint and not $storage->unsafe), "$type correctly ignored extra hashref"); @@ -179,7 +183,8 @@ for my $type (keys %$invocations) { # make sure connection-less storages do not throw on _determine_driver # but work with ENV at the same time SKIP: for my $env_dsn (undef, (DBICTest->_database)[0] ) { - skip 'Subtest relies on being connected to SQLite', 1 + + skip 'This set of tests relies on being connected to SQLite', 1 if $env_dsn and $env_dsn !~ /\:SQLite\:/; local $ENV{DBI_DSN} = $env_dsn || ''; diff --git a/t/storage/cursor.t b/t/storage/cursor.t index ce0be84a0..96f917e1a 100644 --- a/t/storage/cursor.t +++ b/t/storage/cursor.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); +use DBIx::Class::Optional::Dependencies; use DBICTest; my $schema = DBICTest->init_schema(cursor_class => 'DBICTest::Cursor'); diff --git a/t/storage/dbh_do.t b/t/storage/dbh_do.t index 727c245ef..07453eaf9 100644 --- a/t/storage/dbh_do.t +++ b/t/storage/dbh_do.t @@ -1,17 +1,17 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); my $storage = $schema->storage; - $storage = $storage->master - if $ENV{DBICTEST_VIA_REPLICATED}; - + if $storage->isa('DBIx::Class::Storage::DBI::Replicated'); # test (re)connection for my $disconnect (0, 1) { diff --git a/t/storage/dbi_coderef.t b/t/storage/dbi_coderef.t index b5b7961a2..9408417b5 100644 --- a/t/storage/dbi_coderef.t +++ b/t/storage/dbi_coderef.t @@ -1,8 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; +BEGIN { $ENV{DBICTEST_VIA_REPLICATED} = 0 } + use Test::More; -use lib qw(t/lib); + use DBICTest; plan tests => 1; diff --git a/t/storage/dbi_env.t b/t/storage/dbi_env.t index 462da111f..7b9ccc832 100644 --- a/t/storage/dbi_env.t +++ b/t/storage/dbi_env.t @@ -1,6 +1,8 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib qw(t/lib); + use DBICTest; use Test::More; use Test::Exception; @@ -77,6 +79,10 @@ $schema = DBICTest::Schema->connect("dbi:SQLite:$dbname"); lives_ok { count_sheep($schema) } 'SQLite passed to connect_info'; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite'; +$schema = DBICTest::Schema->connect("dbi:SQLite(ReadOnly=1):$dbname"); +lives_ok { count_sheep($schema) } 'SQLite passed to connect_info despite extra arguments present'; +isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite'; + $ENV{DBI_DRIVER} = 'SQLite'; $schema = DBICTest::Schema->connect("dbi::$dbname"); lives_ok { count_sheep($schema) } 'SQLite in DBI_DRIVER'; diff --git a/t/storage/dbic_pretty.t b/t/storage/dbic_pretty.t index 1a1c32ef3..89f12dd39 100644 --- a/t/storage/dbic_pretty.t +++ b/t/storage/dbic_pretty.t @@ -1,9 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_prettydebug'; use strict; use warnings; -use lib qw(t/lib); + use DBICTest; use Test::More; diff --git a/t/storage/debug.t b/t/storage/debug.t index 3f5d39972..d0a6b4f7b 100644 --- a/t/storage/debug.t +++ b/t/storage/debug.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; no warnings 'once'; @@ -12,44 +14,45 @@ BEGIN { } use Test::More; -use Test::Exception; -use Try::Tiny; use File::Spec; -use lib qw(t/lib); + use DBICTest; -use Path::Class qw/file/; +use DBICTest::Util 'slurp_bytes'; +use DBIx::Class::_Util 'scope_guard'; my $schema = DBICTest->init_schema(); -my $lfn = file("t/var/sql-$$.log"); -unlink $lfn or die $! - if -e $lfn; +my $log_fn = "t/var/sql-$$.log"; +unlink $log_fn or die $! if -e $log_fn; # make sure we are testing the vanilla debugger and not ::PrettyPrint require DBIx::Class::Storage::Statistics; $schema->storage->debugobj(DBIx::Class::Storage::Statistics->new); ok ( $schema->storage->debug(1), 'debug' ); -$schema->storage->debugfh($lfn->openw); -$schema->storage->debugfh->autoflush(1); -$schema->resultset('CD')->count; +{ + open my $dbgfh, '>', $log_fn or die $!; + $schema->storage->debugfh($dbgfh); + $schema->storage->debugfh->autoflush(1); + $schema->resultset('CD')->count; + $schema->storage->debugfh(undef); +} -my @loglines = $lfn->slurp; +my @loglines = slurp_bytes $log_fn; is (@loglines, 1, 'one line of log'); like($loglines[0], qr/^SELECT COUNT/, 'File log via debugfh success'); -$schema->storage->debugfh(undef); { - local $ENV{DBIC_TRACE} = "=$lfn"; - unlink $lfn; + local $ENV{DBIC_TRACE} = "=$log_fn"; + unlink $log_fn; $schema->resultset('CD')->count; my $schema2 = DBICTest->init_schema(no_deploy => 1); $schema2->storage->_do_query('SELECT 1'); # _do_query() logs via standard mechanisms - my @loglines = $lfn->slurp; + my @loglines = slurp_bytes $log_fn; is(@loglines, 2, '2 lines of log'); like($loglines[0], qr/^SELECT COUNT/, 'Env log from schema1 success'); like($loglines[1], qr/^SELECT 1:/, 'Env log from schema2 success'); @@ -58,22 +61,23 @@ $schema->storage->debugfh(undef); } END { - unlink $lfn; + unlink $log_fn if $log_fn; } open(STDERRCOPY, '>&STDERR'); my $exception_line_number; # STDERR will be closed, no T::B diag in blocks -my $exception = try { +my $exception = do { + my $restore_guard = scope_guard { open(STDERR, '>&STDERRCOPY') }; close(STDERR); - $exception_line_number = __LINE__ + 1; # important for test, do not reformat - $schema->resultset('CD')->search({})->count; -} catch { - $_ -} finally { - # restore STDERR - open(STDERR, '>&STDERRCOPY'); + + eval { + $exception_line_number = __LINE__ + 1; # important for test, do not reformat + $schema->resultset('CD')->search({})->count; + }; + + my $err = $@; }; ok $exception =~ / @@ -83,19 +87,19 @@ ok $exception =~ / /xms or diag "Unexpected exception text:\n\n$exception\n"; + my @warnings; -$exception = try { +$exception = do { local $SIG{__WARN__} = sub { push @warnings, @_ if $_[0] =~ /character/i }; + my $restore_guard = scope_guard { close STDERR; open(STDERR, '>&STDERRCOPY') }; close STDERR; - open(STDERR, '>', File::Spec->devnull) or die $!; - $schema->resultset('CD')->search({ title => "\x{1f4a9}" })->count; - ''; -} catch { - $_; -} finally { - # restore STDERR - close STDERR; - open(STDERR, '>&STDERRCOPY'); + + eval { + open(STDERR, '>', File::Spec->devnull) or die $!; + $schema->resultset('CD')->search({ title => "\x{1f4a9}" })->count; + }; + + my $err = $@; }; die "How did that fail... $exception" diff --git a/t/storage/deploy.t b/t/storage/deploy.t index 3a1f66f85..eb317758c 100644 --- a/t/storage/deploy.t +++ b/t/storage/deploy.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'deploy'; use strict; @@ -5,10 +6,10 @@ use warnings; use Test::More; use Test::Exception; -use Path::Class qw/dir/; -use lib qw(t/lib); use DBICTest; +use DBICTest::Util qw( slurp_bytes rm_rf ); +use DBIx::Class::_Util 'mkdir_p'; local $ENV{DBI_DSN}; @@ -28,11 +29,11 @@ lives_ok( sub { my $schema = DBICTest->init_schema( quote_names => 1 ); -my $var = dir ("t/var/ddl_dir-$$"); -$var->mkpath unless -d $var; +my $var_dir = "t/var/ddl_dir-$$/"; +mkdir_p $var_dir unless -d $var_dir; -my $test_dir_1 = $var->subdir ('test1', 'foo', 'bar' ); -$test_dir_1->rmtree if -d $test_dir_1; +my $test_dir_1 = $var_dir . 'test1/foo/bar'; +rm_rf $test_dir_1 if -d $test_dir_1; $schema->create_ddl_dir( [qw(SQLite MySQL)], 1, $test_dir_1 ); ok( -d $test_dir_1, 'create_ddl_dir did a make_path on its target dir' ); @@ -49,16 +50,24 @@ for ( my $type = $_->[0]; my $q = quotemeta($_->[1]); - for my $f (map { $test_dir_1->file("DBICTest-Schema-${_}-$type.sql") } qw(1 2) ) { - like scalar $f->slurp, qr/CREATE TABLE ${q}track${q}/, "Proper quoting in $f"; + for my $f (map { $test_dir_1 . "/DBICTest-Schema-${_}-$type.sql" } qw(1 2) ) { + like ( + scalar slurp_bytes $f, + qr/CREATE TABLE ${q}track${q}/, + "Proper quoting in $f" + ); } { local $TODO = 'SQLT::Producer::MySQL has no knowledge of the mythical beast of quoting...' if $type eq 'MySQL'; - my $f = $test_dir_1->file("DBICTest-Schema-1-2-$type.sql"); - like scalar $f->slurp, qr/DROP TABLE ${q}bindtype_test${q}/, "Proper quoting in diff $f"; + my $f = $test_dir_1 . "/DBICTest-Schema-1-2-$type.sql"; + like ( + scalar slurp_bytes $f, + qr/DROP TABLE ${q}bindtype_test${q}/, + "Proper quoting in diff $f" + ); } } @@ -68,7 +77,7 @@ for ( } END { - $var->rmtree; + rm_rf $var_dir; } done_testing; diff --git a/t/storage/deprecated_exception_source_bind_attrs.t b/t/storage/deprecated_exception_source_bind_attrs.t index f6dca5a39..cba18bcb2 100644 --- a/t/storage/deprecated_exception_source_bind_attrs.t +++ b/t/storage/deprecated_exception_source_bind_attrs.t @@ -1,18 +1,18 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + 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 {} } } diff --git a/t/storage/disable_sth_caching.t b/t/storage/disable_sth_caching.t index 494780d63..5fc8e188e 100644 --- a/t/storage/disable_sth_caching.t +++ b/t/storage/disable_sth_caching.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; BEGIN { $ENV{DBICTEST_VIA_REPLICATED} = 0 } use Test::More; -use lib qw(t/lib); + use DBICTest; ##!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/t/storage/error.t b/t/storage/error.t index e01da7047..710ec22ca 100644 --- a/t/storage/error.t +++ b/t/storage/error.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -5,7 +7,7 @@ use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); +use DBICTest::Util 'PEEPEENESS'; use DBICTest; for my $conn_args ( @@ -22,7 +24,8 @@ for my $conn_args ( ); my $storage = $s->storage; - $storage = $storage->master if $ENV{DBICTEST_VIA_REPLICATED}; + $storage = $storage->master + if $storage->isa('DBIx::Class::Storage::DBI::Replicated'); ok( ! $storage->connected, 'Starting unconnected' ); @@ -47,7 +50,8 @@ for my $conn_args ( my $s = DBICTest->init_schema( no_deploy => 1, @$conn_args ); my $storage = $s->storage; - $storage = $storage->master if $ENV{DBICTEST_VIA_REPLICATED}; + $storage = $storage->master + if $storage->isa('DBIx::Class::Storage::DBI::Replicated'); my $desc = "broken on_disconnect action @{[ explain $conn_args ]}"; @@ -93,9 +97,8 @@ throws_ok ( # exception fallback: SKIP: { - if ( !!DBIx::Class::_ENV_::PEEPEENESS ) { - skip "Your perl version $] appears to leak like a sieve - skipping garbage collected \$schema test", 1; - } + skip "Your perl version $] appears to leak like a sieve - skipping garbage collected \$schema test", 1 + if PEEPEENESS; undef ($schema); throws_ok ( diff --git a/t/storage/exception.t b/t/storage/exception.t index d96e336cf..3de6aa95f 100644 --- a/t/storage/exception.t +++ b/t/storage/exception.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; use DBICTest::Schema; diff --git a/t/storage/global_destruction.t b/t/storage/global_destruction.t index 6bddfd75a..5b7fc8559 100644 --- a/t/storage/global_destruction.t +++ b/t/storage/global_destruction.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -8,30 +10,20 @@ BEGIN { $ENV{DBIC_STORAGE_RETRY_DEBUG} = 1 } use DBIx::Class::Optional::Dependencies (); -use lib qw(t/lib); + use DBICTest; for my $type (qw/PG MYSQL SQLite/) { SKIP: { + + DBIx::Class::Optional::Dependencies->skip_without( 'test_rdbms_' . lc $type ); + 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/} - } + ? ( DBICTest->_database(sqlite_use_file => 1) ) + : ( @ENV{map { "DBICTEST_${type}_${_}" } qw/DSN USER PASS/} ) ; - if ($type eq 'PG') { - skip "skipping Pg tests without dependencies installed", 1 - unless DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_pg'); - } - elsif ($type eq 'MYSQL') { - skip "skipping MySQL tests without dependencies installed", 1 - unless DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_mysql'); - } - my $schema = DBICTest::Schema->connect (@dsn); # emulate a singleton-factory, just cache the object *somewhere in a different package* diff --git a/t/storage/nobindvars.t b/t/storage/nobindvars.t index b22975638..61eb3d22d 100644 --- a/t/storage/nobindvars.t +++ b/t/storage/nobindvars.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; { # Fake storage driver for SQLite + no bind variables diff --git a/t/storage/on_connect_call.t b/t/storage/on_connect_call.t index 265835cc2..c88105539 100644 --- a/t/storage/on_connect_call.t +++ b/t/storage/on_connect_call.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; no warnings qw/once redefine/; -use lib qw(t/lib); + use DBI; use DBICTest; use DBICTest::Schema; diff --git a/t/storage/on_connect_do.t b/t/storage/on_connect_do.t index 6fccbb1ae..28a7e3ab8 100644 --- a/t/storage/on_connect_do.t +++ b/t/storage/on_connect_do.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -10,7 +12,7 @@ use Test::More tests => 13; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; require DBI; diff --git a/t/storage/ping_count.t b/t/storage/ping_count.t index 28af647fb..4d472e7b4 100644 --- a/t/storage/ping_count.t +++ b/t/storage/ping_count.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $ping_count = 0; diff --git a/t/storage/prefer_stringification.t b/t/storage/prefer_stringification.t index ffb292a05..e1d3aa05b 100644 --- a/t/storage/prefer_stringification.t +++ b/t/storage/prefer_stringification.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; -use lib qw(t/lib); + use DBICTest; { diff --git a/t/storage/quote_names.t b/t/storage/quote_names.t index ac65fa07b..215c01140 100644 --- a/t/storage/quote_names.t +++ b/t/storage/quote_names.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use Data::Dumper::Concise; -use Try::Tiny; -use lib qw(t/lib); + use DBICTest; +use DBIx::Class::_Util 'dump_value'; +$Data::Dumper::Indent = 0; my %expected = ( 'DBIx::Class::Storage::DBI' => @@ -50,14 +52,17 @@ my %expected = ( ); for my $class (keys %expected) { SKIP: { - eval "require ${class}" - or skip "Skipping test of quotes for $class due to missing dependencies", 1; + + eval "require ${class}" or do { + note "Failed load of $class:\n\n$@\n\n"; + skip "Skipping test of quotes for $class due to missing compile-time dependencies", 1; + }; my $mapping = $expected{$class}; my ($quote_char, $name_sep) = @$mapping{qw/quote_char name_sep/}; my $instance = $class->new; - my $quote_char_text = dumper($quote_char); + my $quote_char_text = dump_value $quote_char; if (exists $mapping->{quote_char}) { is_deeply $instance->sql_quote_char, $quote_char, @@ -106,7 +111,7 @@ for my $db (sort { my $schema; - my $sql_maker = try { + my $sql_maker = eval { $schema = DBICTest::Schema->connect($dsn, $user, $pass, { quote_names => 1 }); @@ -117,7 +122,7 @@ for my $db (sort { my ($exp_quote_char, $exp_name_sep) = @{$expected{$dbs{$db}}}{qw/quote_char name_sep/}; - my ($quote_char_text, $name_sep_text) = map { dumper($_) } + my ($quote_char_text, $name_sep_text) = map { dump_value $_ } ($exp_quote_char, $exp_name_sep); is_deeply $sql_maker->quote_char, @@ -134,7 +139,7 @@ for my $db (sort { # the SQLT producer has no idea what quotes are :/ ! grep { $db eq $_ } qw( SYBASE DB2 ) and - my $ddl = try { $schema->deployment_statements } + my $ddl = eval { $schema->deployment_statements } ) { my $quoted_artist = $sql_maker->_quote('artist'); @@ -143,13 +148,3 @@ for my $db (sort { } done_testing; - -sub dumper { - my $val = shift; - - my $dd = DumperObject; - $dd->Indent(0); - return $dd->Values([ $val ])->Dump; -} - -1; diff --git a/t/storage/reconnect.t b/t/storage/reconnect.t index fc97ebd40..9c1c564e8 100644 --- a/t/storage/reconnect.t +++ b/t/storage/reconnect.t @@ -1,13 +1,13 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use FindBin; use B::Deparse; -use File::Copy 'move'; use Scalar::Util 'weaken'; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $db_orig = DBICTest->_sqlite_dbfilename; @@ -16,12 +16,22 @@ my $db_tmp = "$db_orig.tmp"; # Set up the "usual" sqlite for DBICTest my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); -my $exception_action_count; -$schema->exception_action(sub { - $exception_action_count++; +my $exception_callback_count; +my $ea = $schema->exception_action(sub { + $exception_callback_count++; die @_; }); + +# No, this is not a great idea. +# Yes, people do it anyway. +# Might as well test that we have fixed it for good, by never invoking +# a potential __DIE__ handler in internal_try() stacks. In cases of regular +# exceptions we expect *both* the exception action *AND* the __DIE__ to +# fire once +$SIG{__DIE__} = sub { &$ea }; + + # Make sure we're connected by doing something my @art = $schema->resultset("Artist")->search({ }, { order_by => { -desc => 'name' }}); cmp_ok(@art, '==', 3, "Three artists returned"); @@ -46,7 +56,7 @@ cmp_ok(@art_two, '==', 3, "Three artists returned"); ### Now, disconnect the dbh, and move the db file; # create a new one full of garbage, prevent SQLite from connecting. $schema->storage->_dbh->disconnect; -move( $db_orig, $db_tmp ) +rename( $db_orig, $db_tmp ) or die "failed to move $db_orig to $db_tmp: $!"; open my $db_file, '>', $db_orig; print $db_file 'THIS IS NOT A REAL DATABASE'; @@ -65,7 +75,7 @@ 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: $!"; -move( $db_tmp, $db_orig ) +rename( $db_tmp, $db_orig ) or die "could not move $db_tmp to $db_orig: $!"; ### Try the operation again... this time, it should succeed @@ -98,7 +108,7 @@ for my $ctx (keys %$ctx_map) { # start disconnected and then connected $schema->storage->disconnect; - $exception_action_count = 0; + $exception_callback_count = 0; for (1, 2) { my $disarmed; @@ -115,7 +125,7 @@ for my $ctx (keys %$ctx_map) { }, @$args) }); } - is( $exception_action_count, 0, 'exception_action never called' ); + is( $exception_callback_count, 0, 'neither exception_action nor $SIG{__DIE__} ever called' ); }; # make sure RT#110429 does not recur on manual DBI-side disconnect @@ -149,7 +159,7 @@ for my $cref ( note( "Testing with " . B::Deparse->new->coderef2text($cref) ); $schema->storage->disconnect; - $exception_action_count = 0; + $exception_callback_count = 0; ok( !$schema->storage->connected, 'Not connected' ); @@ -164,13 +174,13 @@ for my $cref ( is( $schema->storage->transaction_depth, undef, "Depth expectedly unknown after failed rollbacks" ); - is( $exception_action_count, 1, "exception_action called only once" ); + is( $exception_callback_count, 2, 'exception_action and $SIG{__DIE__} called only once each' ); } # check exception_action under tenacious disconnect { $schema->storage->disconnect; - $exception_action_count = 0; + $exception_callback_count = 0; throws_ok { $schema->txn_do(sub { $schema->storage->_dbh->disconnect; @@ -178,7 +188,7 @@ for my $cref ( $schema->resultset('Artist')->next; })} qr/prepare on inactive database handle/; - is( $exception_action_count, 1, "exception_action called only once" ); + is( $exception_callback_count, 2, 'exception_action and $SIG{__DIE__} called only once each' ); } # check that things aren't crazy with a non-violent disconnect diff --git a/t/storage/replicated.t b/t/storage/replicated.t index 82c809d30..59bf7e575 100644 --- a/t/storage/replicated.t +++ b/t/storage/replicated.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_replicated'; use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use DBIx::Class::_Util 'modver_gt_or_eq_and_lt'; -use lib qw(t/lib); + use DBICTest; BEGIN { @@ -18,14 +19,12 @@ BEGIN { use Test::Moose; use Test::Exception; -use List::Util 'first'; use Scalar::Util 'reftype'; -use File::Spec; use Moose(); use MooseX::Types(); note "Using Moose version $Moose::VERSION and MooseX::Types version $MooseX::Types::VERSION"; -my $var_dir = quotemeta ( File::Spec->catdir(qw/t var/) ); +my $var_dir_re = qr{ t [\/\\] var [\/\\] }x; ## Add a connect_info option to test option merging. use DBIx::Class::Storage::DBI::Replicated; @@ -156,8 +155,8 @@ TESTSCHEMACLASSES: { $self->master_path( DBICTest->_sqlite_dbfilename ); $self->slave_paths([ - File::Spec->catfile(qw/t var DBIxClass_slave1.db/), - File::Spec->catfile(qw/t var DBIxClass_slave2.db/), + 't/var/DBIxClass_slave1.db', + 't/var/DBIxClass_slave2.db', ]); return $self; @@ -375,7 +374,7 @@ ok @replicant_names, "found replicant names @replicant_names"; ## Silence warning about not supporting the is_replicating method if using the ## sqlite dbs. $replicated->schema->storage->debugobj->silence(1) - if first { $_ =~ /$var_dir/ } @replicant_names; + if grep { $_ =~ $var_dir_re } @replicant_names; isa_ok $replicated->schema->storage->balancer->current_replicant => 'DBIx::Class::Storage::DBI'; @@ -423,7 +422,7 @@ $replicated->schema->storage->replicants->{$replicant_names[1]}->active(1); ## Silence warning about not supporting the is_replicating method if using the ## sqlite dbs. $replicated->schema->storage->debugobj->silence(1) - if first { $_ =~ /$var_dir/ } @replicant_names; + if grep { $_ =~ $var_dir_re } @replicant_names; $replicated->schema->storage->pool->validate_replicants; @@ -606,7 +605,7 @@ $replicated->schema->storage->replicants->{$replicant_names[1]}->active(1); ## Silence warning about not supporting the is_replicating method if using the ## sqlite dbs. $replicated->schema->storage->debugobj->silence(1) - if first { $_ =~ /$var_dir/ } @replicant_names; + if grep { $_ =~ $var_dir_re } @replicant_names; $replicated->schema->storage->pool->validate_replicants; @@ -710,9 +709,19 @@ ok my $reliably = sub { is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; + $_[1] = 9; + } => 'created coderef properly'; -$replicated->schema->storage->execute_reliably($reliably); +my @list_to_mangle = (1, 2, 3); + +$replicated->schema->storage->execute_reliably($reliably, @list_to_mangle); + +is_deeply + \@list_to_mangle, + [ 1, 9, 3], + 'Aliasing of values passed to execute_reliably works' +; ## Try something with an error @@ -727,6 +736,12 @@ throws_ok {$replicated->schema->storage->execute_reliably($unreliably)} qr/Can't find source for ArtistXX/ => 'Bad coderef throws proper error'; +throws_ok { + $replicated->schema->storage->execute_reliably(sub{ + die bless [], 'SomeExceptionThing'; + }); +} 'SomeExceptionThing', "Blessed exception kept intact"; + ## Make sure replication came back ok $replicated->schema->resultset('Artist')->find(3) diff --git a/t/storage/savepoints.t b/t/storage/savepoints.t index b0f3858c0..8960a5e5e 100644 --- a/t/storage/savepoints.t +++ b/t/storage/savepoints.t @@ -1,11 +1,14 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use DBIx::Class::_Util qw(modver_gt_or_eq sigwarn_silencer scope_guard); +use DBIx::Class::Optional::Dependencies; +use DBIx::Class::_Util qw(sigwarn_silencer scope_guard); +use Scalar::Util 'weaken'; -use lib qw(t/lib); use DBICTest; { @@ -35,13 +38,10 @@ for ('', keys %$env2optdep) { SKIP: { my $prefix; if ($prefix = $_) { - my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; - skip ("Skipping tests with $prefix: set \$ENV{${prefix}_DSN} _USER and _PASS", 1) - unless $dsn; + DBIx::Class::Optional::Dependencies->skip_without($env2optdep->{$prefix}); - 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}); + my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; $schema = DBICTest::Schema->connect ($dsn,$user,$pass,{ auto_savepoint => 1 }); @@ -228,15 +228,6 @@ for ('', keys %$env2optdep) { SKIP: { is_deeply( $schema->storage->savepoints, [], 'All savepoints forgotten' ); -SKIP: { - skip "Reading inexplicably fails on very old replicated DBD::SQLite<1.33", 1 if ( - $ENV{DBICTEST_VIA_REPLICATED} - and - $prefix eq 'SQLite Internal DB' - and - ! modver_gt_or_eq('DBD::SQLite', '1.33') - ); - ok($ars->search({ name => 'in_outer_transaction' })->first, 'commit from outer transaction'); ok($ars->search({ name => 'in_outer_transaction2' })->first, @@ -246,7 +237,20 @@ SKIP: { is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first, undef, 'rollback from inner transaction'; -} + + # make sure a fresh txn will work after above + $schema->storage->txn_do(sub { ok "noop" } ); + +### Make sure non-existend savepoint release doesn't infloop itself + { + weaken( my $s = $schema ); + + throws_ok { + $s->storage->txn_do(sub { $s->svp_release('wibble') }) + } qr/Savepoint 'wibble' does not exist/, + "Calling svp_release on a non-existant savepoint throws expected error" + ; + } ### cleanupz $schema->storage->dbh_do(sub { $_[1]->do("DROP TABLE artist") }); @@ -255,8 +259,6 @@ SKIP: { done_testing; END { - local $SIG{__WARN__} = sigwarn_silencer( qr/Internal transaction state of handle/ ) - unless modver_gt_or_eq('DBD::SQLite', '1.33'); eval { $schema->storage->dbh_do(sub { $_[1]->do("DROP TABLE artist") }) } if defined $schema; undef $schema; } diff --git a/t/storage/stats.t b/t/storage/stats.t index c1643995c..58fbde05d 100644 --- a/t/storage/stats.t +++ b/t/storage/stats.t @@ -1,11 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; plan tests => 12; -use lib qw(t/lib); - use_ok('DBICTest'); my $schema = DBICTest->init_schema(); diff --git a/t/storage/txn.t b/t/storage/txn.t index f8e1b356d..0edca6c44 100644 --- a/t/storage/txn.t +++ b/t/storage/txn.t @@ -1,10 +1,16 @@ +# Test is sufficiently involved to *want* to run with "maximum paranoia" +BEGIN { $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} = 1 } + +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); +use Errno (); + use DBICTest; my $code = sub { @@ -208,12 +214,11 @@ sub _test_forking_action { SKIP: for my $count (1 .. 5) { - skip 'Weird DBI General Protection Faults, skip forking tests (RT#63104)', 5 + skip 'FIXME: Weird DBI General Protection Faults, skip forking tests (RT#63104)', 5 if $^O eq 'MSWin32'; my $pid = fork(); if( ! defined $pid ) { - skip "EAGAIN encountered, your system is likely bogged down: skipping forking test", 1 if $! == Errno::EAGAIN(); diff --git a/t/storage/txn_scope_guard.t b/t/storage/txn_scope_guard.t index 6c6d1df0e..00d81a46d 100644 --- a/t/storage/txn_scope_guard.t +++ b/t/storage/txn_scope_guard.t @@ -1,3 +1,8 @@ +# Test is sufficiently involved to *want* to run with "maximum paranoia" +BEGIN { $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} = 1 } + +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -8,7 +13,7 @@ use Test::Exception; use List::Util 'shuffle'; use DBIx::Class::_Util 'sigwarn_silencer'; -use lib qw(t/lib); + use DBICTest; # Test txn_scope_guard @@ -137,6 +142,11 @@ require DBICTest::AntiPattern::NullObject; } }; + + # we are driving manually here, do not allow interference + local $SIG{__DIE__} if $SIG{__DIE__}; + + no warnings 'redefine'; local *DBIx::Class::Storage::DBI::txn_rollback = sub { die 'die die my darling' }; Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; @@ -232,29 +242,4 @@ require DBICTest::AntiPattern::NullObject; is(scalar @w, 0, 'no warnings \o/'); } -# ensure Devel::StackTrace-refcapture-like effects are countered -{ - my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); - my $g = $s->txn_scope_guard; - - my @arg_capture; - { - local $SIG{__WARN__} = sub { - package DB; - my $frnum; - while (my @f = CORE::caller(++$frnum) ) { - push @arg_capture, @DB::args; - } - }; - - undef $g; - 1; - } - - warnings_exist - { @arg_capture = () } - qr/\QPreventing *MULTIPLE* DESTROY() invocations on DBIx::Class::Storage::TxnScopeGuard/ - ; -} - done_testing; diff --git a/t/update/all.t b/t/update/all.t index acc83878e..920e17c3e 100644 --- a/t/update/all.t +++ b/t/update/all.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/update/ident_cond.t b/t/update/ident_cond.t index d7d4cf00f..697925598 100644 --- a/t/update/ident_cond.t +++ b/t/update/ident_cond.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/update/type_aware.t b/t/update/type_aware.t index fd58319d6..eb8ac26c3 100644 --- a/t/update/type_aware.t +++ b/t/update/type_aware.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/zzzzzzz_authors.t b/t/zzzzzzz_authors.t index a46a247a8..18b771f85 100644 --- a/t/zzzzzzz_authors.t +++ b/t/zzzzzzz_authors.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More 'no_plan'; -use lib 't/lib'; + use DBICTest::RunMode; my $authorcount = scalar do { diff --git a/t/zzzzzzz_perl_perf_bug.t b/t/zzzzzzz_perl_perf_bug.t index 4434e1c74..a9cc07f7e 100644 --- a/t/zzzzzzz_perl_perf_bug.t +++ b/t/zzzzzzz_perl_perf_bug.t @@ -1,9 +1,13 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + BEGIN { + delete $ENV{DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE}; + plan skip_all => 'Skipping RH perl performance bug tests as DBIC_NO_WARN_BAD_PERL set' if ( $ENV{DBIC_NO_WARN_BAD_PERL} ); diff --git a/xt/dist/authors.t b/xt/dist/authors.t index 8ee1bf37f..7f0537bc8 100644 --- a/xt/dist/authors.t +++ b/xt/dist/authors.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; @@ -75,7 +77,7 @@ if ( for ( map { my ($gitname) = m/^ \s* \d+ \s* (.+?) \s* $/mx; utf8::decode($gitname); $gitname } - qx( git shortlog -e -s ) + qx( git shortlog HEAD --remotes=historic/ghpr/applied/ --remotes=historic/ghpr/closed/ -e -s ) ) { my ($eml) = $_ =~ $email_re; diff --git a/xt/dist/loadable_standalone_testschema_resultclasses.t b/xt/dist/loadable_standalone_testschema_resultclasses.t index f0dd2acb4..5a9c6f62b 100644 --- a/xt/dist/loadable_standalone_testschema_resultclasses.t +++ b/xt/dist/loadable_standalone_testschema_resultclasses.t @@ -1,22 +1,21 @@ +BEGIN { + delete $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY}; + do "./t/lib/ANFANG.pm" or die ( $@ || $! ) +} + use warnings; use strict; -BEGIN { delete $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY} } - use DBIx::Class::_Util 'sigwarn_silencer'; use if DBIx::Class::_ENV_::BROKEN_FORK, 'threads'; use Test::More; use File::Find; -use Time::HiRes 'sleep'; - - -use lib 't/lib'; my $worker = sub { my $fn = shift; - if (my @offenders = grep { $_ !~ m{DBIx/Class/(?:_Util|Carp)\.pm} } grep { $_ =~ /(^|\/)DBI/ } keys %INC) { + if (my @offenders = grep { $_ !~ m{DBIx/Class/(?:_Util|Carp|Exception|StartupCheck)\.pm} } grep { $_ =~ /(^|\/)DBI/ } keys %INC) { die "Wtf - DBI* modules present in %INC: @offenders"; } @@ -35,7 +34,7 @@ find({ if (DBIx::Class::_ENV_::BROKEN_FORK) { # older perls crash if threads are spawned way too quickly, sleep for 100 msecs my $t = threads->create(sub { $worker->($_) }); - sleep 0.1; + select( undef, undef, undef, 0.1); is ($t->join, 42, "Thread loading $_ did not finish successfully") || diag ($t->can('error') ? $t->error : 'threads.pm too old to retrieve the error :(' ); } diff --git a/xt/dist/pod_coverage.t b/xt/dist/pod_coverage.t index 1f3195a4a..859f0e324 100644 --- a/xt/dist/pod_coverage.t +++ b/xt/dist/pod_coverage.t @@ -1,13 +1,14 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_podcoverage'; use warnings; use strict; use Test::More; -use List::Util 'first'; use Module::Runtime 'require_module'; -use lib qw(t/lib maint/.Generated_Pod/lib); +use lib 'maint/.Generated_Pod/lib'; use DBICTest; +use DBIx::Class::Schema::SanityChecker; use namespace::clean; # this has already been required but leave it here for CPANTS static analysis @@ -29,10 +30,7 @@ require Test::Pod::Coverage; my $exceptions = { 'DBIx::Class' => { ignore => [qw/ - MODIFY_CODE_ATTRIBUTES component_base_class - mk_classdata - mk_classaccessor /] }, 'DBIx::Class::Optional::Dependencies' => { @@ -57,6 +55,7 @@ my $exceptions = { store_column get_column get_columns + get_dirty_columns has_column_loaded /], }, @@ -69,6 +68,10 @@ my $exceptions = { resolve_prefetch STORABLE_freeze STORABLE_thaw + get_rsrc_instance_specific_attribute + set_rsrc_instance_specific_attribute + get_rsrc_instance_specific_handler + set_rsrc_instance_specific_handler /], }, 'DBIx::Class::ResultSet' => { @@ -100,6 +103,11 @@ my $exceptions = { connection /] }, + 'DBIx::Class::Schema::SanityChecker' => { + ignore => [ map { + qr/^ (?: check_${_} | format_${_}_errors ) $/x + } @{ DBIx::Class::Schema::SanityChecker->available_checks } ] + }, 'DBIx::Class::Admin' => { ignore => [ qw/ @@ -114,6 +122,8 @@ my $exceptions = { /] }, + 'DBIx::Class::_TempExtlib*' => { skip => 1 }, + 'DBIx::Class::Admin::*' => { skip => 1 }, 'DBIx::Class::ClassResolver::PassThrough' => { skip => 1 }, 'DBIx::Class::Componentised' => { skip => 1 }, @@ -165,7 +175,7 @@ foreach my $module (@modules) { SKIP: { my ($match) = - first { $module =~ $_ } + grep { $module =~ $_ } (sort { length $b <=> length $a || $b cmp $a } (keys %$ex_lookup) ) ; @@ -177,9 +187,10 @@ foreach my $module (@modules) { # build parms up from ignore list my $parms = {}; - $parms->{trustme} = - [ map { qr/^$_$/ } @{ $ex->{ignore} } ] - if exists($ex->{ignore}); + $parms->{trustme} = [ map + { ref $_ eq 'Regexp' ? $_ : qr/^\Q$_\E$/ } + @{ $ex->{ignore} } + ] if exists($ex->{ignore}); # run the test with the potentially modified parm set Test::Pod::Coverage::pod_coverage_ok($module, $parms, "$module POD coverage"); diff --git a/xt/dist/postdistdir/pod_footers.t b/xt/dist/postdistdir/pod_footers.t index 9882b52a5..ee2ac9d02 100644 --- a/xt/dist/postdistdir/pod_footers.t +++ b/xt/dist/postdistdir/pod_footers.t @@ -1,9 +1,15 @@ +BEGIN { $ENV{DBICTEST_ANFANG_DEFANG} = 1 } + use warnings; use strict; use Test::More; use File::Find; +use lib 't/lib'; +use DBICTest; # for the lock +use DBICTest::Util 'slurp_bytes'; + my $boilerplate_headings = q{ =head1 FURTHER QUESTIONS? @@ -23,8 +29,9 @@ find({ return unless -f $fn; return unless $fn =~ / \. (?: pm | pod ) $ /ix; + return if $fn =~ qr{\Qlib/DBIx/Class/_TempExtlib/}; - my $data = do { local (@ARGV, $/) = $fn; <> }; + my $data = slurp_bytes $fn; if ($data !~ /^=head1 NAME/m) { diff --git a/xt/dist/postdistdir/pod_validity.t b/xt/dist/postdistdir/pod_validity.t index 773e5acfd..49291adac 100644 --- a/xt/dist/postdistdir/pod_validity.t +++ b/xt/dist/postdistdir/pod_validity.t @@ -1,10 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_pod'; use warnings; use strict; use Test::More; -use lib qw(t/lib); + use DBICTest; # this has already been required but leave it here for CPANTS static analysis diff --git a/xt/dist/postdistdir/whitespace.t b/xt/dist/postdistdir/whitespace.t index 3576da6e5..a825c1e0c 100644 --- a/xt/dist/postdistdir/whitespace.t +++ b/xt/dist/postdistdir/whitespace.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_whitespace'; use warnings; @@ -5,7 +6,7 @@ use strict; use Test::More; use File::Glob 'bsd_glob'; -use lib 't/lib'; + use DBICTest ':GlobalLock'; # FIXME - temporary workaround for RT#82032, RT#82033 @@ -26,8 +27,19 @@ 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) +# start with what we want to check no matter what .gitignore says +my @root_files = grep { -f $_ } qw( + Changes + LICENSE + AUTHORS + README + MANIFEST + META.yml + META.json +); + +# if .gitignore is available - go for * and use .gitignore as a guide +# of what to skip if (open(my $gi, '<', '.gitignore')) { my $skipnames; while (my $ln = <$gi>) { @@ -36,15 +48,18 @@ if (open(my $gi, '<', '.gitignore')) { $skipnames->{$_}++ for bsd_glob($ln); } - # that we want to check anyway - delete $skipnames->{'META.yml'}; + delete @{$skipnames}{@root_files}; - 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); - } + @root_files = grep { + ! $skipnames->{$_} + and + -f $_ + } bsd_glob('*'); +} + +for my $fn (@root_files) { + Test::EOL::eol_unix_ok($fn, { trailing_whitespace => 1 }); + Test::NoTabs::notabs_ok($fn) unless $fn eq 'MANIFEST'; # it is always tab infested } # FIXME - Test::NoTabs and Test::EOL declare 'no_plan' which conflicts with done_testing diff --git a/xt/dist/strictures.t b/xt/dist/strictures.t index 70efc7cfd..5d8cb4e85 100644 --- a/xt/dist/strictures.t +++ b/xt/dist/strictures.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_strictures'; use warnings; @@ -7,7 +8,7 @@ use Test::More; use File::Find; use File::Spec; use Config; -use lib 't/lib'; + use DBICTest; # The rationale is - if we can load all our optdeps @@ -23,9 +24,9 @@ my $missing_groupdeps_present = grep # don't test syntax when RT#106935 is triggered (mainly CI) # FIXME - remove when RT is resolved my $tainted_relpath = ( - length $ENV{PATH} + DBIx::Class::_ENV_::TAINT_MODE and - ${^TAINT} + length $ENV{PATH} and grep { ! File::Spec->file_name_is_absolute($_) } @@ -40,9 +41,17 @@ find({ return if m{^(?: maint/Makefile.PL.inc/.+ # all the maint inc snippets are auto-strictured | + t/lib/DBICTest/WithTaint.pm # no stictures by design (trips up local::lib on older perls) + | t/lib/DBICTest/Util/OverrideRequire.pm # no stictures by design (load order sensitive) | - lib/DBIx/Class/Optional/Dependencies.pm # no stictures by design (load spee sensitive) + t/lib/ANFANG.pm # no stictures by design (load speed sensitive) + | + lib/DBIx/Class/Optional/Dependencies.pm # no stictures by design (load speed sensitive) + | + lib/DBIx/Class/StartupCheck.pm # no stictures by design (load speed sensitive) + | + lib/DBIx/Class/_TempExtlib/.+ )$}x; my $f = $_; diff --git a/xt/extra/c3_mro.t b/xt/extra/c3_mro.t index 55effb5a9..fa63e0c3f 100644 --- a/xt/extra/c3_mro.t +++ b/xt/extra/c3_mro.t @@ -1,15 +1,27 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; - -use lib qw(t/lib); -use DBICTest; # do not remove even though it is not used (pulls in MRO::Compat if needed) +use DBICTest; +use DBIx::Class::Optional::Dependencies; +use DBIx::Class::_Util 'uniq'; + +my @global_ISA_tail = qw( + DBIx::Class + DBIx::Class::Componentised + Class::C3::Componentised + DBIx::Class::AccessorGroup + DBIx::Class::MethodAttributes + Class::Accessor::Grouped +); { package AAA; use base "DBIx::Class::Core"; + use mro 'c3'; } { @@ -36,6 +48,31 @@ ok (! $@, "Correctly skipped injecting a direct parent of class BBB"); eval { mro::get_linear_isa('CCC'); }; ok (! $@, "Correctly skipped injecting an indirect parent of class BBB"); + +my $art = DBICTest->init_schema->resultset("Artist")->next; + +check_ancestry($_) for uniq map + { length ref $_ ? ref $_ : $_ } + ( + $art, + $art->result_source, + $art->result_source->resultset, + ( map + { $_, $_->result_class, $_->resultset_class } + map + { $art->result_source->schema->source($_) } + $art->result_source->schema->sources + ), + qw( AAA BBB CCC ), + ((! DBIx::Class::Optional::Dependencies->req_ok_for('cdbicompat') ) ? () : do { + unshift @INC, 't/cdbi/testlib'; + map { eval "require $_" or die $@; $_ } qw( + Film Lazy Actor ActorAlias ImplicitInflate + ); + }), + ) +; + use DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server; is_deeply ( @@ -49,12 +86,7 @@ is_deeply ( DBIx::Class::Storage::DBI DBIx::Class::Storage::DBIHacks DBIx::Class::Storage - DBIx::Class - DBIx::Class::Componentised - Class::C3::Componentised - DBIx::Class::AccessorGroup - Class::Accessor::Grouped - /], + /, @global_ISA_tail], 'Correctly ordered ISA of DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server' ); @@ -75,4 +107,33 @@ if ( "$]" >= 5.010 ) { #ok (! $INC{'MRO/Compat.pm'}, 'No MRO::Compat loaded on perl 5.10+'); } +sub check_ancestry { + my $class = shift; + + die "Expecting classname" if length ref $class; + + my @linear_ISA = @{ mro::get_linear_isa($class) }; + + # something is *VERY* wrong, the splice below won't make it + unless (@linear_ISA > @global_ISA_tail) { + fail( + "Unexpectedly shallow \@ISA for class '$class': " + . join ', ', map { "'$_'" } @linear_ISA + ); + return; + } + + is_deeply ( + [ splice @linear_ISA, ($#linear_ISA - $#global_ISA_tail) ], + \@global_ISA_tail, + "Correct end of \@ISA for '$class'" + ); + + is( + mro::get_mro($class), + 'c3', + "Expected mro on class '$class' automatically set", + ); +} + done_testing; diff --git a/xt/extra/dbicadmin.t b/xt/extra/dbicadmin.t index cc79190f8..db254f82c 100644 --- a/xt/extra/dbicadmin.t +++ b/xt/extra/dbicadmin.t @@ -1,18 +1,19 @@ -use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_admin_script'; - -use strict; -use warnings; - BEGIN { # just in case the user env has stuff in it delete $ENV{JSON_ANY_ORDER}; delete $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY}; + + do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } +use strict; +use warnings; + +use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_admin_script'; + use Test::More; use Config; -use File::Spec; -use lib qw(t/lib); + use DBICTest; $ENV{PATH} = ''; @@ -71,7 +72,7 @@ sub test_dbicadmin { my ($perl) = $^X =~ /(.*)/; - open(my $fh, "-|", ( $perl, '-MDBICTest::RunMode', 'script/dbicadmin', default_args(), qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!; + open(my $fh, "-|", ( $perl, '-MANFANG', '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" )) { @@ -101,7 +102,7 @@ sub default_args { sub test_exec { my ($perl) = $^X =~ /(.*)/; - my @args = ($perl, '-MDBICTest::RunMode', File::Spec->catfile(qw(script dbicadmin)), @_); + my @args = ($perl, '-MANFANG', 'script/dbicadmin', @_); if ($^O eq 'MSWin32') { require Win32::ShellQuote; # included in test optdeps diff --git a/xt/extra/diagnostics/add_invalid_relationship.t b/xt/extra/diagnostics/add_invalid_relationship.t new file mode 100644 index 000000000..6562489de --- /dev/null +++ b/xt/extra/diagnostics/add_invalid_relationship.t @@ -0,0 +1,28 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +use DBICTest; + +{ + local $TODO = "relationship checking needs fixing"; + # try to add a bogus relationship using the wrong cols + throws_ok { + DBICTest::Schema::Artist->add_relationship( + tracks => 'DBICTest::Schema::Track', + { 'foreign.cd' => 'self.cdid' } + ); + } qr/Unknown column/, 'failed when creating a rel with invalid key, ok'; +} + +# another bogus relationship using no join condition +throws_ok { + DBICTest::Schema::Artist->add_relationship( tracks => 'DBICTest::Track' ); +} qr/join condition/, 'failed when creating a rel without join condition, ok'; + + +done_testing; diff --git a/xt/extra/diagnostics/deprecated_rs_attributes.t b/xt/extra/diagnostics/deprecated_rs_attributes.t index 8eed20bf2..2f458c064 100644 --- a/xt/extra/diagnostics/deprecated_rs_attributes.t +++ b/xt/extra/diagnostics/deprecated_rs_attributes.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/xt/extra/diagnostics/divergent_metadata.t b/xt/extra/diagnostics/divergent_metadata.t new file mode 100644 index 000000000..67e9bea1e --- /dev/null +++ b/xt/extra/diagnostics/divergent_metadata.t @@ -0,0 +1,97 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +# things will die if this is set +BEGIN { $ENV{DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE} = 0 } + +use strict; +use warnings; + +use Test::More; + +use DBICTest::Util 'capture_stderr'; +use DBICTest; + +my ($fn) = __FILE__ =~ /( [^\/\\]+ ) $/x; +my @divergence_lines; + +my $art = DBICTest->init_schema->resultset("Artist")->find(1); + +push @divergence_lines, __LINE__ + 1; +DBICTest::Schema::Artist->add_columns("Something_New"); + +push @divergence_lines, __LINE__ + 1; +$_->add_column("Something_New_2") for grep + { $_ != $art->result_source } + DBICTest::Schema::Artist->result_source_instance->__derived_instances +; + +push @divergence_lines, __LINE__ + 1; +DBICTest::Schema::Artist->result_source_instance->name("foo"); + +my $orig_class_rsrc_before_table_triggered_reinit = DBICTest::Schema::Artist->result_source_instance; + +push @divergence_lines, __LINE__ + 1; +DBICTest::Schema::Artist->table("bar"); + +is( + capture_stderr { + ok( + DBICTest::Schema::Artist->has_column( "Something_New" ), + 'Added column visible' + ); + + ok( + (! DBICTest::Schema::Artist->has_column( "Something_New_2" ) ), + 'Column added on children not visible' + ); + }, + '', + 'No StdErr output during rsrc augmentation' +); + +my $err = capture_stderr { + ok( + ! $art->has_column($_), + "Column '$_' not visible on @{[ $art->table ]}" + ) for qw(Something_New Something_New_2); +}; + +# Tricky text - check it painstakingly as things may go off +# in very subtle ways +my $expected_warning_1 = join '.+?', map { quotemeta $_ } + "@{[ $art->result_source ]} (the metadata instance of source 'Artist') is *OUTDATED*", + + "${orig_class_rsrc_before_table_triggered_reinit}->add_columns(...) at", + "$fn line $divergence_lines[0]", + + "@{[ DBICTest::Schema->source('Artist') ]}->add_column(...) at", + "$fn line $divergence_lines[1]", + + "Stale metadata accessed by 'getter' @{[ $art->result_source ]}->has_column(...)", +; + +like + $err, + qr/$expected_warning_1/s, + 'Correct warning on diverged metadata' +; + +my $expected_warning_2 = join '.+?', map { quotemeta $_ } + "@{[ $art->result_source ]} (the metadata instance of source 'Artist') is *OUTDATED*", + + "${orig_class_rsrc_before_table_triggered_reinit}->name(...) at", + "$fn line $divergence_lines[2]", + + "${orig_class_rsrc_before_table_triggered_reinit}->table(...) at", + "$fn line $divergence_lines[3]", + + "Stale metadata accessed by 'getter' @{[ $art->result_source ]}->table(...)", +; + +like + $err, + qr/$expected_warning_2/s, + 'Correct warning on diverged metadata' +; + +done_testing; diff --git a/xt/extra/diagnostics/find_via_unsupported_rel.t b/xt/extra/diagnostics/find_via_unsupported_rel.t new file mode 100644 index 000000000..10328e23d --- /dev/null +++ b/xt/extra/diagnostics/find_via_unsupported_rel.t @@ -0,0 +1,31 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +use DBICTest; + +my $schema = DBICTest->init_schema( no_deploy => 1 ); + +my $artist = $schema->resultset('Artist')->new_result({ artistid => 1 }); + +throws_ok { + $schema->resultset('ArtistUndirectedMap')->find({ + mapped_artists => $artist, + }); +} qr/\QUnable to complete value inferrence - relationship 'mapped_artists' on source 'ArtistUndirectedMap' results in expression(s) instead of definitive values: ( id1 = ? OR id2 = ? )/, + 'proper exception on OR relationship inferrence' +; + +throws_ok { + $schema->resultset('Artwork_to_Artist')->find({ + artist_limited_rank_opaque => $artist + }) +} qr/\QRelationship 'artist_limited_rank_opaque' on source 'Artwork_to_Artist' does not resolve to a 'foreign_values'-based reversed-join-free condition fragment/, + 'proper exception on ipaque custom cond' +; + +done_testing; diff --git a/xt/extra/diagnostics/incomplete_reregister.t b/xt/extra/diagnostics/incomplete_reregister.t new file mode 100644 index 000000000..27469b1a2 --- /dev/null +++ b/xt/extra/diagnostics/incomplete_reregister.t @@ -0,0 +1,26 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +# things will die if this is set +BEGIN { $ENV{DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE} = 0 } + +use strict; +use warnings; + +use Test::More; +use Test::Warn; + +use DBICTest; + +my $s = DBICTest->init_schema( no_deploy => 1 ); + + +warnings_exist { + DBICTest::Schema::Artist->add_column("somethingnew"); + $s->unregister_source("Artist"); + $s->register_class( Artist => "DBICTest::Schema::Artist" ); +} + qr/The ResultSource instance you just registered on .+ \Qas 'Artist' seems to have no relation to DBICTest::Schema->source('Artist') which in turn is marked stale/, + 'Expected warning on incomplete re-register of schema-class-level source' +; + +done_testing; diff --git a/xt/extra/diagnostics/invalid_component_composition.t b/xt/extra/diagnostics/invalid_component_composition.t new file mode 100644 index 000000000..ac162d533 --- /dev/null +++ b/xt/extra/diagnostics/invalid_component_composition.t @@ -0,0 +1,48 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +BEGIN { delete $ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS} } + +use strict; +use warnings; + +use Test::More; + +use DBICTest::Util 'capture_stderr'; +use DBICTest; + + +{ + package DBICTest::Some::BaseResult; + use base "DBIx::Class::Core"; + + # order is important + __PACKAGE__->load_components(qw( FilterColumn InflateColumn::DateTime )); +} + +{ + package DBICTest::Some::Result; + use base "DBICTest::Some::BaseResult"; + + __PACKAGE__->table("sometable"); + + __PACKAGE__->add_columns( + somecolumn => { data_type => "datetime" }, + ); +} + +{ + package DBICTest::Some::Schema; + use base "DBIx::Class::Schema"; + __PACKAGE__->schema_sanity_checker("DBIx::Class::Schema::SanityChecker"); + __PACKAGE__->register_class( some_result => "DBICTest::Some::Result" ); +} + +like( + capture_stderr { + DBICTest::Some::Schema->connection(sub {} ); + }, + qr/Class 'DBICTest::Some::Result' was originally using the 'dfs' MRO affecting .+ register_column\(\)/, + 'Proper incorrect composition warning emitted on StdErr' +); + +done_testing; diff --git a/t/relationship/resolve_relationship_condition.t b/xt/extra/diagnostics/invalid_resolve_relationship_condition_arguments.t similarity index 52% rename from t/relationship/resolve_relationship_condition.t rename to xt/extra/diagnostics/invalid_resolve_relationship_condition_arguments.t index 1d4cb6271..050b5cade 100644 --- a/t/relationship/resolve_relationship_condition.t +++ b/xt/extra/diagnostics/invalid_resolve_relationship_condition_arguments.t @@ -1,13 +1,14 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib 't/lib'; use DBICTest; -my $schema = DBICTest->init_schema(); +my $schema = DBICTest->init_schema( no_deploy => 1 ); for ( { year => [1,2] }, @@ -16,7 +17,7 @@ for ( { -and => [ year => 1, year => 2 ] }, ) { throws_ok { - $schema->source('Track')->_resolve_relationship_condition( + $schema->source('Track')->resolve_relationship_condition( rel_name => 'cd_cref_cond', self_alias => 'me', foreign_alias => 'cd', @@ -25,7 +26,9 @@ for ( } qr/ \Qis not a column on related source 'CD'\E | - \QValue supplied for '...{foreign_values}{year}' is not a direct equivalence expression\E + \Qsupplied value for foreign column 'year' is not a direct equivalence expression\E + | + \QThe key '-\E \w+ \Q' supplied as part of 'foreign_values' during relationship resolution must be a column name, not a function\E /x; } diff --git a/xt/extra/diagnostics/malformed_rel_declaration.t b/xt/extra/diagnostics/malformed_rel_declaration.t index a1abdb7c0..70a803e34 100644 --- a/xt/extra/diagnostics/malformed_rel_declaration.t +++ b/xt/extra/diagnostics/malformed_rel_declaration.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest::Schema::Artist; my $pkg = 'DBICTest::Schema::Artist'; diff --git a/xt/extra/diagnostics/many_to_many_warning.t b/xt/extra/diagnostics/many_to_many_warning.t index 2c42091bf..c416e4141 100644 --- a/xt/extra/diagnostics/many_to_many_warning.t +++ b/xt/extra/diagnostics/many_to_many_warning.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $exp_warn = qr/The many-to-many relationship 'bars' is trying to create/; diff --git a/xt/extra/diagnostics/resultset_manager.t b/xt/extra/diagnostics/resultset_manager.t index fad560d11..28c2d9d62 100644 --- a/xt/extra/diagnostics/resultset_manager.t +++ b/xt/extra/diagnostics/resultset_manager.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; warnings_exist { require DBICTest::ResultSetManager } diff --git a/xt/extra/diagnostics/search_in_void_ctx.t b/xt/extra/diagnostics/search_in_void_ctx.t index 95a040f8d..d63ee1c98 100644 --- a/xt/extra/diagnostics/search_in_void_ctx.t +++ b/xt/extra/diagnostics/search_in_void_ctx.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(no_deploy => 1); diff --git a/xt/extra/diagnostics/unresolvable_relationship.t b/xt/extra/diagnostics/unresolvable_relationship.t index 5a53cd9d3..23a4d887e 100644 --- a/xt/extra/diagnostics/unresolvable_relationship.t +++ b/xt/extra/diagnostics/unresolvable_relationship.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/xt/extra/internals/bool.t b/xt/extra/internals/bool.t new file mode 100644 index 000000000..473a562f6 --- /dev/null +++ b/xt/extra/internals/bool.t @@ -0,0 +1,23 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; +use DBIx::Class::_Util qw( true false ); +use Scalar::Util 'refaddr'; + +my @things = ( true, false, true, false, true, false ); + +for (my $i = 0; $i < $#things; $i++ ) { + for my $j ( $i+1 .. $#things ) { + cmp_ok + refaddr( $things[$i] ), + '!=', + refaddr( $things[$j] ), + "Boolean thingy '$i' distinct from '$j'", + ; + } +} + +done_testing; diff --git a/xt/extra/internals/dbictest_unlink_guard.t b/xt/extra/internals/dbictest_unlink_guard.t index 83a38e9de..9ab5c1bcd 100644 --- a/xt/extra/internals/dbictest_unlink_guard.t +++ b/xt/extra/internals/dbictest_unlink_guard.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; -use lib 't/lib'; + use DBICTest; # Once upon a time there was a problem with a leaking $sth diff --git a/xt/extra/internals/describe_class_methods.t b/xt/extra/internals/describe_class_methods.t new file mode 100644 index 000000000..1177ac8de --- /dev/null +++ b/xt/extra/internals/describe_class_methods.t @@ -0,0 +1,686 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; +no warnings 'once'; + +use Config; +my $skip_threads; +BEGIN { + if( ! $Config{useithreads} ) { + $skip_threads = 'your perl does not support ithreads'; + } + elsif( "$]" < 5.008005 ) { + $skip_threads = 'DBIC does not actively support threads before perl 5.8.5'; + } + elsif( $INC{'Devel/Cover.pm'} ) { + $skip_threads = 'Devel::Cover does not work with ithreads yet'; + } + + unless( $skip_threads ) { + require threads; + threads->import; + } +} + +use Test::More; +use Test::Exception; +use DBIx::Class::_Util qw( + quote_sub describe_class_methods + serialize refdesc sigwarn_silencer + modver_gt_or_eq_and_lt +); +use List::Util 'shuffle'; +use Errno (); + +use DBICTest; + +my $pkg_gen_history = {}; + +{ package UEBERVERSAL; sub ueber {} } +@UNIVERSAL::ISA = "UEBERVERSAL"; +sub UNIVERSAL::uni { "unistuff" } + +sub grab_pkg_gen ($) { + push @{ $pkg_gen_history->{$_[0]} }, [ + DBIx::Class::_Util::get_real_pkg_gen($_[0]), + 'line ' . ( (caller(0))[2] ), + ]; +} + +@DBICTest::AttrLegacy::ISA = 'DBIx::Class'; +sub DBICTest::AttrLegacy::VALID_DBIC_CODE_ATTRIBUTE { 1 } + +grab_pkg_gen("DBICTest::AttrLegacy"); + +my $var = \42; +my $s = quote_sub( + 'DBICTest::AttrLegacy::attr', + '$v', + { '$v' => $var }, + { + attributes => [qw( ResultSet DBIC_random_attr )], + package => 'DBICTest::AttrLegacy', + }, +); + +grab_pkg_gen("DBICTest::AttrLegacy"); + +is $s, \&DBICTest::AttrLegacy::attr, 'Same cref installed'; + +is DBICTest::AttrLegacy::attr(), 42, 'Sub properly installed and callable'; + +is_deeply + [ sort( attributes::get( $s ) ) ], + [qw( DBIC_random_attr ResultSet )], + 'Attribute installed', +; + +{ + package DBICTest::SomeGrandParentClass; + use base 'DBIx::Class::MethodAttributes'; + sub VALID_DBIC_CODE_ATTRIBUTE { shift->next::method(@_) }; +} +{ + package DBICTest::SomeParentClass; + use base qw(DBICTest::SomeGrandParentClass); +} +{ + package DBICTest::AnotherParentClass; + use base 'DBIx::Class::MethodAttributes'; + sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ }; +} + +{ + package DBICTest::AttrTest; + + @DBICTest::AttrTest::ISA = qw( DBICTest::SomeParentClass DBICTest::AnotherParentClass ); + use mro 'c3'; + + # pathological case - but can (and sadly does) happen + *VALID_DBIC_CODE_ATTRIBUTE = \&DBICTest::SomeGrandParentClass::VALID_DBIC_CODE_ATTRIBUTE; + + ::grab_pkg_gen("DBICTest::AttrTest"); + + eval <<'EOS' or die $@; + sub attr :lvalue :method :DBIC_attr1 { $$var} + 1; +EOS + + ::grab_pkg_gen("DBICTest::AttrTest"); + + ::throws_ok { + attributes->import( + 'DBICTest::AttrTest', + DBICTest::AttrTest->can('attr'), + 'DBIC_unknownattr', + ); + } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/; +} + +is_deeply + [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ], + [qw( DBIC_attr1 lvalue method )], + 'Attribute installed', +; + +ok( + ! DBICTest::AttrTest->can('__attr_cache'), + 'Inherited classdata never created on core attrs' +); + +is_deeply( + DBICTest::AttrTest->_attr_cache, + {}, + 'Cache never instantiated on core attrs' +); + +sub add_more_attrs { + + # Test that secondary attribute application works + attributes->import( + 'DBICTest::AttrLegacy', + DBICTest::AttrLegacy->can('attr'), + 'SomethingNobodyUses', + ); + + # and that double-application also works + attributes->import( + 'DBICTest::AttrLegacy', + DBICTest::AttrLegacy->can('attr'), + 'SomethingNobodyUses', + ); + + grab_pkg_gen("DBICTest::AttrLegacy"); + + is_deeply + [ sort( attributes::get( $s ) )], + [ qw( DBIC_random_attr ResultSet SomethingNobodyUses ) ], + 'Secondary attributes installed', + ; + + is_deeply ( + DBICTest::AttrLegacy->_attr_cache->{$s}, + [ qw( ResultSet SomethingNobodyUses ) ], + 'Attributes visible in legacy DBIC attribute API', + ); + + # Test that secondary attribute application works + attributes->import( + 'DBICTest::AttrTest', + DBICTest::AttrTest->can('attr'), + 'DBIC_attr2', + ); + + grab_pkg_gen("DBICTest::AttrTest"); + + # and that double-application also works + attributes->import( + 'DBICTest::AttrTest', + DBICTest::AttrTest->can('attr'), + 'DBIC_attr2', + 'DBIC_attr3', + ); + + grab_pkg_gen("DBICTest::AttrTest"); + + is_deeply + [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ], + [qw( DBIC_attr1 DBIC_attr2 DBIC_attr3 lvalue method )], + 'DBIC-specific attribute installed', + ; + + ok( + ! DBICTest::AttrTest->can('__attr_cache'), + 'Inherited classdata never created on core+DBIC-specific attrs' + ); + + is_deeply( + DBICTest::AttrTest->_attr_cache, + {}, + 'Legacy DBIC attribute cache never instantiated on core+DBIC-specific attrs' + ); + + # no point dragging in threads::shared, just do the check here + for my $class ( keys %$pkg_gen_history ) { + my $stack = $pkg_gen_history->{$class}; + + for my $i ( 1 .. $#$stack ) { + cmp_ok( + $stack->[$i-1][0], + ( DBIx::Class::_ENV_::OLD_MRO ? '!=' : '<' ), + $stack->[$i][0], + "pkg_gen for $class changed from $stack->[$i-1][1] to $stack->[$i][1]" + ); + } + } + + my $cnt; + # check that class description is stable, and changes when needed + # + # FIXME - this list used to contain 'main', but that started failing as + # of the commit introducing this line with bizarre "unstable gen" errors + # Punting for the time being - will fix at some point in the future + # + for my $class (qw( + DBICTest::AttrTest + DBICTest::AttrLegacy + DBIx::Class + )) { + my $desc = describe_class_methods($class); + + is_deeply( + describe_class_methods($class), + $desc, + "describe_class_methods result is stable over '$class' (pass $_)" + ) for (1,2,3); + + my $desc2 = do { + no strict 'refs'; + + $cnt++; + + eval "sub UEBERVERSAL::some_unimethod_$cnt {}; 1" or die $@; + + my $rv = describe_class_methods($class); + + delete ${"UEBERVERSAL::"}{"some_unimethod_$cnt"}; + + $rv + }; + + delete $_->{cumulative_gen} for $desc, $desc2; + ok( + serialize( $desc ) + ne + serialize( $desc2 ), + "touching UNIVERSAL changed '$class' method availability" + ); + } + + my $bottom_most_V_D_C_A = refdesc( + describe_class_methods("DBIx::Class::MethodAttributes") + ->{methods} + ->{VALID_DBIC_CODE_ATTRIBUTE} + ->[0] + ); + + for my $class ( shuffle( qw( + DBICTest::AttrTest + DBICTest::AttrLegacy + DBICTest::SomeGrandParentClass + DBIx::Class::Schema + DBIx::Class::ResultSet + DBICTest::Schema::Track + ))) { + my $desc = describe_class_methods($class); + + is ( + refdesc( $desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ), + $bottom_most_V_D_C_A, + "Same physical structure returned for last VALID_DBIC_CODE_ATTRIBUTE via class $class" + ); + + is ( + refdesc( $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ), + $bottom_most_V_D_C_A, + "Same physical structure returned for bottom-most SUPER of VALID_DBIC_CODE_ATTRIBUTE via class $class" + ) if $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}; + } + + # check that describe_class_methods returns the right stuff + # ( on the simpler class ) + my $expected_AttrTest_linear_ISA = [qw( + DBICTest::SomeParentClass + DBICTest::SomeGrandParentClass + DBICTest::AnotherParentClass + DBIx::Class::MethodAttributes + )]; + + my $expected_AttrTest_full_ISA = { map { $_ => 1 } ( + qw( UEBERVERSAL UNIVERSAL DBICTest::AttrTest ), + @$expected_AttrTest_linear_ISA, + )}; + + my $expected_desc = { + class => "DBICTest::AttrTest", + + # sum and/or is_deeply are buggy on old List::Util/Test::More + # do the sum by hand ourselves to be sure + cumulative_gen => do { + require Math::BigInt; + my $gen = Math::BigInt->new(0); + + $gen += DBIx::Class::_Util::get_real_pkg_gen($_) + for keys %$expected_AttrTest_full_ISA; + + $gen; + }, + mro => { + type => 'c3', + is_c3 => 1, + }, + linear_isa => $expected_AttrTest_linear_ISA, + isa => $expected_AttrTest_full_ISA, + methods => { + FETCH_CODE_ATTRIBUTES => [ + { + attributes => {}, + name => "FETCH_CODE_ATTRIBUTES", + via_class => "DBIx::Class::MethodAttributes" + }, + ], + MODIFY_CODE_ATTRIBUTES => [ + { + attributes => {}, + name => "MODIFY_CODE_ATTRIBUTES", + via_class => "DBIx::Class::MethodAttributes" + }, + ], + VALID_DBIC_CODE_ATTRIBUTE => ( my $V_D_C_A_stack = [ + { + attributes => {}, + name => 'VALID_DBIC_CODE_ATTRIBUTE', + via_class => 'DBICTest::AttrTest' + }, + { + attributes => {}, + name => "VALID_DBIC_CODE_ATTRIBUTE", + via_class => "DBICTest::SomeGrandParentClass", + }, + { + attributes => {}, + name => "VALID_DBIC_CODE_ATTRIBUTE", + via_class => "DBICTest::AnotherParentClass" + }, + { + attributes => {}, + name => "VALID_DBIC_CODE_ATTRIBUTE", + via_class => "DBIx::Class::MethodAttributes" + }, + ]), + _attr_cache => [ + { + attributes => {}, + name => "_attr_cache", + via_class => "DBIx::Class::MethodAttributes" + }, + ], + attr => [ + { + attributes => { + DBIC_attr1 => 1, + DBIC_attr2 => 1, + DBIC_attr3 => 1, + lvalue => 1, + method => 1 + }, + name => "attr", + via_class => "DBICTest::AttrTest" + } + ], + ueber => [ + { + attributes => {}, + name => "ueber", + via_class => "UEBERVERSAL", + } + ], + uni => [ + { + attributes => {}, + name => "uni", + via_class => "UNIVERSAL", + } + ], + can => [ + { + attributes => {}, + name => "can", + via_class => "UNIVERSAL", + }, + ], + isa => [ + { + attributes => {}, + name => "isa", + via_class => "UNIVERSAL", + }, + ], + VERSION => [ + { + attributes => {}, + name => "VERSION", + via_class => "UNIVERSAL", + }, + ], + ( DBIx::Class::_ENV_::OLD_MRO ? () : ( + DOES => [{ + attributes => {}, + name => "DOES", + via_class => "UNIVERSAL", + }], + ) ), + }, + }; + + $expected_desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE} + = $V_D_C_A_stack; + + $expected_desc->{methods_defined_in_class}{VALID_DBIC_CODE_ATTRIBUTE} + = $V_D_C_A_stack->[0]; + + $expected_desc->{methods_defined_in_class}{attr} + = $expected_desc->{methods}{attr}[0]; + + is_deeply ( + describe_class_methods("DBICTest::AttrTest"), + $expected_desc, + 'describe_class_methods returns correct data', + ); + + # ensure that asking with a different MRO will not perturb the cache + my $cached_desc = serialize( + $DBIx::Class::_Util::__describe_class_query_cache->{"DBICTest::AttrTest|c3"} + ); + + # now try to ask for DFS explicitly, adjust our expectations + $expected_desc->{mro} = { type => 'dfs', is_c3 => 0 }; + + # due to DFS the last 2 entries of ISA and the VALID_DBIC_CODE_ATTRIBUTE + # sourcing-list will change places + splice @$_, -2, 2, @{$_}[-1, -2] + for $V_D_C_A_stack, $expected_AttrTest_linear_ISA; + + is_deeply ( + # work around taint, see TODO below + { + %{ describe_class_methods({ class => "DBICTest::AttrTest", use_mro => "dfs" }) }, + cumulative_gen => $expected_desc->{cumulative_gen}, + }, + $expected_desc, + 'describing with explicit mro returns correct data' + ); + + if ( + DBIx::Class::_ENV_::OLD_MRO + or + ! DBIx::Class::_ENV_::TAINT_MODE + or + ! $INC{"threads.pm"} + or + # $TODO did not work on T::B under threads in this range + # https://github.com/Test-More/test-more/issues/683 + ! modver_gt_or_eq_and_lt( 'Test::More', '1.300', '1.302027' ) + ) { + local $TODO = "On 5.10+ -T combined with stash peeking invalidates the pkg_gen (wtf)" + if + DBIx::Class::_ENV_::TAINT_MODE + and + DBIx::Class::_ENV_::PERL_VERSION > 5.009 + ; + + ok( + ( + serialize( describe_class_methods("DBICTest::AttrTest") ) + eq + $cached_desc + ), + "Asking for alternative mro type did not invalidate cache" + ); + } + + # setting mro explicitly still matches what we expect + mro::set_mro("DBICTest::AttrTest", "dfs"); + + is_deeply ( + # in case set_mro starts increasing pkg_gen... + { + %{describe_class_methods("DBICTest::AttrTest")}, + cumulative_gen => $expected_desc->{cumulative_gen}, + }, + $expected_desc, + 'describing with implicit mro returns correct data' + ); + + # check that a UNIVERSAL-parent interrogation makes sense + # ( it should not list anything from UNIVERSAL itself ) + is_deeply ( + describe_class_methods("UEBERVERSAL"), + { + # should be cached by now, thus safe to rely on...? + cumulative_gen => DBIx::Class::_Util::get_real_pkg_gen('UEBERVERSAL'), + + class => 'UEBERVERSAL', + mro => { is_c3 => 0, type => 'dfs' }, + isa => { UEBERVERSAL => 1 }, + linear_isa => [], + methods => { + ueber => $expected_desc->{methods}{ueber} + }, + methods_defined_in_class => { + ueber => $expected_desc->{methods}{ueber}[0] + }, + }, + "Expected description of a parent-of-UNIVERSAL class (pathological case)", + ); +} + +if ($skip_threads) { + SKIP: { skip "Skipping the thread test: $skip_threads", 1 } + + add_more_attrs(); +} +else { SKIP: { + + my $t = threads->create(sub { + + my $t = threads->create(sub { + + add_more_attrs(); + select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls + + 42; + + }) || do { + die "Unable to start thread: $!" + unless $! == Errno::EAGAIN(); + + SKIP: { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 } + + return 42 ; + }; + + my $rv = $t->join; + + select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls + + $rv; + }) || do { + die "Unable to start thread: $!" + unless $! == Errno::EAGAIN(); + + skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1; + }; + + is ( + $t->join, + 42, + 'Thread stack exitted succesfully' + ); +}} + +# check "crosed-over" mro +{ + { + package DBICTest::WackyDFS; + use base qw( DBICTest::SomeGrandParentClass DBICTest::SomeParentClass ); + } + + is_deeply + describe_class_methods("DBICTest::WackyDFS")->{methods}{VALID_DBIC_CODE_ATTRIBUTE}, + [ + { + attributes => {}, + name => "VALID_DBIC_CODE_ATTRIBUTE", + via_class => "DBICTest::SomeGrandParentClass", + }, + { + attributes => {}, + name => "VALID_DBIC_CODE_ATTRIBUTE", + via_class => "DBIx::Class::MethodAttributes" + }, + ], + 'Expected description on unusable inheritance hierarchy' + ; +} + +# check pathological cases ( combinations of cases from +# Package::Stash and Devel::Isa::Explainer ) +{ + { + package DBICTest::Exotic; + + use constant CSCALAR => 1; + use constant CSCALARREF => \1; + use constant CARRAYREF => []; + use constant CHASHREF => {}; + use constant CSUB => sub { }; + + sub subnormal { } + sub substub; + sub subnormalproto () { } + sub substubproto (); + + sub Bsubnormal { } + sub Bsubstub; + sub Bsubnormalproto () { } + sub Bsubstubproto (); + + our @OURARRAY; + our %OURHASH; + our $OURSCALAR; + + *someXSUB = \&DBIx::Class::_Util::deep_clone; + + *EMPTYGLOB = *EMPTYGLOB; + + our @GLOBCOLLISION; + our %GLOBCOLLISION; + sub GLOBCOLLISION { } + + no strict 'refs'; + ${'DBICTest::'}{stubUNDEF} = undef; + ${'DBICTest::'}{stubSCALAR} = 1; + + bless $_, "0" + for map + { \&{"DBICTest::Exotic::Bsub$_"} } + qw( normal stub ) + ; + + bless $_, __PACKAGE__ + for map + { \&{"DBICTest::Exotic::Bsub$_"} } + qw( normalproto stubproto ) + ; + + package DBICTest::Exotic::SubPackage; + *CHILDGLOB = *CHILDGLOB; + } + + my $expected = [ sort + qw( + CSCALAR CSCALARREF CARRAYREF CHASHREF CSUB + GLOBCOLLISION someXSUB + ), + (map + {( "Bsub$_", "sub$_" )} + qw( normal stub normalproto stubproto ) + ), + ]; + + # FIXME because attributes::get() has an error in its signature parser + local $SIG{__WARN__} = sigwarn_silencer qr/Unable to determine attributes of/; + + is_deeply + [ sort keys %{ + describe_class_methods('DBICTest::Exotic')->{methods_defined_in_class} + } ], + $expected, + 'All expected methods recognized in pathological cases' + ; + + # blow the cache + *DBICTest::Exotic::zzz_extra_method = sub {}; + + is_deeply + [ sort keys %{ + describe_class_methods('DBICTest::Exotic')->{methods_defined_in_class} + } ], + [ @$expected, 'zzz_extra_method' ], + 'All expected methods yet again recognized in pathological cases' + ; +} + +done_testing; diff --git a/xt/extra/internals/discard_changes_in_DESTROY.t b/xt/extra/internals/discard_changes_in_DESTROY.t index 736664d54..a5fa8e038 100644 --- a/xt/extra/internals/discard_changes_in_DESTROY.t +++ b/xt/extra/internals/discard_changes_in_DESTROY.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/xt/extra/internals/ensure_class_loaded.t b/xt/extra/internals/ensure_class_loaded.t index e933c00a3..d106d3ed7 100644 --- a/xt/extra/internals/ensure_class_loaded.t +++ b/xt/extra/internals/ensure_class_loaded.t @@ -1,11 +1,13 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; -use Class::Inspector; +use DBICTest::Util 'class_seems_loaded'; BEGIN { package TestPackage::A; @@ -19,11 +21,11 @@ plan tests => 28; # Test ensure_class_found ok( $schema->ensure_class_found('DBIx::Class::Schema'), 'loaded package DBIx::Class::Schema was found' ); -ok( !Class::Inspector->loaded('DBICTest::FakeComponent'), +ok( ! class_seems_loaded('DBICTest::FakeComponent'), 'DBICTest::FakeComponent not loaded yet' ); ok( $schema->ensure_class_found('DBICTest::FakeComponent'), 'package DBICTest::FakeComponent was found' ); -ok( !Class::Inspector->loaded('DBICTest::FakeComponent'), +ok( ! class_seems_loaded('DBICTest::FakeComponent'), 'DBICTest::FakeComponent not loaded by ensure_class_found()' ); ok( $schema->ensure_class_found('TestPackage::A'), 'anonymous package TestPackage::A found' ); @@ -86,17 +88,17 @@ like( $@, qr/did not return a true value/, } # Test ensure_class_loaded -ok( Class::Inspector->loaded('TestPackage::A'), 'anonymous package exists' ); +ok( class_seems_loaded('TestPackage::A'), 'anonymous package exists' ); eval { $schema->ensure_class_loaded('TestPackage::A'); }; ok( !$@, 'ensure_class_loaded detected an anon. class' ); eval { $schema->ensure_class_loaded('FakePackage::B'); }; like( $@, qr/Can't locate/, 'ensure_class_loaded threw exception for nonexistent class' ); -ok( !Class::Inspector->loaded('DBICTest::FakeComponent'), +ok( ! class_seems_loaded('DBICTest::FakeComponent'), 'DBICTest::FakeComponent not loaded yet' ); eval { $schema->ensure_class_loaded('DBICTest::FakeComponent'); }; ok( !$@, 'ensure_class_loaded detected an existing but non-loaded class' ); -ok( Class::Inspector->loaded('DBICTest::FakeComponent'), +ok( class_seems_loaded('DBICTest::FakeComponent'), 'DBICTest::FakeComponent now loaded' ); { diff --git a/xt/extra/internals/ithread_stress.t b/xt/extra/internals/ithread_stress.t new file mode 100644 index 000000000..dc56d498f --- /dev/null +++ b/xt/extra/internals/ithread_stress.t @@ -0,0 +1,114 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +# Test is sufficiently involved to *want* to run with "maximum paranoia" +BEGIN { $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} = 1 } + +use warnings; +use strict; + +use Config; +BEGIN { + my $skipall; + + # FIXME: this discrepancy is crazy, need to investigate + my $mem_needed = ($Config{ptrsize} == 4) + ? 200 + : 750 + ; + + if( ! $Config{useithreads} ) { + $skipall = 'your perl does not support ithreads'; + } + elsif( "$]" < 5.008005 ) { + $skipall = 'DBIC does not actively support threads before perl 5.8.5'; + } + elsif( $INC{'Devel/Cover.pm'} ) { + $skipall = 'Devel::Cover does not work with ithreads yet'; + } + elsif( + ! $ENV{DBICTEST_RUN_ALL_TESTS} + and + require DBICTest::RunMode + and + ! DBICTest::RunMode->is_smoker + ) { + $skipall = "Test is too expensive (may use up to ${mem_needed}MB of memory), skipping on non-smoker"; + } + else { + require threads; + threads->import(); + + require DBICTest; + # without this the can_alloc may very well shoot half of the CI down + DBICTest->import(':GlobalLock'); + + unless ( DBICTest::Util::can_alloc_MB($mem_needed) ) { + $skipall = "Your system does not have the necessary amount of memory (${mem_needed}MB) for this ridiculous test"; + } + } + + if( $skipall ) { + print "1..0 # SKIP $skipall\n"; + exit 0; + } +} + +use Test::More; +use Errno (); +use DBIx::Class::_Util 'sigwarn_silencer'; +use Time::HiRes qw(time sleep); +use List::Util 'max'; + +# README: If you set the env var to a number greater than 5, +# we will use that many children +my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; +if($num_children !~ /^[0-9]+$/ || $num_children < 5) { + $num_children = 5; +} + +my $schema = DBICTest->init_schema(no_deploy => 1); +isa_ok ($schema, 'DBICTest::Schema'); + +# sleep until this spot so everything starts simultaneously +# add "until turn of second" for prettier display +my $t = int( time() ) + 4; + +my @threads; +SKIP: { + + local $SIG{__WARN__} = sigwarn_silencer( qr/Thread creation failed/i ); + + for (1.. $num_children) { + push @threads, threads->create(sub { + my $tid = threads->tid; + + sleep( max( 0.1, $t - time ) ); + note ("Thread $tid starting work at " . time() ); + + my $rsrc = $schema->source('Artist'); + undef $schema; + isa_ok ($rsrc->schema, 'DBICTest::Schema'); + my $s2 = $rsrc->schema->clone; + + sleep (0.2); # without this many tasty crashes even on latest perls + }) || do { + skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 + if $! == Errno::EAGAIN(); + + die "Unable to start thread: $!"; + }; + } +} + +ok(1, "past spawning"); + +$_->join for @threads; + +ok(1, "past joining"); + +# Too many threading bugs on exit, none of which have anything to do with +# the actual stuff we test +$ENV{DBICTEST_DIRTY_EXIT} = 1 + if "$]"< 5.012; + +done_testing; diff --git a/xt/extra/internals/merge_joinpref_attr.t b/xt/extra/internals/merge_joinpref_attr.t index bb7735800..7a242bd74 100644 --- a/xt/extra/internals/merge_joinpref_attr.t +++ b/xt/extra/internals/merge_joinpref_attr.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; use Test::More; diff --git a/xt/extra/internals/namespaces_cleaned.t b/xt/extra/internals/namespaces_cleaned.t index 552a81ecf..eb255307f 100644 --- a/xt/extra/internals/namespaces_cleaned.t +++ b/xt/extra/internals/namespaces_cleaned.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + BEGIN { if ( "$]" < 5.010) { @@ -16,7 +18,7 @@ BEGIN { # we want to do this here, in the very beginning, before even # warnings/strict are loaded - unshift @INC, 't/lib'; + require DBICTest::Util::OverrideRequire; DBICTest::Util::OverrideRequire::override_global_require( sub { @@ -35,20 +37,16 @@ use warnings; use Test::More; -use lib 't/lib'; - use DBICTest; use File::Find; -use File::Spec; -use B qw/svref_2object/; -use Package::Stash; +use DBIx::Class::_Util qw( get_subname describe_class_methods ); # makes sure we can load at least something use DBIx::Class; use DBIx::Class::Carp; my @modules = grep { - my ($mod) = $_ =~ /(.+)/; + my $mod = $_; # not all modules are loadable at all times do { @@ -65,8 +63,7 @@ my @modules = grep { # have an exception table for old and/or weird code we are not sure # we *want* to clean in the first place my $skip_idx = { map { $_ => 1 } ( - (grep { /^DBIx::Class::CDBICompat/ } @modules), # too crufty to touch - 'SQL::Translator::Producer::DBIx::Class::File', # ditto + 'SQL::Translator::Producer::DBIx::Class::File', # too crufty to touch # not sure how to handle type libraries 'DBIx::Class::Storage::DBI::Replicated::Types', @@ -83,27 +80,26 @@ my $skip_idx = { map { $_ => 1 } ( # utility classes, not part of the inheritance chain 'DBIx::Class::Optional::Dependencies', 'DBIx::Class::ResultSource::RowParser::Util', + 'DBIx::Class::ResultSource::FromSpec::Util', + 'DBIx::Class::SQLMaker::Util', 'DBIx::Class::_Util', ) }; my $has_moose = eval { require Moose::Util }; -Sub::Defer::undefer_all(); - -# can't use Class::Inspector for the mundane parts as it does not -# distinguish imports from anything else, what a crock of... -# Moose is not always available either - hence just do it ourselves - my $seen; #inheritance means we will see the same method multiple times for my $mod (@modules) { SKIP: { skip "$mod exempt from namespace checks",1 if $skip_idx->{$mod}; - my %all_method_like = (map - { %{Package::Stash->new($_)->get_all_symbols('CODE')} } - (reverse @{mro::get_linear_isa($mod)}) - ); + my %all_method_like = + map + { $_->[0]{name} => $mod->can( $_->[0]{name} ) } + grep + { $_->[0]{via_class} ne 'UNIVERSAL' } + values %{ describe_class_methods($mod)->{methods} } + ; my %parents = map { $_ => 1 } @{mro::get_linear_isa($mod)}; @@ -119,15 +115,14 @@ for my $mod (@modules) { # overload is a funky thing - it is not cleaned, and its imports are named funny next if $name =~ /^\(/; - my $gv = svref_2object($all_method_like{$name})->GV; - my $origin = $gv->STASH->NAME; + my ($origin, $cv_name) = get_subname($all_method_like{$name}); - is ($gv->NAME, $name, "Properly named $name method at $origin" . ($origin eq $mod + is ($cv_name, $name, "Properly named $name method at $origin" . ($origin eq $mod ? '' : " (inherited by $mod)" )); - next if $seen->{"${origin}:${name}"}++; + next if $seen->{"${origin}::${name}"}++; if ($origin eq $mod) { pass ("$name is a native $mod method"); @@ -150,6 +145,9 @@ for my $mod (@modules) { # exception time if ( ( $name eq 'import' and $via = 'Exporter' ) + or + # jesus christ nobody had any idea how to design an interface back then + ( $name =~ /_trigger/ and $via = 'Class::Trigger' ) ) { pass("${mod}::${name} is a valid uncleaned import from ${name}"); } @@ -162,7 +160,10 @@ for my $mod (@modules) { } # 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/) { + for my $f (qw( + carp carp_once carp_unique croak confess cluck + try catch finally dbic_internal_try dbic_internal_catch + )) { if ($mod->can($f)) { my $via; for (reverse @{mro::get_linear_isa($mod)} ) { @@ -188,9 +189,11 @@ sub find_modules { find( { wanted => sub { -f $_ or return; + $_ =~ m|lib/DBIx/Class/_TempExtlib| and return; s/\.pm$// or return; s/^ (?: lib | blib . (?:lib|arch) ) . //x; - push @modules, join ('::', File::Spec->splitdir($_)); + s/[\/\\]/::/g; + push @modules, ( $_ =~ /(.+)/ ); }, no_chdir => 1, }, ( diff --git a/xt/extra/internals/optional_deps.t b/xt/extra/internals/optional_deps.t index 7da1cc43e..e93391175 100644 --- a/xt/extra/internals/optional_deps.t +++ b/xt/extra/internals/optional_deps.t @@ -12,15 +12,34 @@ no warnings qw/once/; use Test::More; use Test::Exception; +BEGIN { + plan skip_all => 'This test breaking module loading interferes with PERL_UNICODE on perls prior to 5.12' + if exists $ENV{PERL_UNICODE} and "$]" < 5.012; +} + # load before we break require() use Scalar::Util(); use MRO::Compat(); use Carp 'confess'; use List::Util 'shuffle'; +use Config; SKIP: { - skip 'Lean load pattern testing unsafe with $ENV{PERL5OPT}', 1 if $ENV{PERL5OPT}; - skip 'Lean load pattern testing useless with $ENV{RELEASE_TESTING}', 1 if $ENV{RELEASE_TESTING}; + skip 'Lean load pattern testing makes no sense with TempExtlib', 1 + if grep { $_ =~ /TempExtlib/ } @INC; + + skip 'Lean load pattern testing unsafe with $ENV{PERL5OPT}', 1 + if $ENV{PERL5OPT}; + + skip 'Lean load pattern testing unsafe with sitecustomize.pl', 1 + if grep { $_ =~ m| \/ sitecustomize\.pl $ |x } keys %INC; + + skip 'Lean load pattern testing useless with $ENV{RELEASE_TESTING}', 1 + if $ENV{RELEASE_TESTING}; + + skip 'Lean load pattern testing useless under cperl', 1 + if $Config{usecperl}; + is_deeply $inc_before, [], diff --git a/xt/extra/internals/quote_sub.t b/xt/extra/internals/quote_sub.t index 77b490507..23fb05752 100644 --- a/xt/extra/internals/quote_sub.t +++ b/xt/extra/internals/quote_sub.t @@ -6,9 +6,11 @@ use Test::Warn; use DBIx::Class::_Util 'quote_sub'; +### Test for strictures leakage my $q = do { no strict 'vars'; - quote_sub '$x = $x . "buh"; $x += 42'; + quote_sub 'DBICTest::QSUB::nostrict' + => '$x = $x . "buh"; $x += 42'; }; warnings_exist { @@ -23,10 +25,10 @@ warnings_exist { } ; -my $no_nothing_q = do { +my $no_nothing_q = sub { no strict; no warnings; - quote_sub <<'EOC'; + quote_sub 'DBICTest::QSUB::nowarn', <<'EOC'; BEGIN { warn "-->${^WARNING_BITS}<--\n" }; my $n = "Test::Warn::warnings_exist"; warn "-->@{[ *{$n}{CODE} ]}<--\n"; @@ -35,7 +37,7 @@ EOC my $we_cref = Test::Warn->can('warnings_exist'); -warnings_exist { $no_nothing_q->() } [ +warnings_exist { $no_nothing_q->()->() } [ qr/^\-\-\>\0+\<\-\-$/m, qr/^\Q-->$we_cref<--\E$/m, ], 'Expected warnings, strict did not leak inside the qsub' diff --git a/xt/extra/internals/rsrc_ancestry.t b/xt/extra/internals/rsrc_ancestry.t new file mode 100644 index 000000000..e39f005a4 --- /dev/null +++ b/xt/extra/internals/rsrc_ancestry.t @@ -0,0 +1,82 @@ +use warnings; +use strict; + +use Config; +BEGIN { + my $skipall; + + if( ! $Config{useithreads} ) { + $skipall = 'your perl does not support ithreads'; + } + elsif( "$]" < 5.008005 ) { + $skipall = 'DBIC does not actively support threads before perl 5.8.5'; + } + elsif( $INC{'Devel/Cover.pm'} ) { + $skipall = 'Devel::Cover does not work with ithreads yet'; + } + + if( $skipall ) { + print "1..0 # SKIP $skipall\n"; + exit 0; + } +} + +use threads; +use Test::More; +use DBIx::Class::_Util 'hrefaddr'; +use Scalar::Util 'weaken'; + +{ + package DBICTest::Ancestry::Result; + + use base 'DBIx::Class::Core'; + + __PACKAGE__->table("foo"); +} + +{ + package DBICTest::Ancestry::Schema; + + use base 'DBIx::Class::Schema'; + + __PACKAGE__->register_class( r => "DBICTest::Ancestry::Result" ); +} + +my $schema = DBICTest::Ancestry::Schema->clone; +my $rsrc = $schema->resultset("r")->result_source->clone; + +threads->new( sub { + + my $another_rsrc = $rsrc->clone; + + is_deeply + refaddrify( DBICTest::Ancestry::Result->result_source_instance->__derived_instances ), + refaddrify( + DBICTest::Ancestry::Schema->source("r"), + $schema->source("r"), + $rsrc, + $another_rsrc, + ) + ; + + undef $schema; + undef $rsrc; + $another_rsrc->schema(undef); + + is_deeply + refaddrify( DBICTest::Ancestry::Result->result_source_instance->__derived_instances ), + refaddrify( + DBICTest::Ancestry::Schema->source("r"), + $another_rsrc, + ) + ; + + # tasty crashes without this + select( undef, undef, undef, 0.2 ); +})->join; + +sub refaddrify { + [ sort map { hrefaddr $_ } @_ ]; +} + +done_testing; diff --git a/t/sqlmaker/dbihacks_internals.t b/xt/extra/internals/sqla_condition_parsers.t similarity index 59% rename from t/sqlmaker/dbihacks_internals.t rename to xt/extra/internals/sqla_condition_parsers.t index ca8173784..98a76b088 100644 --- a/t/sqlmaker/dbihacks_internals.t +++ b/xt/extra/internals/sqla_condition_parsers.t @@ -1,14 +1,16 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; -use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION'; +use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dump_value ); +use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); -use Data::Dumper; BEGIN { if ( eval { require Test::Differences } ) { no warnings 'redefine'; @@ -16,8 +18,7 @@ BEGIN { } } -my $schema = DBICTest->init_schema( no_deploy => 1); -my $sm = $schema->storage->sql_maker; +my $sm = DBICTest->init_schema( no_deploy => 1)->storage->sql_maker; { package # hideee @@ -33,98 +34,100 @@ my $num = bless( \do { my $foo = 69 }, 'DBICTest::SillyInt' ); is($num, 69, 'test overloaded object is "sane"'); is("$num", 69, 'test overloaded object is "sane"'); +my $AttUQoLtUaE = 42; +my $PVIVmaker = $AttUQoLtUaE . ''; + my @tests = ( { where => { artistid => 1, charfield => undef }, - cc_result => { artistid => 1, charfield => undef }, + normalized => { artistid => 1, charfield => undef }, sql => 'WHERE artistid = ? AND charfield IS NULL', - efcc_result => { artistid => 1 }, - efcc_n_result => { artistid => 1, charfield => undef }, + equality_extract => { artistid => 1 }, + equality_considering_nulls_extract => { artistid => 1, charfield => undef }, }, { where => { -and => [ artistid => 1, charfield => undef, { rank => 13 } ] }, - cc_result => { artistid => 1, charfield => undef, rank => 13 }, + normalized => { artistid => 1, charfield => undef, rank => 13 }, sql => 'WHERE artistid = ? AND charfield IS NULL AND rank = ?', - efcc_result => { artistid => 1, rank => 13 }, - efcc_n_result => { artistid => 1, charfield => undef, rank => 13 }, + equality_extract => { artistid => 1, rank => 13 }, + equality_considering_nulls_extract => { artistid => 1, charfield => undef, rank => 13 }, }, { where => { -and => [ { artistid => 1, charfield => undef}, { rank => 13 } ] }, - cc_result => { artistid => 1, charfield => undef, rank => 13 }, + normalized => { artistid => 1, charfield => undef, rank => 13 }, sql => 'WHERE artistid = ? AND charfield IS NULL AND rank = ?', - efcc_result => { artistid => 1, rank => 13 }, - efcc_n_result => { artistid => 1, charfield => undef, rank => 13 }, + equality_extract => { artistid => 1, rank => 13 }, + equality_considering_nulls_extract => { artistid => 1, charfield => undef, rank => 13 }, }, { where => { -and => [ -or => { name => 'Caterwauler McCrae' }, 'rank' ] }, - cc_result => { name => 'Caterwauler McCrae', rank => undef }, + normalized => { name => 'Caterwauler McCrae', rank => undef }, sql => 'WHERE name = ? AND rank IS NULL', - efcc_result => { name => 'Caterwauler McCrae' }, - efcc_n_result => { name => 'Caterwauler McCrae', rank => undef }, + equality_extract => { name => 'Caterwauler McCrae' }, + equality_considering_nulls_extract => { name => 'Caterwauler McCrae', rank => undef }, }, { where => { -and => [ [ [ artist => {'=' => \'foo' } ] ], { name => \[ '= ?', 'bar' ] } ] }, - cc_result => { artist => {'=' => \'foo' }, name => \[ '= ?', 'bar' ] }, + normalized => { artist => {'=' => \'foo' }, name => \[ '= ?', 'bar' ] }, sql => 'WHERE artist = foo AND name = ?', - efcc_result => { artist => \'foo' }, + equality_extract => { artist => \'foo' }, }, { where => { -and => [ -or => { name => 'Caterwauler McCrae', artistid => 2 } ] }, - cc_result => { -or => [ artistid => 2, name => 'Caterwauler McCrae' ] }, + normalized => { -or => [ artistid => 2, name => 'Caterwauler McCrae' ] }, sql => 'WHERE artistid = ? OR name = ?', - efcc_result => {}, + equality_extract => {}, }, { where => { -or => { name => 'Caterwauler McCrae', artistid => 2 } }, - cc_result => { -or => [ artistid => 2, name => 'Caterwauler McCrae' ] }, + normalized => { -or => [ artistid => 2, name => 'Caterwauler McCrae' ] }, sql => 'WHERE artistid = ? OR name = ?', - efcc_result => {}, + equality_extract => {}, }, { where => { -and => [ \'foo=bar', [ { artistid => { '=', $num } } ], { name => 'Caterwauler McCrae'} ] }, - cc_result => { -and => [ \'foo=bar' ], name => 'Caterwauler McCrae', artistid => $num }, + normalized => { -and => [ \'foo=bar' ], name => 'Caterwauler McCrae', artistid => $num }, sql => 'WHERE foo=bar AND artistid = ? AND name = ?', - efcc_result => { name => 'Caterwauler McCrae', artistid => $num }, + equality_extract => { name => 'Caterwauler McCrae', artistid => $num }, }, { where => { -and => [ \'foo=bar', [ { artistid => { '=', $num } } ], { name => 'Caterwauler McCrae'}, \'buzz=bozz' ] }, - cc_result => { -and => [ \'foo=bar', \'buzz=bozz' ], name => 'Caterwauler McCrae', artistid => $num }, - sql => 'WHERE foo=bar AND artistid = ? AND name = ? AND buzz=bozz', - collapsed_sql => 'WHERE foo=bar AND buzz=bozz AND artistid = ? AND name = ?', - efcc_result => { name => 'Caterwauler McCrae', artistid => $num }, + normalized => { -and => [ \'buzz=bozz', \'foo=bar' ], name => 'Caterwauler McCrae', artistid => $num }, + sql => 'WHERE foo=bar AND artistid = ? AND name = ? AND buzz=bozz', + normalized_sql => 'WHERE buzz=bozz AND foo=bar AND artistid = ? AND name = ?', + equality_extract => { name => 'Caterwauler McCrae', artistid => $num }, }, { where => { artistid => [ $num ], rank => [ 13, 2, 3 ], charfield => [ undef ] }, - cc_result => { artistid => $num, charfield => undef, rank => [13, 2, 3] }, + normalized => { artistid => $num, charfield => undef, rank => [13, 2, 3] }, sql => 'WHERE artistid = ? AND charfield IS NULL AND ( rank = ? OR rank = ? OR rank = ? )', - efcc_result => { artistid => $num }, - efcc_n_result => { artistid => $num, charfield => undef }, + equality_extract => { artistid => $num }, + equality_considering_nulls_extract => { artistid => $num, charfield => undef }, }, { where => { artistid => { '=' => 1 }, rank => { '>' => 12 }, charfield => { '=' => undef } }, - cc_result => { artistid => 1, charfield => undef, rank => { '>' => 12 } }, + normalized => { artistid => 1, charfield => undef, rank => { '>' => 12 } }, sql => 'WHERE artistid = ? AND charfield IS NULL AND rank > ?', - efcc_result => { artistid => 1 }, - efcc_n_result => { artistid => 1, charfield => undef }, + equality_extract => { artistid => 1 }, + equality_considering_nulls_extract => { artistid => 1, charfield => undef }, }, { where => { artistid => { '=' => [ 1 ], }, charfield => { '=' => [ -AND => \'1', \['?',2] ] }, rank => { '=' => [ -OR => $num, $num ] } }, - cc_result => { artistid => 1, charfield => [-and => { '=' => \['?',2] }, { '=' => \'1' } ], rank => { '=' => [$num, $num] } }, - sql => 'WHERE artistid = ? AND charfield = 1 AND charfield = ? AND ( rank = ? OR rank = ? )', - collapsed_sql => 'WHERE artistid = ? AND charfield = ? AND charfield = 1 AND ( rank = ? OR rank = ? )', - efcc_result => { artistid => 1, charfield => UNRESOLVABLE_CONDITION }, + normalized => { artistid => 1, charfield => [-and => { '=' => \'1' }, { '=' => \['?',2] } ], rank => { '=' => [$num, $num] } }, + sql => 'WHERE artistid = ? AND charfield = 1 AND charfield = ? AND ( rank = ? OR rank = ? )', + equality_extract => { artistid => 1, charfield => UNRESOLVABLE_CONDITION }, }, { where => { -and => [ artistid => 1, artistid => 2 ], name => [ -and => { '!=', 1 }, 2 ], charfield => [ -or => { '=', 2 } ], rank => [-and => undef, { '=', undef }, { '!=', 2 } ] }, - cc_result => { artistid => [ -and => 1, 2 ], name => [ -and => { '!=', 1 }, 2 ], charfield => 2, rank => [ -and => { '!=', 2 }, undef ] }, - sql => 'WHERE artistid = ? AND artistid = ? AND charfield = ? AND name != ? AND name = ? AND rank IS NULL AND rank IS NULL AND rank != ?', - collapsed_sql => 'WHERE artistid = ? AND artistid = ? AND charfield = ? AND name != ? AND name = ? AND rank != ? AND rank IS NULL', - efcc_result => { + normalized => { artistid => [ -and => 1, 2 ], name => [ -and => { '!=', 1 }, 2 ], charfield => 2, rank => [ -and => { '!=', 2 }, undef ] }, + sql => 'WHERE artistid = ? AND artistid = ? AND charfield = ? AND name != ? AND name = ? AND rank IS NULL AND rank IS NULL AND rank != ?', + normalized_sql => 'WHERE artistid = ? AND artistid = ? AND charfield = ? AND name != ? AND name = ? AND rank != ? AND rank IS NULL', + equality_extract => { artistid => UNRESOLVABLE_CONDITION, name => 2, charfield => 2, }, - efcc_n_result => { + equality_considering_nulls_extract => { artistid => UNRESOLVABLE_CONDITION, name => 2, charfield => 2, @@ -133,19 +136,19 @@ my @tests = ( }, (map { { where => $_, - sql => 'WHERE (rank = 13 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank != 42)', - collapsed_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank = 13) AND (artistid = ? OR charfield IS NULL OR rank != 42)', - cc_result => { -and => [ - { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, + sql => 'WHERE (rank = 13 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank != 42)', + normalized_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank != 42) AND (artistid = ? OR charfield IS NULL OR rank = 13)', + normalized => { -and => [ { -or => [ artistid => 1, charfield => undef, rank => { '!=' => \42 } ] }, + { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, ] }, - efcc_result => {}, - efcc_n_result => {}, + equality_extract => {}, + equality_considering_nulls_extract => {}, } } ( { -and => [ -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ], - -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '!=' => \42 } }, + -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '!=' => \$AttUQoLtUaE } }, ] }, { @@ -161,37 +164,51 @@ my @tests = ( baz => { '!=' => { -ident => 'bozz' } }, baz => { -ident => 'buzz' }, ] }, - sql => 'WHERE ( foo IS NOT NULL AND bar IN ( ?, ? ) ) OR foo IS NULL OR baz != bozz OR baz = buzz', - collapsed_sql => 'WHERE baz != bozz OR baz = buzz OR foo IS NULL OR ( bar IN ( ?, ? ) AND foo IS NOT NULL )', - cc_result => { -or => [ + sql => 'WHERE ( foo IS NOT NULL AND bar IN ( ?, ? ) ) OR foo IS NULL OR baz != bozz OR baz = buzz', + normalized_sql => 'WHERE baz != bozz OR baz = buzz OR foo IS NULL OR ( bar IN ( ?, ? ) AND foo IS NOT NULL )', + normalized => { -or => [ baz => { '!=' => { -ident => 'bozz' } }, baz => { '=' => { -ident => 'buzz' } }, foo => undef, { bar => { -in => [ 69, 42 ] }, foo => { '!=', undef } } ] }, - efcc_result => {}, + equality_extract => {}, }, { where => { -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => { '=' => 1 }, genreid => { '=' => \['?', 2] } ] }, - sql => 'WHERE rank = 13 OR charfield IS NULL OR artistid = ? OR genreid = ?', - collapsed_sql => 'WHERE artistid = ? OR charfield IS NULL OR genreid = ? OR rank = 13', - cc_result => { -or => [ artistid => 1, charfield => undef, genreid => { '=' => \['?', 2] }, rank => { '=' => \13 } ] }, - efcc_result => {}, - efcc_n_result => {}, + sql => 'WHERE rank = 13 OR charfield IS NULL OR artistid = ? OR genreid = ?', + normalized_sql => 'WHERE artistid = ? OR charfield IS NULL OR genreid = ? OR rank = 13', + normalized => { -or => [ artistid => 1, charfield => undef, genreid => { '=' => \['?', 2] }, rank => { '=' => \13 } ] }, + equality_extract => {}, + equality_considering_nulls_extract => {}, }, { where => { -and => [ - -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ], - -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '=' => \13 } }, + -or => [ rank => { '=' => \$AttUQoLtUaE }, charfield => { '=' => undef }, artistid => 1 ], + -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '=' => \42 } }, ] }, - cc_result => { -and => [ - { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, - { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, + normalized => { + -or => [ artistid => 1, charfield => undef, rank => { '=' => \42 } ], + }, + sql => 'WHERE (rank = 42 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank = 42)', + normalized_sql => 'WHERE artistid = ? OR charfield IS NULL OR rank = 42', + equality_extract => {}, + equality_considering_nulls_extract => {}, + }, + { + where => { -and => [ + { -or => [ \42 ] }, + { -and => [ + { -or => [ \$AttUQoLtUaE ] }, + { -or => [ \13 ] }, + ] }, ] }, - sql => 'WHERE (rank = 13 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank = 13)', - collapsed_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank = 13) AND (artistid = ? OR charfield IS NULL OR rank = 13)', - efcc_result => {}, - efcc_n_result => {}, + normalized => { + -and => [ \13, \42 ], + }, + sql => 'WHERE 42 AND 42 AND 13', + normalized_sql => 'WHERE 13 AND 42', + equality_extract => {}, }, { where => { -and => [ @@ -216,35 +233,35 @@ my @tests = ( AND NOT foo = ? AND NOT foo = ? ', - collapsed_sql => 'WHERE - ( artistid = ? OR charfield IS NULL OR rank = 13 ) - AND ( artistid = ? OR charfield IS NULL OR rank != 42 ) - AND (EXISTS (SELECT 1)) + normalized_sql => 'WHERE + (EXISTS (SELECT 1)) AND (EXISTS (SELECT 2)) AND NOT foo = ? AND NOT foo = ? + AND ( artistid = ? OR charfield IS NULL OR rank != 42 ) + AND ( artistid = ? OR charfield IS NULL OR rank = 13 ) AND bar = 4 AND bar = ? AND foo = 1 AND foo = ? ', - cc_result => { + normalized => { -and => [ - { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, - { -or => [ artistid => 1, charfield => undef, rank => { '!=' => \42 } ] }, { -exists => \'(SELECT 1)' }, { -exists => \'(SELECT 2)' }, - { -not => { foo => 69 } }, { -not => { foo => 42 } }, + { -not => { foo => 69 } }, + { -or => [ artistid => 1, charfield => undef, rank => { '!=' => \42 } ] }, + { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, ], foo => [ -and => { '=' => \1 }, 3 ], bar => [ -and => { '=' => \4 }, 2 ], }, - efcc_result => { + equality_extract => { foo => UNRESOLVABLE_CONDITION, bar => UNRESOLVABLE_CONDITION, }, - efcc_n_result => { + equality_considering_nulls_extract => { foo => UNRESOLVABLE_CONDITION, bar => UNRESOLVABLE_CONDITION, }, @@ -254,7 +271,7 @@ my @tests = ( [ '_macro.to' => { -like => '%correct%' }, '_wc_macros.to' => { -like => '%correct%' } ], { -and => [ { 'group.is_active' => 1 }, { 'me.is_active' => 1 } ] } ] }, - cc_result => { + normalized => { 'group.is_active' => 1, 'me.is_active' => 1, -or => [ @@ -263,7 +280,7 @@ my @tests = ( ], }, sql => 'WHERE ( _macro.to LIKE ? OR _wc_macros.to LIKE ? ) AND group.is_active = ? AND me.is_active = ?', - efcc_result => { 'group.is_active' => 1, 'me.is_active' => 1 }, + equality_extract => { 'group.is_active' => 1, 'me.is_active' => 1 }, }, { @@ -272,20 +289,23 @@ my @tests = ( charfield => { -ident => 'foo' }, name => { '=' => { -value => undef } }, rank => { '=' => { -ident => 'bar' } }, + arrayfield => { '>' => { -value => [3,1] } }, ] }, - sql => 'WHERE artistid = ? AND charfield = foo AND name IS NULL AND rank = bar', - cc_result => { + normalized => { artistid => { -value => [1] }, name => undef, charfield => { '=', { -ident => 'foo' } }, rank => { '=' => { -ident => 'bar' } }, + arrayfield => { '>' => { -value => [3,1] } }, }, - efcc_result => { + sql => 'WHERE artistid = ? AND charfield = foo AND name IS NULL AND rank = bar AND arrayfield > ?', + normalized_sql => 'WHERE arrayfield > ? AND artistid = ? AND charfield = foo AND name IS NULL AND rank = bar', + equality_extract => { artistid => [1], charfield => { -ident => 'foo' }, rank => { -ident => 'bar' }, }, - efcc_n_result => { + equality_considering_nulls_extract => { artistid => [1], name => undef, charfield => { -ident => 'foo' }, @@ -295,40 +315,40 @@ my @tests = ( { where => { artistid => [] }, - cc_result => { artistid => [] }, - efcc_result => {}, + normalized => { artistid => [] }, + equality_extract => {}, }, (map { { where => { -and => $_ }, - cc_result => undef, - efcc_result => {}, + normalized => undef, + equality_extract => {}, sql => '', }, { where => { -or => $_ }, - cc_result => undef, - efcc_result => {}, + normalized => undef, + equality_extract => {}, sql => '', }, { where => { -or => [ foo => 1, $_ ] }, - cc_result => { foo => 1 }, - efcc_result => { foo => 1 }, + normalized => { foo => 1 }, + equality_extract => { foo => 1 }, sql => 'WHERE foo = ?', }, { where => { -or => [ $_, foo => 1 ] }, - cc_result => { foo => 1 }, - efcc_result => { foo => 1 }, + normalized => { foo => 1 }, + equality_extract => { foo => 1 }, sql => 'WHERE foo = ?', }, { where => { -and => [ fuu => 2, $_, foo => 1 ] }, - sql => 'WHERE fuu = ? AND foo = ?', - collapsed_sql => 'WHERE foo = ? AND fuu = ?', - cc_result => { foo => 1, fuu => 2 }, - efcc_result => { foo => 1, fuu => 2 }, + sql => 'WHERE fuu = ? AND foo = ?', + normalized_sql => 'WHERE foo = ? AND fuu = ?', + normalized => { foo => 1, fuu => 2 }, + equality_extract => { foo => 1, fuu => 2 }, }, } ( # bare @@ -342,16 +362,16 @@ my @tests = ( )), # FIXME legacy compat crap, possibly worth undef/dieing in SQLMaker - { where => { artistid => {} }, sql => '', cc_result => undef, efcc_result => {}, efcc_n_result => {} }, + { where => { artistid => {} }, sql => '', normalized => undef, equality_extract => {}, equality_considering_nulls_extract => {} }, # batshit insanity, just to be thorough { where => { -and => [ [ 'artistid' ], [ -and => [ artistid => { '!=', 69 }, artistid => undef, artistid => { '=' => 200 } ]], artistid => [], { -or => [] }, { -and => [] }, [ 'charfield' ], { name => [] }, 'rank' ] }, - cc_result => { artistid => [ -and => [], { '!=', 69 }, undef, 200 ], charfield => undef, name => [], rank => undef }, - sql => 'WHERE artistid IS NULL AND artistid != ? AND artistid IS NULL AND artistid = ? AND 0=1 AND charfield IS NULL AND 0=1 AND rank IS NULL', - collapsed_sql => 'WHERE 0=1 AND artistid != ? AND artistid IS NULL AND artistid = ? AND charfield IS NULL AND 0=1 AND rank IS NULL', - efcc_result => { artistid => UNRESOLVABLE_CONDITION }, - efcc_n_result => { artistid => UNRESOLVABLE_CONDITION, charfield => undef, rank => undef }, + normalized => { artistid => [ -and => [], { '!=', 69 }, undef, 200 ], charfield => undef, name => [], rank => undef }, + sql => 'WHERE artistid IS NULL AND artistid != ? AND artistid IS NULL AND artistid = ? AND 0=1 AND charfield IS NULL AND 0=1 AND rank IS NULL', + normalized_sql => 'WHERE 0=1 AND artistid != ? AND artistid IS NULL AND artistid = ? AND charfield IS NULL AND 0=1 AND rank IS NULL', + equality_extract => { artistid => UNRESOLVABLE_CONDITION }, + equality_considering_nulls_extract => { artistid => UNRESOLVABLE_CONDITION, charfield => undef, rank => undef }, }, # original test from RT#93244 @@ -364,7 +384,7 @@ my @tests = ( ], [ { 'me.title' => 'Spoonful of bees' } ], ]}, - cc_result => { + normalized => { -and => [ \[ "LOWER(me.title) LIKE ?", '%spoon%', @@ -372,7 +392,7 @@ my @tests = ( 'me.title' => 'Spoonful of bees', }, sql => 'WHERE LOWER(me.title) LIKE ? AND me.title = ?', - efcc_result => { 'me.title' => 'Spoonful of bees' }, + equality_extract => { 'me.title' => 'Spoonful of bees' }, }, # crazy literals @@ -383,12 +403,12 @@ my @tests = ( ], }, sql => 'WHERE foo = bar', - cc_result => { + normalized => { -and => [ \'foo = bar', ], }, - efcc_result => {}, + equality_extract => {}, }, { where => { @@ -397,15 +417,15 @@ my @tests = ( \'baz = ber', ], }, - sql => 'WHERE foo = bar OR baz = ber', - collapsed_sql => 'WHERE baz = ber OR foo = bar', - cc_result => { + sql => 'WHERE foo = bar OR baz = ber', + normalized_sql => 'WHERE baz = ber OR foo = bar', + normalized => { -or => [ \'baz = ber', \'foo = bar', ], }, - efcc_result => {}, + equality_extract => {}, }, { where => { @@ -414,14 +434,15 @@ my @tests = ( \'baz = ber', ], }, - sql => 'WHERE foo = bar AND baz = ber', - cc_result => { + normalized => { -and => [ - \'foo = bar', \'baz = ber', + \'foo = bar', ], }, - efcc_result => {}, + sql => 'WHERE foo = bar AND baz = ber', + normalized_sql => 'WHERE baz = ber AND foo = bar', + equality_extract => {}, }, { where => { @@ -431,15 +452,16 @@ my @tests = ( x => { -ident => 'y' }, ], }, - sql => 'WHERE foo = bar AND baz = ber AND x = y', - cc_result => { + normalized => { -and => [ - \'foo = bar', \'baz = ber', + \'foo = bar', ], x => { '=' => { -ident => 'y' } } }, - efcc_result => { x => { -ident => 'y' } }, + sql => 'WHERE foo = bar AND baz = ber AND x = y', + normalized_sql => 'WHERE baz = ber AND foo = bar AND x = y', + equality_extract => { x => { -ident => 'y' } }, }, ); @@ -494,8 +516,8 @@ for my $lhs (undef, '') { push @tests, { where => { $lhs => $rhs }, - cc_result => { -and => [ $rhs ] }, - efcc_result => {}, + normalized => { -and => [ $rhs ] }, + equality_extract => {}, sql => 'WHERE baz', warn => $expected_warning, }; @@ -506,12 +528,12 @@ for my $lhs (undef, '') { ) { push @tests, { where => $w, - cc_result => { + normalized => { -and => [ $rhs ], bizz => "buzz", foo => "bar", }, - efcc_result => { + equality_extract => { foo => "bar", bizz => "buzz", }, @@ -538,12 +560,12 @@ for my $eq ( ) { push @tests, { where => $where, - cc_result => { + normalized => { 0 => $eq, foo => 'bar', bizz => 'buzz', }, - efcc_result => { + equality_extract => { foo => 'bar', bizz => 'buzz', ( ref $eq eq 'HASH' ? ( 0 => $eq->{'='} ) : () ), @@ -553,12 +575,12 @@ for my $eq ( push @tests, { where => { -or => $where }, - cc_result => { -or => [ + normalized => { -or => [ "0" => $eq, bizz => 'buzz', foo => 'bar', ]}, - efcc_result => {}, + equality_extract => {}, sql => 'WHERE 0 = baz OR bizz = ? OR foo = ?', } @@ -573,14 +595,14 @@ for my $eq ( ) { push @tests, { where => { -or => $where }, - cc_result => { -or => [ + normalized => { -or => [ "0" => $eq, bizz => 'buzz', foo => 'bar', ]}, - efcc_result => {}, - sql => 'WHERE foo = ? OR 0 = baz OR bizz = ?', - collapsed_sql => 'WHERE 0 = baz OR bizz = ? OR foo = ?', + equality_extract => {}, + sql => 'WHERE foo = ? OR 0 = baz OR bizz = ?', + normalized_sql => 'WHERE 0 = baz OR bizz = ? OR foo = ?', } } @@ -590,14 +612,14 @@ for my $eq ( ) { push @tests, { where => { -or => $where }, - cc_result => { -or => [ + normalized => { -or => [ "0" => 'baz', bizz => 'buzz', foo => 'bar', ]}, - efcc_result => {}, - sql => 'WHERE foo = ? OR 0 = ? OR bizz = ?', - collapsed_sql => 'WHERE 0 = ? OR bizz = ? OR foo = ?', + equality_extract => {}, + sql => 'WHERE foo = ? OR 0 = ? OR bizz = ?', + normalized_sql => 'WHERE 0 = ? OR bizz = ? OR foo = ?', }; } @@ -624,27 +646,26 @@ for my $t (@tests) { ) { die unless Test::Builder->new->is_passing; - my $name = do { local ($Data::Dumper::Indent, $Data::Dumper::Terse, $Data::Dumper::Sortkeys) = (0, 1, 1); Dumper $w }; + my $name = do { local $Data::Dumper::Indent = 0; dump_value $w }; - my ($collapsed_cond, $collapsed_cond_as_sql); + my ($normalized_cond, $normalized_cond_as_sql); if ($t->{throw}) { throws_ok { - $collapsed_cond = $schema->storage->_collapse_cond($w); - ($collapsed_cond_as_sql) = $sm->where($collapsed_cond); + $sm->where( normalize_sqla_condition($w) ); } $t->{throw}, "Exception on attempted collapse/render of $name" and next; } warnings_exist { - $collapsed_cond = $schema->storage->_collapse_cond($w); - ($collapsed_cond_as_sql) = $sm->where($collapsed_cond); + $normalized_cond = normalize_sqla_condition($w); + ($normalized_cond_as_sql) = $sm->where($normalized_cond); } $t->{warn} || [], "Expected warning when collapsing/rendering $name"; is_deeply( - $collapsed_cond, - $t->{cc_result}, + $normalized_cond, + $t->{normalized}, "Expected collapsed condition produced on $name", ); @@ -657,29 +678,35 @@ for my $t (@tests) { if exists $t->{sql}; is_same_sql( - $collapsed_cond_as_sql, - ( $t->{collapsed_sql} || $t->{sql} || $original_sql ), - "Collapse did not alter *the semantics* of the final SQL based on $name", + $normalized_cond_as_sql, + ( $t->{normalized_sql} || $t->{sql} || $original_sql ), + "Normalization did not alter *the semantics* of the final SQL based on $name", ); is_deeply( - $schema->storage->_extract_fixed_condition_columns($collapsed_cond), - $t->{efcc_result}, - "Expected fixed_condition produced on $name", + extract_equality_conditions($normalized_cond), + $t->{equality_extract}, + "Expected equality_conditions produced on $name", ); is_deeply( - $schema->storage->_extract_fixed_condition_columns($collapsed_cond, 'consider_nulls'), - $t->{efcc_n_result}, - "Expected fixed_condition including NULLs produced on $name", - ) if $t->{efcc_n_result}; + extract_equality_conditions($normalized_cond, 'consider_nulls'), + ( $t->{equality_considering_nulls_extract} || $t->{equality_extract} ), + "Expected equality_conditions including NULLs produced on $name", + ); is_deeply( - $collapsed_cond, - $t->{cc_result}, - "Collapsed condition result unaltered by fixed condition extractor", + $normalized_cond, + $t->{normalized}, + "Collapsed condition result unaltered by equality conditions extractor", ); } } +# test separately +is_deeply( + normalize_sqla_condition( UNRESOLVABLE_CONDITION ), + { -and => [ UNRESOLVABLE_CONDITION ] }, +); + done_testing; diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index 8c220dd74..b53d1e8f9 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -1,32 +1,35 @@ # Use a require override instead of @INC munging (less common) # Do the override as early as possible so that CORE::require doesn't get compiled away -my ($initial_inc_contents, $expected_dbic_deps, $require_sites); BEGIN { - # these envvars *will* bring in more stuff than the baseline - delete @ENV{qw(DBICTEST_SQLT_DEPLOY DBIC_TRACE)}; - - # make sure extras do not load even when this is set - $ENV{PERL_STRICTURES_EXTRA} = 1; + if ( $ENV{RELEASE_TESTING} ) { + require warnings and warnings->import; + require strict and strict->import; + } +} +my ($initial_inc_contents, $expected_dbic_deps, $require_sites, %stack); +BEGIN { unshift @INC, 't/lib'; require DBICTest::Util::OverrideRequire; DBICTest::Util::OverrideRequire::override_global_require( sub { my $res = $_[0]->(); + return $res if $stack{neutralize_override}; + my $req = $_[1]; $req =~ s/\.pm$//; $req =~ s/\//::/g; my $up = 0; my @caller; - do { @caller = caller($up++) } while ( + do { @caller = CORE::caller($up++) } while ( @caller and ( # exclude our test suite, known "module require-rs" and eval frames - $caller[1] =~ /^ t [\/\\] /x + $caller[1] =~ / (?: \A | [\/\\] ) x?t [\/\\] /x or - $caller[0] =~ /^ (?: base | parent | Class::C3::Componentised | Module::Inspector | Module::Runtime ) $/x + $caller[0] =~ /^ (?: base | parent | Class::C3::Componentised | Module::Inspector | Module::Runtime | DBIx::Class::Optional::Dependencies ) $/x or $caller[3] eq '(eval)', ) @@ -37,8 +40,11 @@ BEGIN { return $res if $req =~ /^DBIx::Class|^DBICTest::/; - # exclude everything where the current namespace does not match the called function - # (this works around very weird XS-induced require callstack corruption) + # Some modules have a bare 'use $perl_version' as the first statement + # Since the use() happens before 'package' had a chance to switch + # the namespace, the shim thinks DBIC* tried to require this + return $res if $req =~ /^v?[0-9.]+$/; + if ( !$initial_inc_contents->{$req} and @@ -47,14 +53,28 @@ BEGIN { @caller and $caller[0] =~ /^DBIx::Class/ - and - (caller($up))[3] =~ /\Q$caller[0]/ ) { - CORE::require('Test/More.pm'); + local $stack{neutralize_override} = 1; + + # find last-most frame, to feed to T::B below + while( CORE::caller(++$up) ) { 1 } + + require('Test/More.pm'); + local $Test::Builder::Level = $up + 1; + + # work around the trainwreck that is https://github.com/doy/package-stash-xs/pull/4 + local $::TODO = 'sigh' if ( + $INC{'Package/Stash/XS.pm'} + and + $req eq 'utf8' + ); + Test::More::fail ("Unexpected require of '$req' by $caller[0] ($caller[1] line $caller[2])"); - CORE::require('DBICTest/Util.pm'); - Test::More::diag( 'Require invoked' . DBICTest::Util::stacktrace() ); + unless( $::TODO ) { + require('DBICTest/Util.pm'); + Test::More::diag( 'Require invoked' . DBICTest::Util::stacktrace() ); + } } return $res; @@ -69,9 +89,31 @@ BEGIN { plan skip_all => 'A defined PERL5OPT may inject extra deps crashing this test' if $ENV{PERL5OPT}; + plan skip_all => 'Presence of sitecustomize.pl may inject extra deps crashing this test' + if grep { $_ =~ m| \/ sitecustomize\.pl $ |x } keys %INC; + plan skip_all => 'Dependency load patterns are radically different before perl 5.10' if "$]" < 5.010; + # these envvars *will* bring in more stuff than the baseline + delete @ENV{qw( + DBIC_TRACE + DBIC_SHUFFLE_UNORDERED_RESULTSETS + DBICTEST_SQLT_DEPLOY + DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER + DBICTEST_VIA_REPLICATED + DBICTEST_DEBUG_CONCURRENCY_LOCKS + )}; + + # ensures the checker won't be disabled in + # t/lib/DBICTest/BaseSchema.pm + $ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS} = 1; + + $ENV{DBICTEST_ANFANG_DEFANG} = 1; + + # make sure extras do not load even when this is set + $ENV{PERL_STRICTURES_EXTRA} = 1; + # add what we loaded so far for (keys %INC) { my $mod = $_; @@ -81,12 +123,6 @@ BEGIN { } } -BEGIN { - delete $ENV{$_} for qw( - DBICTEST_VIA_REPLICATED - DBICTEST_DEBUG_CONCURRENCY_LOCKS - ); -} ####### ### This is where the test starts @@ -105,21 +141,24 @@ BEGIN { Carp namespace::clean - Try::Tiny Sub::Name Sub::Defer Sub::Quote + attributes Scalar::Util - List::Util Storable Class::Accessor::Grouped Class::C3::Componentised - SQL::Abstract )); - require DBICTest::Schema; + # load Storable ourselves here - there are too many + # variations with DynaLoader and XSLoader making testing + # for it rather unstable + require Storable; + + require DBIx::Class::Schema; assert_no_missing_expected_requires(); } @@ -131,9 +170,10 @@ BEGIN { Method::Generate::Accessor Method::Generate::Constructor Context::Preserve + SQL::Abstract )); - my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); + my $s = DBIx::Class::Schema->connect('dbi:SQLite::memory:'); ok (! $s->storage->connected, 'no connection'); assert_no_missing_expected_requires(); } @@ -143,9 +183,55 @@ BEGIN { register_lazy_loadable_requires(qw( DBI Hash::Merge + Data::Dumper )); - my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); + { + eval <<'EOP' or die $@; + + package DBICTest::Result::Artist; + + use warnings; + use strict; + + use base 'DBIx::Class::Core'; + + __PACKAGE__->table("artist"); + + __PACKAGE__->add_columns( + artistid => { + data_type => 'integer', + is_auto_increment => 1, + }, + name => { + data_type => 'varchar', + size => 100, + is_nullable => 1, + }, + rank => { + data_type => 'integer', + default_value => 13, + }, + charfield => { + data_type => 'char', + size => 10, + is_nullable => 1, + }, + ); + + __PACKAGE__->set_primary_key('artistid'); + __PACKAGE__->add_unique_constraint(['name']); + __PACKAGE__->add_unique_constraint(u_nullable => [qw/charfield rank/]); + + 1; + +EOP + } + + my $s = DBIx::Class::Schema->connect('dbi:SQLite::memory:'); + + $s->register_class( Artist => 'DBICTest::Result::Artist' ); + $s->storage->dbh_do(sub { $_[1]->do('CREATE TABLE artist ( "artistid" INTEGER PRIMARY KEY NOT NULL, @@ -158,24 +244,27 @@ BEGIN { my $art = $s->resultset('Artist')->create({ name => \[ '?' => 'foo'], rank => 42 }); $art->discard_changes; $art->update({ rank => 69, name => 'foo' }); + $s->resultset('Artist')->all; assert_no_missing_expected_requires(); } -# and do full populate() as well, just in case - shouldn't add new stuff + +# and do full DBICTest based populate() as well, just in case - shouldn't add new stuff { - local $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}; - { - # in general we do not want DBICTest to load before sqla, but it is - # ok to cheat here - local $INC{'SQL/Abstract.pm'}; - require DBICTest; - } + # DBICTest needs File::Spec, but older versions of Storable load it alread + # Instead of adding a contrived conditional, just preempt the testing entirely + require File::Spec; + + require DBICTest; + DBICTest->import; + my $s = DBICTest->init_schema; - is ($s->resultset('Artist')->find(1)->name, 'Caterwauler McCrae'); - assert_no_missing_expected_requires(); + is ($s->resultset('Artist')->find(1)->name, 'Caterwauler McCrae', 'Expected find() result'); } done_testing; +# one final quiet guard to run at all times +END { assert_no_missing_expected_requires('quiet') }; sub register_lazy_loadable_requires { local $Test::Builder::Level = $Test::Builder::Level + 1; @@ -194,7 +283,8 @@ sub register_lazy_loadable_requires { # check if anything we were expecting didn't actually load sub assert_no_missing_expected_requires { - my $nl; + my $quiet = shift; + for my $mod (keys %$expected_dbic_deps) { (my $modfn = "$mod.pm") =~ s/::/\//g; fail sprintf ( @@ -203,9 +293,10 @@ sub assert_no_missing_expected_requires { __FILE__ ) unless $INC{$modfn}; } + pass(sprintf 'All modules expected at %s line %s loaded by DBIC: %s', __FILE__, (caller(0))[2], join (', ', sort keys %$expected_dbic_deps ), - ) unless $nl; + ) unless $quiet; } diff --git a/xt/extra/multicreate_opcount.t b/xt/extra/multicreate_opcount.t index 4184f06e0..06369d928 100644 --- a/xt/extra/multicreate_opcount.t +++ b/xt/extra/multicreate_opcount.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -7,7 +9,7 @@ BEGIN { } use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/xt/extra/sqlite_deadlock.t b/xt/extra/sqlite_deadlock.t index a9fdca95f..f50175e1c 100644 --- a/xt/extra/sqlite_deadlock.t +++ b/xt/extra/sqlite_deadlock.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -5,7 +7,7 @@ use Test::More; use Test::Exception; use File::Temp (); -use lib 't/lib'; + use DBICTest; plan tests => 2; diff --git a/xt/extra/sqlite_view_deps.t b/xt/extra/sqlite_view_deps.t index 39bb63252..3aabe1594 100644 --- a/xt/extra/sqlite_view_deps.t +++ b/xt/extra/sqlite_view_deps.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'deploy'; use strict; @@ -6,7 +7,7 @@ use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest; use ViewDeps; use ViewDepsBad; diff --git a/t/54taint.t b/xt/extra/taint.t similarity index 92% rename from t/54taint.t rename to xt/extra/taint.t index 6b866e6d1..93190c32f 100644 --- a/t/54taint.t +++ b/xt/extra/taint.t @@ -1,10 +1,26 @@ +BEGIN { $ENV{DBICTEST_ANFANG_DEFANG} = 1 } + +# When in taint mode, PERL5LIB is ignored (but *not* unset) +# Put it back in INC so that local-lib users can actually +# run this test. Use lib.pm instead of an @INC unshift as +# it will correctly add any arch subdirs encountered +# +# Yes, this is a lazy solution: adding -I args in the exec below is the +# more sensible approach, but no time to properly do it at present +use Config; +use lib ( + grep { length } + map { split /\Q$Config{path_sep}\E/, (/^(.*)$/)[0] } # untainting regex + grep { defined } + @ENV{qw(PERL5LIB PERLLIB)} # precedence preserved by lib +); + use strict; use warnings; -use Config; # there is talk of possible perl compilations where -T is fatal or just # doesn't work. We don't want to have the user deal with that. -BEGIN { unless ($INC{'t/lib/DBICTest/WithTaint.pm'}) { +BEGIN { unless ($INC{'DBICTest/WithTaint.pm'}) { if ( $^O eq 'MSWin32' and $^X =~ /\x20/ ) { print "1..0 # SKIP Running this test on Windows with spaces within the perl executable path (\$^X) is not possible due to https://rt.perl.org/Ticket/Display.html?id=123907\n"; @@ -40,21 +56,9 @@ BEGIN { unless ($INC{'t/lib/DBICTest/WithTaint.pm'}) { exit 0; } - exec( $perl, qw( -I. -Mt::lib::DBICTest::WithTaint -T ), __FILE__ ); + exec( $perl, qw( -It/lib -MDBICTest::WithTaint -T ), __FILE__ ); }} -# When in taint mode, PERL5LIB is ignored (but *not* unset) -# Put it back in INC so that local-lib users can actually -# run this test. Use lib.pm instead of an @INC unshift as -# it will correctly add any arch subdirs encountered - -use lib ( - grep { length } - map { split /\Q$Config{path_sep}\E/, (/^(.*)$/)[0] } # untainting regex - grep { defined } - @ENV{qw(PERL5LIB PERLLIB)} # precedence preserved by lib -); - # We need to specify 'lib' here as well because even if it was already in # @INC, the above will have put our local::lib in front of it, so now an # installed DBIx::Class will take precedence over the one we're trying to test.