From: Peter Rabbitson Date: Sat, 12 Apr 2014 07:50:18 +0000 (+0200) Subject: Merge branch 'current/for_cpan_index' into current/dq X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=refs%2Fheads%2Fcurrent%2Fdq;hp=a63c42fc0b2844ff59bc86719fbe2c779067f171;p=dbsrgits%2FDBIx-Class.git Merge branch 'current/for_cpan_index' into current/dq --- diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..db6df22 --- /dev/null +++ b/.gitattributes @@ -0,0 +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 +/* eol=lf +/script/* eol=lf +/maint/* eol=lf + +* text=auto diff --git a/.mailmap b/.mailmap index 0537484..587e076 100644 --- a/.mailmap +++ b/.mailmap @@ -2,6 +2,8 @@ # so if someone were to legally change their name, we could use it to fix that # while maintaining the integrity of the repository +# https://www.kernel.org/pub/software/scm/git/docs/git-shortlog.html#_mapping_authors + Alexander Hartmaier Amiri Barksdale Andrew Rodland @@ -10,9 +12,11 @@ Brendan Byrd Brendan Byrd Brendan Byrd Brian Phillips +Dagfinn Ilmari Mannsåker David Kamholz -David Schmidt -David Schmidt +David Schmidt +David Schmidt +David Schmidt Devin Austin Felix Antonius Wilhelm Ostmann Gerda Shank diff --git a/.travis.yml b/.travis.yml index 1bd9d4d..05b5157 100644 --- a/.travis.yml +++ b/.travis.yml @@ -58,6 +58,13 @@ notifications: on_success: change on_failure: always +# FIXME - This stuff is not yet available for free OSS accounts, sadpanda +# First paragrah on http://about.travis-ci.org/docs/user/caching/ +#cache: +# apt: true +# directories: +# - /var/cache/apt/archives + language: perl perl: @@ -68,6 +75,7 @@ env: - CLEANTEST=true matrix: + fast_finish: true include: # this particular perl is quite widespread - perl: 5.8.8_thr_mb @@ -116,14 +124,14 @@ matrix: ### # some permutations of tracing and envvar poisoning - - perl: 5.18.1_thr_mb + - perl: 5.16.2_thr_mb env: - CLEANTEST=false - POISON_ENV=true - DBIC_TRACE=1 - DBIC_MULTICREATE_DEBUG=0 - BREWOPTS="-Duseithreads -Dusemorebits" - - BREWVER=5.18.1 + - BREWVER=5.16.2 - perl: 5.18 env: @@ -131,7 +139,7 @@ matrix: - POISON_ENV=true - DBIC_TRACE_PROFILE=console - - perl: 5.18 + - perl: 5.8 env: - CLEANTEST=true - POISON_ENV=true @@ -148,19 +156,42 @@ matrix: ### # Start of the allow_failures block - # recentish stable with blead CPAN - - perl: devcpan_5.18.1_thr_mb + # old threaded with blead CPAN + - perl: devcpan_5.8.7_thr env: - - CLEANTEST=false + - CLEANTEST=true + - BREWOPTS="-Duseithreads" + - BREWVER=5.8.7 + - DEVREL_DEPS=true + + # 5.10.0 threaded with blead CPAN + - perl: devcpan_5.10.0_thr_mb + env: + - CLEANTEST=true - BREWOPTS="-Duseithreads -Dusemorebits" - - BREWVER=5.18.1 + - BREWVER=5.10.0 - DEVREL_DEPS=true - # bleadperl with stock CPAN - - perl: bleadperl_thr_mb + # 5.12.2 with blead CPAN + - perl: devcpan_5.12.2_thr + env: + - CLEANTEST=true + - BREWOPTS="-Duseithreads" + - BREWVER=5.12.2 + - DEVREL_DEPS=true + + # recentish threaded stable with blead CPAN + - perl: devcpan_5.18.2_thr_mb env: - CLEANTEST=false - BREWOPTS="-Duseithreads -Dusemorebits" + - BREWVER=5.18.2 + - DEVREL_DEPS=true + + # bleadperl with stock CPAN, full depchain test + - perl: bleadperl + env: + - CLEANTEST=true - BREWVER=blead # bleadperl with blead CPAN @@ -175,13 +206,12 @@ matrix: # which ones of the above can fail allow_failures: - # Fails tests because of https://github.com/Perl-Toolchain-Gang/CPAN-Meta/issues/25 - # Can't be simply masked due to https://rt.cpan.org/Ticket/Display.html?id=88903 - - perl: 5.10.0_thr_dbg - # these run with various dev snapshots - allowed to fail - - perl: devcpan_5.18.1_thr_mb - - perl: bleadperl_thr_mb + - perl: devcpan_5.8.7_thr + - perl: devcpan_5.10.0_thr_mb + - perl: devcpan_5.12.2_thr + - perl: devcpan_5.18.2_thr_mb + - perl: bleadperl - perl: devcpan_bleadperl_thr_mb diff --git a/Changes b/Changes index e9b5fe5..3d77271 100644 --- a/Changes +++ b/Changes @@ -1,19 +1,54 @@ Revision history for DBIx::Class -0.08901-TRIAL (EXPERIMENTAL BETA RELEASE) + * Start of experimental Data::Query-based release cycle - Any and all newly introduced syntax features may very well change or disappear altogether before the 0.09000 release - * New Features / Changes + + * Fixes + - Fix on_connect_* not always firing in some cases - a race condition + existed between storage accessor setters and the determine_driver + routines, triggering a connection before the set-cycle is finished + +0.08270 2014-01-30 21:54 (PST) + * Fixes + - Fix 0.08260 regression in DBD::SQLite bound int handling. Inserted + data was not affected, but any function <=> integer comparison would + have failed (originally fixed way back in 0e773352) + - Fix failure to load DateTime formatter when connecting to Firebird + over ODBC + + * Misc + - All drivers based on ::Storage::DBI::Firebird::Common now return the + same sqlt_type value (affects ::DBI::Interbase, ::DBI::Firebird and + ::DBI::ODBC::Firebird) + +0.08260 2014-01-28 18:52 (UTC) + * New Features - A new zero-to-DBIC style manual: DBIx::Class::Manual::QuickStart + * Notable Changes and Deprecations + - Explicitly deprecate combination of distinct and selecting a + non-column via $rs->get_column() + * Fixes - More robust handling of circular relationship declarations by loading foreign classes less frequently (should resolve issues like http://lists.scsys.co.uk/pipermail/dbix-class/2013-June/011374.html) - - Fix multiple edge cases steming from interaction of a non-selecting + Note that none of this is a manifestations of a DBIC bug, but rather + unexpected (but correct) behavior of load-order-dependent (hence + logically broken) Resultclass hierarchies. In order to deal with this + DBIC is scaling back a large number of sanity checks, which are to be + reintroduce pending a better framework for source registration + - Fix multiple edge cases of complex prefetch combining incorrectly + with correlated subquery selections + - Fix multiple edge cases stemming from interaction of a non-selecting order_by specification and distinct and/or complex prefetch + - Fix unbound growth of a resultset during repeated execute/exhaust + cycles (GH#29) + - Work around (and be very vocal about the fact) when DBIC encounters + an exception object with broken string overloading - Clarify ambiguous behavior of distinct when used with ResultSetColumn i.e. $rs->search({}, { distinct => 1 })->get_column (...) - Setting quote_names propagates to SQL::Translator when producing @@ -25,13 +60,27 @@ Revision history for DBIx::Class - Back out self-cleaning from DBIx::Class::Carp for the time being (as a side effect fixes RT#86267) - Fix incorrect internal use of implicit list context in copy() + - Fix 0.08250 regression in driver determination when DBI_DSN is used - Tests no longer fail if $ENV{DBI_DSN} is set - Throw clearer exception on ->new_related() with a non-existent - relationship. + relationship + - Fix incorrect parethesis unroll with multicolumn in, (never noticed + before fixing false positive in SQLA::Test 1.77) - Fix t/storage/replicated.t class loading problem - Stop using the deprecated Class::MOP::load_class() + - Fix warning in t/54taint.t with explicitly unset PERL5LIB (RT#91972) + - Fix t/54taint.t failing under a local::lib with installed earlier + DBIC version (RT#92486) * Misc + - Massive incompatible change of ::BlockRunner internals (was never + documented as usable externally, this last set of changes settles + the design for proper documentation and opening up) + - Adjust exceptions in tests to accommodate changes in the upcoming + DBD::SQLite based on libsqlite 3.8.2 + - More robust lock file naming scheme - allow tests to work on exotic + MSWin32 filesystems (habitual offender being http://is.gd/iy5XVP) + - Better diagnostics when File::Spec->tmpdir gives us crap in testing - Replace $row with $result in all docs to be consistent and to clarify various return values diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index 5f0567e..5e2f3f3 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -28,3 +28,6 @@ lib/DBIx/Class/Manual/ResultClass.pod.proto maint/.Generated_Pod + +maint/travis-ci_scripts +.travis.yml diff --git a/Makefile.PL b/Makefile.PL index 27bb2f2..9830868 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -3,6 +3,7 @@ use warnings; use 5.008001; use inc::Module::Install 1.06; +BEGIN { makemaker_args( NORECURS => 1 ) } # needs to happen early for old EUMM ## ## TEMPORARY (and non-portable) @@ -46,7 +47,6 @@ use lib $target_libdir; # for that) BEGIN { $Module::Install::AUTHOR = 0 if (grep { $ENV{"PERL5_${_}_IS_RUNNING"} } (qw/CPANM CPANPLUS CPAN/) ); - makemaker_args( NORECURS => 1 ); } homepage 'http://www.dbix-class.org/'; @@ -61,6 +61,10 @@ perl_version '5.008001'; all_from 'lib/DBIx/Class.pm'; Meta->{values}{x_authority} = 'cpan:RIBASUSHI'; +# nothing determined at runtime, except for possibly SQLT dep, see +# comment further down +dynamic_config 0; + tests_recursive (qw| t |); @@ -114,7 +118,7 @@ my $runtime_requires = { 'namespace::clean' => '0.24', 'Path::Class' => '0.18', 'Scope::Guard' => '0.03', - 'SQL::Abstract' => '1.73', + 'SQL::Abstract' => '1.77', 'Try::Tiny' => '0.07', # Technically this is not a core dependency - it is only required @@ -128,6 +132,15 @@ my $runtime_requires = { }; my $build_requires = { +}; + +my $test_requires = { + 'File::Temp' => '0.22', + 'Test::Deep' => '0.101', + 'Test::Exception' => '0.31', + 'Test::Warn' => '0.21', + 'Test::More' => '0.94', + # needed for testing only, not for operation # we will move away from this dep eventually, perhaps to DBD::CSV or something ### @@ -137,16 +150,6 @@ my $build_requires = { ### often *not* easy or even possible) ### 'DBD::SQLite' => '1.29', -}; - -my $test_requires = { - 'File::Temp' => '0.22', - 'Test::Deep' => '0.101', - 'Test::Exception' => '0.31', - 'Test::Warn' => '0.21', - 'Test::More' => '0.94', - # not sure if this is necessary at all, ask schwern some day - 'Test::Builder' => '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 @@ -154,10 +157,15 @@ my $test_requires = { }; # if the user has this env var set and no SQLT installed, tests will fail -# same rationale for direct test_requires as the strictures stuff above -# (even though no dist will be created from this) +# Note - this is added as test_requires *directly*, so it gets properly +# excluded on META.yml cleansing (even though no dist can be created from this) # we force this req regarless of author_deps, worst case scenario it will # be specified twice +# +# also note that we *do* set dynamic_config => 0, as this is the only thing +# that we determine dynamically, and in all fairness if someone sets the +# envvar *and* is not running a full Makefile/make/maketest cycle - they get +# to keep the pieces if ($ENV{DBICTEST_SQLT_DEPLOY}) { local @INC = ('lib', @INC); require DBIx::Class::Optional::Dependencies; @@ -177,6 +185,52 @@ my $reqs = { # only do author-includes if not part of a `make` run if ($Module::Install::AUTHOR and ! $ENV{MAKELEVEL}) { + invoke_author_mode() +} +else { + # make sure this Makefile can not be used to make a dist + # (without the author includes there are no meta cleanup, no sanity checks, etc) + postamble <{$rtype}} ) { + + # sanity check req duplications + die "$mod specified as both a '$rtype' and a '$final_req{$mod}[0]'\n" + if $final_req{$mod}; + + $final_req{$mod} = [ $rtype, $reqs->{$rtype}{$mod}||0 ], + } +} + +# actual require +for my $mod (sort keys %final_req) { + my ($rtype, $ver) = @{$final_req{$mod}}; + no strict 'refs'; + $rtype->($mod, $ver); +} + +# author-mode or not - this is where we show a list of missing deps +# IFF we are running interactively +auto_install(); + +WriteAll(); + +exit 0; + +# needs to be here to keep 5.8 string eval happy +# (the include of Makefile.PL.inc loop) +my $mm_proto; + +sub invoke_author_mode { # get options here, make $args available to all snippets require Getopt::Long; my $getopt = Getopt::Long::Parser->new( @@ -194,9 +248,14 @@ if ($Module::Install::AUTHOR and ! $ENV{MAKELEVEL}) { # We need the MM facilities to generate the pieces for the final MM run. # Just instantiate a throaway object here - my $mm_proto = ExtUtils::MakeMaker->new({ + # + # Also EUMM and MI disagree on what is the format of Meta->name, just + # punt here until a new M::I is shipped (if at all) + my $name = Meta->name || die 'The Module::Install metadata must be available at this point but is not - did you rearrange the Makefile.PL...?'; + $name =~ s/\-/::/g; + $mm_proto = ExtUtils::MakeMaker->new({ NORECURS => 1, - NAME => Meta->name || die 'The Module::Install metadata must be available at this point but is not - did you rearrange the Makefile.PL...?', + NAME => $name, }); # Crutch for DISTBUILDING_IN_HELL @@ -226,40 +285,3 @@ if ($Module::Install::AUTHOR and ! $ENV{MAKELEVEL}) { ; } } -else { - # make sure this Makefile can not be used to make a dist - # (without the author includes there are no meta cleanup, no sanity checks, etc) - postamble <{$rtype}} ) { - - # sanity check req duplications - if ($final_req{$mod}) { - die "$mod specified as both a '$rtype' and a '$final_req{$mod}[0]'\n"; - } - - $final_req{$mod} = [ $rtype, $reqs->{$rtype}{$mod}||0 ], - } -} - -# actual require -for my $mod (sort keys %final_req) { - my ($rtype, $ver) = @{$final_req{$mod}}; - no strict 'refs'; - $rtype->($mod, $ver); -} - -# author-mode or not - this is where we show a list of missing deps -# IFF we are running interactively -auto_install(); - -WriteAll(); diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index 7d9580c..32faec4 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -17,47 +17,7 @@ $VERSION = '0.08901'; $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases -BEGIN { - package # hide from pause - DBIx::Class::_ENV_; - - use Config; - - use constant { - - # but of course - BROKEN_FORK => ($^O eq 'MSWin32') ? 1 : 0, - - HAS_ITHREADS => $Config{useithreads} ? 1 : 0, - - # ::Runmode would only be loaded by DBICTest, which in turn implies t/ - DBICTEST => eval { DBICTest::RunMode->is_author } ? 1 : 0, - - # During 5.13 dev cycle HELEMs started to leak on copy - PEEPEENESS => - # request for all tests would force "non-leaky" illusion and vice-versa - defined $ENV{DBICTEST_ALL_LEAKS} ? !$ENV{DBICTEST_ALL_LEAKS} - # otherwise confess that this perl is busted ONLY on smokers - : eval { DBICTest::RunMode->is_smoker } && ($] >= 5.013005 and $] <= 5.013006) ? 1 - # otherwise we are good - : 0 - , - - ASSERT_NO_INTERNAL_WANTARRAY => $ENV{DBIC_ASSERT_NO_INTERNAL_WANTARRAY} ? 1 : 0, - - IV_SIZE => $Config{ivsize}, - }; - - if ($] < 5.009_005) { - require MRO::Compat; - constant->import( OLD_MRO => 1 ); - } - else { - require mro; - constant->import( OLD_MRO => 0 ); - } -} - +use DBIx::Class::_Util; use mro 'c3'; use DBIx::Class::Optional::Dependencies; @@ -582,6 +542,8 @@ yrlnry: Mark Jason Dominus zamolxes: Bogdan Lucaciu +Zefram: Andrew Main + =head1 COPYRIGHT Copyright (c) 2005 - 2011 the DBIx::Class L and L diff --git a/lib/DBIx/Class/Manual/Cookbook.pod b/lib/DBIx/Class/Manual/Cookbook.pod index 36b891e..0cb560b 100644 --- a/lib/DBIx/Class/Manual/Cookbook.pod +++ b/lib/DBIx/Class/Manual/Cookbook.pod @@ -1183,7 +1183,7 @@ of your application to support a change lifecycle (e.g. DEV, TEST, PROD) and the DB schemas are named based on the environment (e.g. database1_dev). However, one can dynamically "map" to the proper DB schema by overriding the -L method in your Schema class and +L method in your Schema class and building a renaming facility, like so: package MyApp::Schema; @@ -1223,13 +1223,13 @@ building a renaming facility, like so: 1; -By overriding the L +By overriding the L method and extracting a custom option from the provided \%attr hashref one can then simply iterate over all the Schema's ResultSources, renaming them as needed. To use this facility, simply add or modify the \%attr hashref that is passed to -L, as follows: +L, as follows: my $schema = MyApp::Schema->connect( diff --git a/lib/DBIx/Class/Manual/Troubleshooting.pod b/lib/DBIx/Class/Manual/Troubleshooting.pod index f76934e..b28a960 100644 --- a/lib/DBIx/Class/Manual/Troubleshooting.pod +++ b/lib/DBIx/Class/Manual/Troubleshooting.pod @@ -21,7 +21,7 @@ Alternatively use the C<< storage->debug >> class method:- To send the output somewhere else set debugfh:- - $schema->storage->debugfh(IO::File->new('/tmp/trace.out', 'w'); + $schema->storage->debugfh(IO::File->new('/tmp/trace.out', 'w')); Alternatively you can do this with the environment variable, too:- diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm index e312c72..23ffebe 100644 --- a/lib/DBIx/Class/Optional/Dependencies.pm +++ b/lib/DBIx/Class/Optional/Dependencies.pm @@ -11,9 +11,15 @@ use Carp (); # POD is generated automatically by calling _gen_pod from the # Makefile.PL in $AUTHOR mode -my $json_any = { +# NOTE: the rationale for 2 JSON::Any versions is that +# we need the newer only to work around JSON::XS, which +# itself is an optional dep +my $min_json_any = { 'JSON::Any' => '1.23', }; +my $test_and_dist_json_any = { + 'JSON::Any' => '1.31', +}; my $moose_basic = { 'Moose' => '0.98', @@ -27,7 +33,7 @@ my $replicated = { my $admin_basic = { %$moose_basic, - %$json_any, + %$min_json_any, 'MooseX::Types::Path::Class' => '0.05', 'MooseX::Types::JSON' => '0.02', 'namespace::autoclean' => '0.09', @@ -190,13 +196,13 @@ my $reqs = { }, test_prettydebug => { - req => $json_any, + req => $min_json_any, }, test_admin_script => { req => { %$admin_script, - 'JSON::Any' => '1.30', + %$test_and_dist_json_any, 'JSON' => 0, 'JSON::PP' => 0, 'Cpanel::JSON::XS' => 0, @@ -210,10 +216,10 @@ my $reqs = { } }, - test_leaks => { + test_leaks_heavy => { req => { - 'Test::Memory::Cycle' => '0', - 'Devel::Cycle' => '1.10', + 'Class::MethodCache' => '0.02', + 'PadWalker' => '1.06', }, }, @@ -615,6 +621,7 @@ my $reqs = { dist_dir => { req => { + %$test_and_dist_json_any, 'ExtUtils::MakeMaker' => '6.64', 'Pod::Inherit' => '0.90', 'Pod::Tree' => '0', diff --git a/lib/DBIx/Class/Relationship.pm b/lib/DBIx/Class/Relationship.pm index 26a07ef..427b5aa 100644 --- a/lib/DBIx/Class/Relationship.pm +++ b/lib/DBIx/Class/Relationship.pm @@ -191,15 +191,16 @@ more info see L. # To retrieve the plain id if you used the ugly version: $book->get_column('author_id'); - -If the relationship is optional -- i.e. the column containing the -foreign key can be NULL -- then the belongs_to relationship does the -right thing. Thus, in the example above C<< $obj->author >> would -return C. However in this case you would probably want to set -the L attribute so that -a C is done, which makes complex resultsets involving -C or C operations work correctly. The modified -declaration is shown below: +If some of the foreign key columns are +L you probably want to set +the L attribute to +C explicitly so that SQL expressing this relation is composed with +a C (as opposed to C which is default for +L relationships). This ensures that relationship traversal +works consistently in all situations. (i.e. resultsets involving +L or +L). +The modified declaration is shown below: # in a Book class (where Author has_many Books) __PACKAGE__->belongs_to( @@ -209,7 +210,6 @@ declaration is shown below: { join_type => 'left' } ); - Cascading deletes are off by default on a C relationship. To turn them on, pass C<< cascade_delete => 1 >> in the $attr hashref. diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm index 07f89c2..ef63b08 100644 --- a/lib/DBIx/Class/Relationship/ManyToMany.pm +++ b/lib/DBIx/Class/Relationship/ManyToMany.pm @@ -63,7 +63,6 @@ EOW *$rs_meth_name = subname $rs_meth_name, sub { my $self = shift; my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}; - my @args = ($f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs }); my $rs = $self->search_related($rel)->search_related( $f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs } ); diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 77d04b2..d6c5e9b 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -248,7 +248,7 @@ sub new { if $source->isa('DBIx::Class::ResultSourceHandle'); $attrs = { %{$attrs||{}} }; - delete @{$attrs}{qw(_sqlmaker_select_args _related_results_construction)}; + delete @{$attrs}{qw(_last_sqlmaker_alias_map _related_results_construction)}; if ($attrs->{page}) { $attrs->{rows} ||= 10; @@ -1412,7 +1412,7 @@ sub _construct_results { return undef unless @{$rows||[]}; # sanity check - people are too clever for their own good - if ($attrs->{collapse} and my $aliastypes = $attrs->{_sqlmaker_select_args}[3]{_aliastypes} ) { + if ($attrs->{collapse} and my $aliastypes = $attrs->{_last_sqlmaker_alias_map} ) { my $multiplied_selectors; for my $sel_alias ( grep { $_ ne $attrs->{alias} } keys %{ $aliastypes->{selecting} } ) { @@ -2751,8 +2751,6 @@ sub as_query { $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs ); - $self->{_attrs}{_sqlmaker_select_args} = $attrs->{_sqlmaker_select_args}; - $aq; } diff --git a/lib/DBIx/Class/ResultSetColumn.pm b/lib/DBIx/Class/ResultSetColumn.pm index 4f7b39e..b64eec2 100644 --- a/lib/DBIx/Class/ResultSetColumn.pm +++ b/lib/DBIx/Class/ResultSetColumn.pm @@ -110,14 +110,11 @@ sub new { } } - # collapse the selector to a literal so that it survives a possible 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 - my $new = bless { - _select => \ ($rsrc->storage->sql_maker->_render_sqla(select_select => $select) =~ /^\s*SELECT\s*(.+)/i)[0], + return bless { + _select => $select, _as => $column, - _parent_resultset => $new_parent_rs }, $class; - return $new; + _parent_resultset => $new_parent_rs + }, $class; } =head2 as_query @@ -478,12 +475,33 @@ sub throw_exception { sub _resultset { my $self = shift; - return $self->{_resultset} ||= $self->{_parent_resultset}->search(undef, - { - select => [$self->{_select}], - as => [$self->{_as}] + return $self->{_resultset} ||= do { + + my $select = $self->{_select}; + + if ($self->{_parent_resultset}{attrs}{distinct}) { + my $alias = $self->{_parent_resultset}->current_source_alias; + my $rsrc = $self->{_parent_resultset}->result_source; + my %cols = map { $_ => 1, "$alias.$_" => 1 } $rsrc->columns; + + unless( $cols{$select} ) { + carp_unique( + 'Use of distinct => 1 while selecting anything other than a column ' + . 'declared on the primary ResultSource is deprecated - please supply ' + . 'an explicit group_by instead' + ); + + # 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->_render_sqla(select_select => $select) =~ /^\s*SELECT\s*(.+)/i)[0], + } } - ); + + $self->{_parent_resultset}->search(undef, { + columns => { $self->{_as} => $select } + }); + }; } 1; diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index 498d9ac..17c8ca1 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -8,7 +8,6 @@ use base 'DBIx::Class'; use Try::Tiny; use List::Util qw(first max); -use B 'perlstring'; use Scalar::Util qw(blessed); use DBIx::Class::ResultSource::RowParser::Util qw( diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index b4b7f19..197a393 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -1244,17 +1244,15 @@ sub inflate_result { $class->throw_exception("No accessor type declared for prefetched relationship '$relname'") unless $relinfo->{attrs}{accessor}; + my $rel_rs = $new->related_resultset($relname); + my @rel_objects; if ( - $prefetch->{$relname} - and - @{$prefetch->{$relname}} + @{ $prefetch->{$relname} || [] } and ref($prefetch->{$relname}) ne $DBIx::Class::ResultSource::RowParser::Util::null_branch_class ) { - my $rel_rs = $new->related_resultset($relname); - if (ref $prefetch->{$relname}[0] eq 'ARRAY') { my $rel_rsrc = $rel_rs->result_source; my $rel_class = $rel_rs->result_class; @@ -1278,7 +1276,7 @@ sub inflate_result { $new->{_inflated_column}{$relname} = $rel_objects[0]; } - $new->related_resultset($relname)->set_cache(\@rel_objects); + $rel_rs->set_cache(\@rel_objects); } } diff --git a/lib/DBIx/Class/SQLMaker/LimitDialects.pm b/lib/DBIx/Class/SQLMaker/LimitDialects.pm index d3ea35c..53e6ea0 100644 --- a/lib/DBIx/Class/SQLMaker/LimitDialects.pm +++ b/lib/DBIx/Class/SQLMaker/LimitDialects.pm @@ -221,7 +221,7 @@ sub _FirstSkip { Depending on the resultset attributes one of: SELECT * FROM ( - SELECT *, ROWNUM rownum__index FROM ( + SELECT *, ROWNUM AS rownum__index FROM ( SELECT ... ) WHERE ROWNUM <= ($limit+$offset) ) WHERE rownum__index >= ($offset+1) @@ -229,7 +229,7 @@ Depending on the resultset attributes one of: or SELECT * FROM ( - SELECT *, ROWNUM rownum__index FROM ( + SELECT *, ROWNUM AS rownum__index FROM ( SELECT ... ) ) WHERE rownum__index BETWEEN ($offset+1) AND ($limit+$offset) @@ -286,7 +286,7 @@ EOS return <{selection_outer} FROM ( - SELECT $sq_attrs->{selection_outer}, ROWNUM $idx_name FROM ( + SELECT $sq_attrs->{selection_outer}, ROWNUM AS $idx_name FROM ( SELECT $sq_attrs->{selection_inner} $sq_attrs->{query_leftover}${order_group_having} ) $qalias WHERE ROWNUM <= ? ) $qalias WHERE $idx_name >= ? @@ -297,7 +297,7 @@ EOS return <{selection_outer} FROM ( - SELECT $sq_attrs->{selection_outer}, ROWNUM $idx_name FROM ( + SELECT $sq_attrs->{selection_outer}, ROWNUM AS $idx_name FROM ( SELECT $sq_attrs->{selection_inner} $sq_attrs->{query_leftover}${order_group_having} ) $qalias ) $qalias WHERE $idx_name BETWEEN ? AND ? diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 16a0878..4c3cce5 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -8,8 +8,8 @@ use base 'DBIx::Class'; use DBIx::Class::Carp; use Try::Tiny; use Scalar::Util qw/weaken blessed/; +use DBIx::Class::_Util 'refcount'; use Sub::Name 'subname'; -use B 'svref_2object'; use Devel::GlobalDestruction; use namespace::clean; @@ -155,8 +155,7 @@ entries in the list of namespaces will override earlier ones. # be stripped. sub _expand_relative_name { my ($class, $name) = @_; - return if !$name; - $name = $class . '::' . $name if ! ($name =~ s/^\+//); + $name =~ s/^\+// or $name = "${class}::${name}"; return $name; } @@ -164,31 +163,26 @@ sub _expand_relative_name { # namespace of $class. Untaints all findings as they can be assumed # to be safe sub _findallmod { - my $proto = shift; - my $ns = shift || ref $proto || $proto; - require Module::Find; - - # untaint result - return map { $_ =~ /(.+)/ } Module::Find::findallmod($ns); + return map + { $_ =~ /(.+)/ } # untaint result + Module::Find::findallmod( $_[1] || ref $_[0] || $_[0] ) + ; } # returns a hash of $shortname => $fullname for every package # found in the given namespaces ($shortname is with the $fullname's # namespace stripped off) sub _map_namespaces { - my ($class, @namespaces) = @_; - - my @results_hash; - foreach my $namespace (@namespaces) { - push( - @results_hash, - map { (substr($_, length "${namespace}::"), $_) } - $class->_findallmod($namespace) - ); + my ($me, $namespaces) = @_; + + my %res; + for my $ns (@$namespaces) { + $res{ substr($_, length "${ns}::") } = $_ + for $me->_findallmod($ns); } - @results_hash; + \%res; } # returns the result_source_instance for the passed class/object, @@ -211,17 +205,18 @@ sub load_namespaces { my $result_namespace = delete $args{result_namespace} || 'Result'; my $resultset_namespace = delete $args{resultset_namespace} || 'ResultSet'; + my $default_resultset_class = delete $args{default_resultset_class}; + $default_resultset_class = $class->_expand_relative_name($default_resultset_class) + if $default_resultset_class; + $class->throw_exception('load_namespaces: unknown option(s): ' . join(q{,}, map { qq{'$_'} } keys %args)) if scalar keys %args; - $default_resultset_class - = $class->_expand_relative_name($default_resultset_class); - for my $arg ($result_namespace, $resultset_namespace) { - $arg = [ $arg ] if !ref($arg) && $arg; + $arg = [ $arg ] if ( $arg and ! ref $arg ); $class->throw_exception('load_namespaces: namespace arguments must be ' . 'a simple string or an arrayref') @@ -230,8 +225,8 @@ sub load_namespaces { $_ = $class->_expand_relative_name($_) for (@$arg); } - my %results = $class->_map_namespaces(@$result_namespace); - my %resultsets = $class->_map_namespaces(@$resultset_namespace); + my $results_by_source_name = $class->_map_namespaces($result_namespace); + my $resultsets_by_source_name = $class->_map_namespaces($resultset_namespace); my @to_register; { @@ -240,54 +235,56 @@ sub load_namespaces { use warnings qw/redefine/; # ensure classes are loaded and attached in inheritance order - for my $res (values %results) { - $class->ensure_class_loaded($res); + for my $result_class (values %$results_by_source_name) { + $class->ensure_class_loaded($result_class); } my %inh_idx; - my @subclass_last = sort { + my @source_names_by_subclass_last = sort { ($inh_idx{$a} ||= - scalar @{mro::get_linear_isa( $results{$a} )} + scalar @{mro::get_linear_isa( $results_by_source_name->{$a} )} ) <=> ($inh_idx{$b} ||= - scalar @{mro::get_linear_isa( $results{$b} )} + scalar @{mro::get_linear_isa( $results_by_source_name->{$b} )} ) - } keys(%results); + } keys(%$results_by_source_name); - foreach my $result (@subclass_last) { - my $result_class = $results{$result}; + foreach my $source_name (@source_names_by_subclass_last) { + my $result_class = $results_by_source_name->{$source_name}; - my $rs_class = delete $resultsets{$result}; - my $rs_set = $class->_ns_get_rsrc_instance ($result_class)->resultset_class; + my $preset_resultset_class = $class->_ns_get_rsrc_instance ($result_class)->resultset_class; + my $found_resultset_class = delete $resultsets_by_source_name->{$source_name}; - if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') { - if($rs_class && $rs_class ne $rs_set) { - carp "We found ResultSet class '$rs_class' for '$result', but it seems " - . "that you had already set '$result' to use '$rs_set' instead"; + if($preset_resultset_class && $preset_resultset_class ne 'DBIx::Class::ResultSet') { + if($found_resultset_class && $found_resultset_class ne $preset_resultset_class) { + carp "We found ResultSet class '$found_resultset_class' matching '$results_by_source_name->{$source_name}', but it seems " + . "that you had already set the '$results_by_source_name->{$source_name}' resultet to '$preset_resultset_class' instead"; } } - elsif($rs_class ||= $default_resultset_class) { - $class->ensure_class_loaded($rs_class); - if(!$rs_class->isa("DBIx::Class::ResultSet")) { - carp "load_namespaces found ResultSet class $rs_class that does not subclass DBIx::Class::ResultSet"; + # elsif - there may be *no* default_resultset_class, in which case we fallback to + # DBIx::Class::Resultset and there is nothing to check + elsif($found_resultset_class ||= $default_resultset_class) { + $class->ensure_class_loaded($found_resultset_class); + if(!$found_resultset_class->isa("DBIx::Class::ResultSet")) { + carp "load_namespaces found ResultSet class '$found_resultset_class' that does not subclass DBIx::Class::ResultSet"; } - $class->_ns_get_rsrc_instance ($result_class)->resultset_class($rs_class); + $class->_ns_get_rsrc_instance ($result_class)->resultset_class($found_resultset_class); } - my $source_name = $class->_ns_get_rsrc_instance ($result_class)->source_name || $result; + my $source_name = $class->_ns_get_rsrc_instance ($result_class)->source_name || $source_name; push(@to_register, [ $source_name, $result_class ]); } } - foreach (sort keys %resultsets) { - carp "load_namespaces found ResultSet class $_ with no " - . 'corresponding Result class'; + foreach (sort keys %$resultsets_by_source_name) { + carp "load_namespaces found ResultSet class '$resultsets_by_source_name->{$_}' " + .'with no corresponding Result class'; } Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; @@ -367,7 +364,7 @@ sub load_classes { } } else { my @comp = map { substr $_, length "${class}::" } - $class->_findallmod; + $class->_findallmod($class); $comps_for{$class} = \@comp; } @@ -564,7 +561,7 @@ Lists names of all the sources registered on this Schema object. =cut -sub sources { return keys %{shift->source_registrations}; } +sub sources { keys %{shift->source_registrations} } =head2 source @@ -799,11 +796,13 @@ sub connection { my ($self, @info) = @_; return $self if !@info && $self->storage; - my ($storage_class, $args) = ref $self->storage_type ? - ($self->_normalize_storage_type($self->storage_type),{}) : ($self->storage_type, {}); + my ($storage_class, $args) = ref $self->storage_type + ? $self->_normalize_storage_type($self->storage_type) + : $self->storage_type + ; + + $storage_class =~ s/^::/DBIx::Class::Storage::/; - $storage_class = 'DBIx::Class::Storage'.$storage_class - if $storage_class =~ m/^::/; try { $self->ensure_class_loaded ($storage_class); } @@ -812,7 +811,8 @@ sub connection { "Unable to load storage class ${storage_class}: $_" ); }; - my $storage = $storage_class->new($self=>$args); + + my $storage = $storage_class->new( $self => $args||{} ); $storage->connect_info(\@info); $self->storage($storage); return $self; @@ -1405,7 +1405,7 @@ sub DESTROY { # which will serve as a signal to not try doing anything else # however beware - on older perls the exception seems randomly untrappable # due to some weird race condition during thread joining :((( - if (ref $srcs->{$source_name} and svref_2object($srcs->{$source_name})->REFCNT > 1) { + if (length ref $srcs->{$source_name} and refcount($srcs->{$source_name}) > 1) { local $@; eval { $srcs->{$source_name}->schema($self); diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm index 470911b..1addeaf 100644 --- a/lib/DBIx/Class/Storage.pm +++ b/lib/DBIx/Class/Storage.pm @@ -175,18 +175,16 @@ transaction failure. sub txn_do { my $self = shift; - my $coderef = shift; DBIx::Class::Storage::BlockRunner->new( storage => $self, - run_code => $coderef, - run_args => @_ - ? \@_ # take a ref instead of a copy, to preserve @_ aliasing - : [] # semantics within the coderef, but only if needed - , # (pseudoforking doesn't like this trick much) wrap_txn => 1, - retry_handler => sub { ! ( $_[0]->retried_count or $_[0]->storage->connected ) }, - )->run; + retry_handler => sub { + $_[0]->failed_attempt_count == 1 + and + ! $_[0]->storage->connected + }, + )->run(@_); } =head2 txn_begin @@ -437,7 +435,7 @@ shell environment. =head2 debugfh Set or retrieve the filehandle used for trace/debug output. This should be -an IO::Handle compatible object (only the C method is used. Initially +an IO::Handle compatible object (only the C method is used). Initially set to be STDERR - although see information on the L environment variable. diff --git a/lib/DBIx/Class/Storage/BlockRunner.pm b/lib/DBIx/Class/Storage/BlockRunner.pm index 5760b7d..8dae0c9 100644 --- a/lib/DBIx/Class/Storage/BlockRunner.pm +++ b/lib/DBIx/Class/Storage/BlockRunner.pm @@ -1,13 +1,22 @@ package # hide from pause until we figure it all out DBIx::Class::Storage::BlockRunner; -use Sub::Quote 'quote_sub'; +use strict; + use DBIx::Class::Exception; use DBIx::Class::Carp; use Context::Preserve 'preserve_context'; -use Scalar::Util qw/weaken blessed/; +use DBIx::Class::_Util 'is_exception'; +use Scalar::Util qw(weaken blessed reftype); use Try::Tiny; -use Moo; + +# DO NOT edit away without talking to riba first, he will just put it back +BEGIN { + local $ENV{PERL_STRICTURES_EXTRA} = 0; + require Moo; Moo->import; + require Sub::Quote; Sub::Quote->import('quote_sub'); +} +use warnings NONFATAL => 'all'; use namespace::clean; =head1 NAME @@ -34,52 +43,35 @@ has wrap_txn => ( has retry_handler => ( is => 'ro', required => 1, - isa => quote_sub( q| - (ref $_[0]) eq 'CODE' + isa => quote_sub( q{ + (Scalar::Util::reftype($_[0])||'') eq 'CODE' or DBIx::Class::Exception->throw('retry_handler must be a CODE reference') - |), -); - -has run_code => ( - is => 'ro', - required => 1, - isa => quote_sub( q| - (ref $_[0]) eq 'CODE' - or DBIx::Class::Exception->throw('run_code must be a CODE reference') - |), -); - -has run_args => ( - is => 'ro', - isa => quote_sub( q| - (ref $_[0]) eq 'ARRAY' - or DBIx::Class::Exception->throw('run_args must be an ARRAY reference') - |), - default => quote_sub( '[]' ), + }), ); has retry_debug => ( is => 'rw', + # use a sub - to be evaluated on the spot lazily default => quote_sub( '$ENV{DBIC_STORAGE_RETRY_DEBUG}' ), + lazy => 1, ); -has max_retried_count => ( +has max_attempts => ( is => 'ro', - default => quote_sub( '20' ), + default => 20, ); -has retried_count => ( +has failed_attempt_count => ( is => 'ro', - init_arg => undef, - writer => '_set_retried_count', - clearer => '_reset_retried_count', - default => quote_sub(q{ 0 }), + init_arg => undef, # ensures one can't pass the value in + writer => '_set_failed_attempt_count', + default => 0, lazy => 1, trigger => quote_sub(q{ $_[0]->throw_exception( sprintf ( - 'Exceeded max_retried_count amount of %d, latest exception: %s', - $_[0]->max_retried_count, $_[0]->last_exception - )) if $_[0]->max_retried_count < ($_[1]||0); + 'Reached max_attempts amount of %d, latest exception: %s', + $_[0]->max_attempts, $_[0]->last_exception + )) if $_[0]->max_attempts <= ($_[1]||0); }), ); @@ -98,28 +90,35 @@ sub throw_exception { shift->storage->throw_exception (@_) } sub run { my $self = shift; - $self->throw_exception('run() takes no arguments') if @_; - $self->_reset_exception_stack; - $self->_reset_retried_count; + $self->_set_failed_attempt_count(0); + + my $cref = shift; + + $self->throw_exception('run() requires a coderef to execute as its first argument') + if ( reftype($cref)||'' ) ne 'CODE'; + my $storage = $self->storage; - return $self->run_code->( @{$self->run_args} ) - if (! $self->wrap_txn and $storage->{_in_do_block}); + return $cref->( @_ ) if ( + $storage->{_in_do_block} + and + ! $self->wrap_txn + ); local $storage->{_in_do_block} = 1 unless $storage->{_in_do_block}; - return $self->_run; + return $self->_run($cref, @_); } # this is the actual recursing worker sub _run { - # warnings here mean I did not anticipate some ueber-complex case - # fatal warnings are not warranted - no warnings; - use warnings; + # internal method - we know that both refs are strong-held by the + # calling scope of run(), hence safe to weaken everything + weaken( my $self = shift ); + weaken( my $cref = shift ); - my $self = shift; + my $args = @_ ? \@_ : []; # from this point on (defined $txn_init_depth) is an indicator for wrap_txn # save a bit on method calls @@ -128,15 +127,13 @@ sub _run { my $run_err = ''; - weaken (my $weakself = $self); - return preserve_context { try { if (defined $txn_init_depth) { - $weakself->storage->txn_begin; + $self->storage->txn_begin; $txn_begin_ok = 1; } - $weakself->run_code->( @{$weakself->run_args} ); + $cref->( @$args ); } catch { $run_err = $_; (); # important, affects @_ below @@ -144,7 +141,7 @@ sub _run { } replace => sub { my @res = @_; - my $storage = $weakself->storage; + my $storage = $self->storage; my $cur_depth = $storage->transaction_depth; if (defined $txn_init_depth and $run_err eq '') { @@ -156,7 +153,7 @@ sub _run { 'Unexpected reduction of transaction depth by %d after execution of ' . '%s, skipping txn_commit()', $delta_txn, - $weakself->run_code, + $cref, ) unless $delta_txn == 1 and $cur_depth == 0; } else { @@ -165,7 +162,7 @@ sub _run { } # something above threw an error (could be the begin, the code or the commit) - if ($run_err ne '') { + if ( is_exception $run_err ) { # attempt a rollback if we did begin in the first place if ($txn_begin_ok) { @@ -184,7 +181,10 @@ sub _run { } } - push @{ $weakself->exception_stack }, $run_err; + push @{ $self->exception_stack }, $run_err; + + # this will throw if max_attempts is reached + $self->_set_failed_attempt_count($self->failed_attempt_count + 1); # init depth of > 0 ( > 1 with AC) implies nesting - no retry attempt queries $storage->throw_exception($run_err) if ( @@ -194,17 +194,15 @@ 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 ! $weakself->retry_handler->($weakself) + ) or ! $self->retry_handler->($self) ); - $weakself->_set_retried_count($weakself->retried_count + 1); - # we got that far - let's retry - carp( sprintf 'Retrying %s (run %d) after caught exception: %s', - $weakself->run_code, - $weakself->retried_count + 1, + carp( sprintf 'Retrying %s (attempt %d) after caught exception: %s', + $cref, + $self->failed_attempt_count + 1, $run_err, - ) if $weakself->retry_debug; + ) if $self->retry_debug; $storage->ensure_connected; # if txn_depth is > 1 this means something was done to the @@ -214,7 +212,7 @@ sub _run { $storage->transaction_depth, ) if (defined $txn_init_depth and $storage->transaction_depth); - return $weakself->_run; + return $self->_run($cref, @$args); } return wantarray ? @res : $res[0]; diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index fe833b8..2f9d9a5 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -32,7 +32,7 @@ __PACKAGE__->datetime_parser_type('DateTime::Format::MySQL'); # historic default __PACKAGE__->sql_name_sep('.'); __PACKAGE__->mk_group_accessors('simple' => qw/ - _connect_info _dbi_connect_info _dbic_connect_attributes _driver_determined + _connect_info _dbic_connect_attributes _driver_determined _dbh _dbh_details _conn_pid _sql_maker _sql_maker_opts _dbh_autocommit _perform_autoinc_retrieval _autoinc_supplied_for_op /); @@ -79,20 +79,24 @@ __PACKAGE__->_use_join_optimizer (1); sub _determine_supports_join_optimizer { 1 }; # Each of these methods need _determine_driver called before itself -# in order to function reliably. This is a purely DRY optimization +# in order to function reliably. We also need to separate accessors +# from plain old method calls, since an accessor called as a setter +# does *not* need the driver determination loop fired (and in fact +# can produce hard to find bugs, like e.g. losing on_connect_* +# semantics on fresh connections) # -# get_(use)_dbms_capability need to be called on the correct Storage -# class, as _use_X may be hardcoded class-wide, and _supports_X calls -# _determine_supports_X which obv. needs a correct driver as well -my @rdbms_specific_methods = qw/ +# The construct below is simply a parameterized around() +my $storage_accessor_idx = { map { $_ => 1 } qw( sqlt_type - deployment_statements + datetime_parser_type sql_maker cursor_class +)}; +for my $meth (keys %$storage_accessor_idx, qw( + deployment_statements build_datetime_parser - datetime_parser_type txn_begin @@ -110,15 +114,13 @@ my @rdbms_specific_methods = qw/ _server_info _get_server_version -/; - -for my $meth (@rdbms_specific_methods) { +)) { my $orig = __PACKAGE__->can ($meth) or die "$meth is not a ::Storage::DBI method!"; - no strict qw/refs/; - no warnings qw/redefine/; + no strict 'refs'; + no warnings 'redefine'; *{__PACKAGE__ ."::$meth"} = subname $meth => sub { if ( # only fire when invoked on an instance, a valid class-based invocation @@ -129,7 +131,14 @@ for my $meth (@rdbms_specific_methods) { and ! $_[0]->{_in_determine_driver} and - ($_[0]->_dbi_connect_info||[])->[0] + # if this is a known *setter* - just set it, no need to connect + # and determine the driver + ! ( $storage_accessor_idx->{$meth} and @_ > 1 ) + and + # Only try to determine stuff if we have *something* that either is or can + # provide a DSN. Allows for bare $schema's generated with a plain ->connect() + # to still be marginally useful + $_[0]->_dbi_connect_info->[0] ) { $_[0]->_determine_driver; @@ -210,6 +219,12 @@ sub new { my %seek_and_destroy; sub _arm_global_destructor { + + # quick "garbage collection" pass - prevents the registry + # from slowly growing with a bunch of undef-valued keys + defined $seek_and_destroy{$_} or delete $seek_and_destroy{$_} + for keys %seek_and_destroy; + weaken ( $seek_and_destroy{ refaddr($_[0]) } = $_[0] ); @@ -616,23 +631,6 @@ sub connect_info { $info = $self->_normalize_connect_info($info) if ref $info eq 'ARRAY'; - for my $storage_opt (keys %{ $info->{storage_options} }) { - my $value = $info->{storage_options}{$storage_opt}; - - $self->$storage_opt($value); - } - - # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only - # the new set of options - $self->_sql_maker(undef); - $self->_sql_maker_opts({}); - - for my $sql_maker_opt (keys %{ $info->{sql_maker_options} }) { - my $value = $info->{sql_maker_options}{$sql_maker_opt}; - - $self->_sql_maker_opts->{$sql_maker_opt} = $value; - } - my %attrs = ( %{ $self->_default_dbi_connect_attributes || {} }, %{ $info->{attributes} || {} }, @@ -651,16 +649,58 @@ sub connect_info { push @args, \%attrs if keys %attrs; } + + # this is the authoritative "always an arrayref" thing fed to DBI->connect + # OR a single-element coderef-based $dbh factory $self->_dbi_connect_info(\@args); + # extract the individual storage options + for my $storage_opt (keys %{ $info->{storage_options} }) { + my $value = $info->{storage_options}{$storage_opt}; + + $self->$storage_opt($value); + } + + # Extract the individual sqlmaker options + # + # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only + # the new set of options + $self->_sql_maker(undef); + $self->_sql_maker_opts({}); + + for my $sql_maker_opt (keys %{ $info->{sql_maker_options} }) { + my $value = $info->{sql_maker_options}{$sql_maker_opt}; + + $self->_sql_maker_opts->{$sql_maker_opt} = $value; + } + # FIXME - dirty: - # save attributes them in a separate accessor so they are always + # save attributes in a separate accessor so they are always # introspectable, even in case of a CODE $dbhmaker $self->_dbic_connect_attributes (\%attrs); return $self->_connect_info; } +sub _dbi_connect_info { + my $self = shift; + + return $self->{_dbi_connect_info} = $_[0] + if @_; + + my $conninfo = $self->{_dbi_connect_info} || []; + + # last ditch effort to grab a DSN + if ( ! defined $conninfo->[0] and $ENV{DBI_DSN} ) { + my @new_conninfo = @$conninfo; + $new_conninfo[0] = $ENV{DBI_DSN}; + $conninfo = \@new_conninfo; + } + + return $conninfo; +} + + sub _normalize_connect_info { my ($self, $info_arg) = @_; my %info; @@ -796,7 +836,7 @@ Example: sub dbh_do { my $self = shift; - my $run_target = shift; + my $run_target = shift; # either a coderef or a method name # short circuit when we know there is no need for a runner # @@ -813,10 +853,15 @@ sub dbh_do { DBIx::Class::Storage::BlockRunner->new( storage => $self, - run_code => sub { $self->$run_target ($self->_get_dbh, @$args ) }, wrap_txn => 0, - retry_handler => sub { ! ( $_[0]->retried_count or $_[0]->storage->connected ) }, - )->run; + retry_handler => sub { + $_[0]->failed_attempt_count == 1 + and + ! $_[0]->storage->connected + }, + )->run(sub { + $self->$run_target ($self->_get_dbh, @$args ) + }); } sub txn_do { @@ -954,8 +999,13 @@ sub _get_dbh { return $self->_dbh; } +# *DELIBERATELY* not a setter (for the time being) +# Too intertwined with everything else for any kind of sanity sub sql_maker { - my ($self) = @_; + my $self = shift; + + $self->throw_exception('sql_maker() is not a setter method') if @_; + unless ($self->_sql_maker) { my $sql_maker_class = $self->sql_maker_class; @@ -1017,11 +1067,11 @@ sub _init {} sub _populate_dbh { my ($self) = @_; - my @info = @{$self->_dbi_connect_info || []}; $self->_dbh(undef); # in case ->connected failed we might get sent here $self->_dbh_details({}); # reset everything we know + $self->_sql_maker(undef); # this may also end up being different - $self->_dbh($self->_connect(@info)); + $self->_dbh($self->_connect); $self->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads @@ -1152,15 +1202,28 @@ sub _describe_connection { require DBI::Const::GetInfoReturn; my $self = shift; - $self->ensure_connected; + + my $drv; + try { + $drv = $self->_extract_driver_from_connect_info; + $self->ensure_connected; + }; + + $drv = "DBD::$drv" if $drv; my $res = { DBIC_DSN => $self->_dbi_connect_info->[0], DBI_VER => DBI->VERSION, DBIC_VER => DBIx::Class->VERSION, DBIC_DRIVER => ref $self, + $drv ? ( + DBD => $drv, + DBD_VER => try { $drv->VERSION }, + ) : (), }; + # try to grab data even if we never managed to connect + # will cover us in cases of an oddly broken half-connect for my $inf ( #keys %DBI::Const::GetInfoType::GetInfoType, qw/ @@ -1221,20 +1284,7 @@ sub _determine_driver { $started_connected = 1; } else { - # if connect_info is a CODEREF, we have no choice but to connect - if (ref $self->_dbi_connect_info->[0] && - reftype $self->_dbi_connect_info->[0] eq 'CODE') { - $self->_populate_dbh; - $driver = $self->_dbh->{Driver}{Name}; - } - else { - # try to use dsn to not require being connected, the driver may still - # force a connection in _rebless to determine version - # (dsn may not be supplied at all if all we do is make a mock-schema) - my $dsn = $self->_dbi_connect_info->[0] || $ENV{DBI_DSN} || ''; - ($driver) = $dsn =~ /dbi:([^:]+):/i; - $driver ||= $ENV{DBI_DRIVER}; - } + $driver = $self->_extract_driver_from_connect_info; } if ($driver) { @@ -1279,6 +1329,31 @@ sub _determine_driver { } } +sub _extract_driver_from_connect_info { + my $self = shift; + + my $drv; + + # if connect_info is a CODEREF, we have no choice but to connect + if ( + ref $self->_dbi_connect_info->[0] + and + reftype $self->_dbi_connect_info->[0] eq 'CODE' + ) { + $self->_populate_dbh; + $drv = $self->_dbh->{Driver}{Name}; + } + else { + # 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; + $drv ||= $ENV{DBI_DRIVER}; + } + + return $drv; +} + sub _determine_connector_driver { my ($self, $conn) = @_; @@ -1385,10 +1460,12 @@ sub _do_query { } sub _connect { - my ($self, @info) = @_; + my $self = shift; + + my $info = $self->_dbi_connect_info; $self->throw_exception("You did not provide any connection_info") - if ( ! defined $info[0] and ! $ENV{DBI_DSN} and ! $ENV{DBI_DRIVER} ); + unless defined $info->[0]; my ($old_connect_via, $dbh); @@ -1418,12 +1495,12 @@ sub _connect { }; try { - if(ref $info[0] eq 'CODE') { - $dbh = $info[0]->(); + if(ref $info->[0] eq 'CODE') { + $dbh = $info->[0]->(); } else { require DBI; - $dbh = DBI->connect(@info); + $dbh = DBI->connect(@$info); } die $DBI::errstr unless $dbh; @@ -1431,8 +1508,8 @@ sub _connect { die sprintf ("%s fresh DBI handle with a *false* 'Active' attribute. " . 'This handle is disconnected as far as DBIC is concerned, and we can ' . 'not continue', - ref $info[0] eq 'CODE' - ? "Connection coderef $info[0] returned a" + ref $info->[0] eq 'CODE' + ? "Connection coderef $info->[0] returned a" : 'DBI->connect($schema->storage->connect_info) resulted in a' ) unless $dbh->FETCH('Active'); @@ -1447,7 +1524,7 @@ sub _connect { # Default via _default_dbi_connect_attributes is 1, hence it was an explicit # request, or an external handle. Complain and set anyway unless ($dbh->{RaiseError}) { - carp( ref $info[0] eq 'CODE' + carp( ref $info->[0] eq 'CODE' ? "The 'RaiseError' of the externally supplied DBI handle is set to false. " ."DBIx::Class will toggle it back to true, unless the 'unsafe' connect " @@ -1468,7 +1545,7 @@ sub _connect { }; $self->_dbh_autocommit($dbh->{AutoCommit}); - $dbh; + return $dbh; } sub txn_begin { @@ -2350,8 +2427,8 @@ sub _select_args { # soooooo much better now. But that is also another # battle... #return ( - # 'select', @{$orig_attrs->{_sqlmaker_select_args}} - #) if $orig_attrs->{_sqlmaker_select_args}; + # 'select', $orig_attrs->{!args_as_stored_at_the_end_of_this_method!} + #) if $orig_attrs->{!args_as_stored_at_the_end_of_this_method!}; my $sql_maker = $self->sql_maker; my $alias2source = $self->_resolve_ident_sources ($ident); @@ -2447,6 +2524,16 @@ sub _select_args { ($attrs->{from}, $attrs->{_aliastypes}) = $self->_prune_unused_joins ($attrs); } + # FIXME this is a gross, inefficient, largely incorrect and fragile hack + # during the result inflation stage we *need* to know what was the aliastype + # map as sqla saw it when the final pieces of SQL were being assembled + # Originally we simply carried around the entirety of $attrs, but this + # resulted in resultsets that are being reused growing continuously, as + # the hash in question grew deeper and deeper. + # Instead hand-pick what to take with us here (we actually don't need much + # at this point just the map itself) + $orig_attrs->{_last_sqlmaker_alias_map} = $attrs->{_aliastypes}; + ### # This would be the point to deflate anything found in $attrs->{where} # (and leave $attrs->{bind} intact). Problem is - inflators historically @@ -2457,9 +2544,7 @@ sub _select_args { # invoked, and that's just bad... ### - return ( 'select', @{ $orig_attrs->{_sqlmaker_select_args} = [ - @{$attrs}{qw(from select where)}, $attrs, @limit_args - ]} ); + return ( 'select', @{$attrs}{qw(from select where)}, $attrs, @limit_args ); } # Returns a counting SELECT for a simple count diff --git a/lib/DBIx/Class/Storage/DBI/Cursor.pm b/lib/DBIx/Class/Storage/DBI/Cursor.pm index a8f087d..6681d23 100644 --- a/lib/DBIx/Class/Storage/DBI/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/Cursor.pm @@ -59,8 +59,15 @@ Returns a new L object. attrs => $attrs, }, ref $class || $class; - weaken( $cursor_registry{ refaddr($self) } = $self ) - if DBIx::Class::_ENV_::HAS_ITHREADS; + if (DBIx::Class::_ENV_::HAS_ITHREADS) { + + # quick "garbage collection" pass - prevents the registry + # from slowly growing with a bunch of undef-valued keys + defined $cursor_registry{$_} or delete $cursor_registry{$_} + for keys %cursor_registry; + + weaken( $cursor_registry{ refaddr($self) } = $self ) + } return $self; } diff --git a/lib/DBIx/Class/Storage/DBI/Firebird.pm b/lib/DBIx/Class/Storage/DBI/Firebird.pm index f0178bd..e615eb0 100644 --- a/lib/DBIx/Class/Storage/DBI/Firebird.pm +++ b/lib/DBIx/Class/Storage/DBI/Firebird.pm @@ -8,9 +8,10 @@ use warnings; # in ::Storage::DBI::InterBase as opposed to inheriting # directly from ::Storage::DBI::Firebird::Common use base qw/DBIx::Class::Storage::DBI::InterBase/; - use mro 'c3'; +1; + =head1 NAME DBIx::Class::Storage::DBI::Firebird - Driver for the Firebird RDBMS via @@ -21,10 +22,6 @@ L This is an empty subclass of L for use with L, see that driver for details. -=cut - -1; - =head1 AUTHOR See L and L. @@ -33,5 +30,3 @@ See L and L. You may distribute this code under the same terms as Perl itself. -=cut -# vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm b/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm index 4676fc4..7e6b518 100644 --- a/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm +++ b/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm @@ -24,6 +24,14 @@ __PACKAGE__->_use_insert_returning (1); __PACKAGE__->sql_limit_dialect ('FirstSkip'); __PACKAGE__->sql_quote_char ('"'); +__PACKAGE__->datetime_parser_type( + 'DBIx::Class::Storage::DBI::InterBase::DateTime::Format' +); + +sub sqlt_type { + return 'Firebird'; +} + sub _sequence_fetch { my ($self, $nextval, $sequence) = @_; @@ -108,6 +116,54 @@ SELECT rdb$get_context('SYSTEM', 'ENGINE_VERSION') FROM rdb$database }); } +package # hide from PAUSE + DBIx::Class::Storage::DBI::InterBase::DateTime::Format; + +my $timestamp_format = '%Y-%m-%d %H:%M:%S.%4N'; # %F %T +my $date_format = '%Y-%m-%d'; + +my ($timestamp_parser, $date_parser); + +sub parse_datetime { + shift; + require DateTime::Format::Strptime; + $timestamp_parser ||= DateTime::Format::Strptime->new( + pattern => $timestamp_format, + on_error => 'croak', + ); + return $timestamp_parser->parse_datetime(shift); +} + +sub format_datetime { + shift; + require DateTime::Format::Strptime; + $timestamp_parser ||= DateTime::Format::Strptime->new( + pattern => $timestamp_format, + on_error => 'croak', + ); + return $timestamp_parser->format_datetime(shift); +} + +sub parse_date { + shift; + require DateTime::Format::Strptime; + $date_parser ||= DateTime::Format::Strptime->new( + pattern => $date_format, + on_error => 'croak', + ); + return $date_parser->parse_datetime(shift); +} + +sub format_date { + shift; + require DateTime::Format::Strptime; + $date_parser ||= DateTime::Format::Strptime->new( + pattern => $date_format, + on_error => 'croak', + ); + return $date_parser->format_datetime(shift); +} + 1; =head1 CAVEATS diff --git a/lib/DBIx/Class/Storage/DBI/InterBase.pm b/lib/DBIx/Class/Storage/DBI/InterBase.pm index 5f5043b..cb6d8f9 100644 --- a/lib/DBIx/Class/Storage/DBI/InterBase.pm +++ b/lib/DBIx/Class/Storage/DBI/InterBase.pm @@ -30,10 +30,6 @@ L. =cut -__PACKAGE__->datetime_parser_type( - 'DBIx::Class::Storage::DBI::InterBase::DateTime::Format' -); - sub _ping { my $self = shift; @@ -135,55 +131,6 @@ sub connect_call_datetime_setup { $self->_get_dbh->{ib_time_all} = 'ISO'; } - -package # hide from PAUSE - DBIx::Class::Storage::DBI::InterBase::DateTime::Format; - -my $timestamp_format = '%Y-%m-%d %H:%M:%S.%4N'; # %F %T -my $date_format = '%Y-%m-%d'; - -my ($timestamp_parser, $date_parser); - -sub parse_datetime { - shift; - require DateTime::Format::Strptime; - $timestamp_parser ||= DateTime::Format::Strptime->new( - pattern => $timestamp_format, - on_error => 'croak', - ); - return $timestamp_parser->parse_datetime(shift); -} - -sub format_datetime { - shift; - require DateTime::Format::Strptime; - $timestamp_parser ||= DateTime::Format::Strptime->new( - pattern => $timestamp_format, - on_error => 'croak', - ); - return $timestamp_parser->format_datetime(shift); -} - -sub parse_date { - shift; - require DateTime::Format::Strptime; - $date_parser ||= DateTime::Format::Strptime->new( - pattern => $date_format, - on_error => 'croak', - ); - return $date_parser->parse_datetime(shift); -} - -sub format_date { - shift; - require DateTime::Format::Strptime; - $date_parser ||= DateTime::Format::Strptime->new( - pattern => $date_format, - on_error => 'croak', - ); - return $date_parser->format_datetime(shift); -} - 1; =head1 CAVEATS diff --git a/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm b/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm index ac0afbb..c5254b4 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm @@ -31,8 +31,6 @@ makes it more suitable for long running processes such as under L. =cut -__PACKAGE__->datetime_parser_type ('DBIx::Class::Storage::DBI::ODBC::Firebird::DateTime::Format'); - # batch operations in DBD::ODBC 1.35 do not work with the official ODBC driver sub _run_connection_actions { my $self = shift; @@ -61,37 +59,6 @@ sub _exec_svp_rollback { }; } -package # hide from PAUSE - DBIx::Class::Storage::DBI::ODBC::Firebird::DateTime::Format; - -# inherit parse/format date -our @ISA = 'DBIx::Class::Storage::DBI::InterBase::DateTime::Format'; - -my $timestamp_format = '%Y-%m-%d %H:%M:%S.%4N'; # %F %T -my $timestamp_parser; - -sub parse_datetime { - shift; - require DateTime::Format::Strptime; - $timestamp_parser ||= DateTime::Format::Strptime->new( - pattern => $timestamp_format, - on_error => 'croak', - ); - return $timestamp_parser->parse_datetime(shift); -} - -sub format_datetime { - shift; - require DateTime::Format::Strptime; - $timestamp_parser ||= DateTime::Format::Strptime->new( - pattern => $timestamp_format, - on_error => 'croak', - ); - return $timestamp_parser->format_datetime(shift); -} - -1; - =head1 AUTHOR See L and L. @@ -102,3 +69,5 @@ You may distribute this code under the same terms as Perl itself. =cut # vim:sts=2 sw=2: + +1; diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm index 568b561..d763953 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm @@ -285,7 +285,7 @@ sub _ping { sub _dbh_execute { #my ($self, $dbh, $sql, $bind, $bind_attrs) = @_; - my ($self, $bind) = @_[0,3]; + 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 { @@ -300,26 +300,31 @@ sub _dbh_execute { return shift->$next(@_) if $self->transaction_depth; - # cheat the blockrunner - we do want to rerun things regardless of outer state + # cheat the blockrunner we are just about to create + # we do want to rerun things regardless of outer state local $self->{_in_do_block}; return DBIx::Class::Storage::BlockRunner->new( storage => $self, - run_code => $next, - run_args => \@_, wrap_txn => 0, retry_handler => sub { # ORA-01003: no statement parsed (someone changed the table somehow, # invalidating your cursor.) - return 0 if ($_[0]->retried_count or $_[0]->last_exception !~ /ORA-01003/); - - # re-prepare towards new table data - if (my $dbh = $_[0]->storage->_dbh) { - delete $dbh->{CachedKids}{$_[0]->run_args->[2]}; + if ( + $_[0]->failed_attempt_count == 1 + and + $_[0]->last_exception =~ /ORA-01003/ + and + my $dbh = $_[0]->storage->_dbh + ) { + delete $dbh->{CachedKids}{$sql}; + return 1; + } + else { + return 0; } - return 1; }, - )->run; + )->run( $next, @_ ); } sub _dbh_execute_for_fetch { @@ -644,7 +649,7 @@ sub relname_to_table_alias { my $alias = $self->next::method(@_); # we need to shorten here in addition to the shortening in SQLA itself, - # since the final relnames are a crucial for the join optimizer + # since the final relnames are crucial for the join optimizer return $self->sql_maker->_shorten_identifier($alias); } diff --git a/lib/DBIx/Class/Storage/DBI/Replicated.pm b/lib/DBIx/Class/Storage/DBI/Replicated.pm index 91ce826..1d6102f 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated.pm @@ -37,7 +37,7 @@ also define your arguments, such as which balancer you want and any arguments that the Pool object should get. my $schema = Schema::Class->clone; - $schema->storage_type( ['::DBI::Replicated', {balancer=>'::Random'}] ); + $schema->storage_type(['::DBI::Replicated', { balancer_type => '::Random' }]); $schema->connection(...); Next, you need to add in the Replicants. Basically this is an array of @@ -338,6 +338,7 @@ my $method_dispatch = { _dbh_get_info _determine_connector_driver + _extract_driver_from_connect_info _describe_connection _warn_undetermined_driver @@ -1095,7 +1096,7 @@ attribute: my $result = $resultset->search(undef, {force_pool=>'master'})->find($pk); -This attribute will safely be ignore by non replicated storages, so you can use +This attribute will safely be ignored by non replicated storages, so you can use the same code for both types of systems. Lastly, you can use the L method, which works very much like diff --git a/lib/DBIx/Class/Storage/DBI/SQLite.pm b/lib/DBIx/Class/Storage/DBI/SQLite.pm index a1a84c0..2e4e312 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLite.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLite.pm @@ -257,7 +257,11 @@ sub bind_attribute_by_data_type { # DBD::SQLite warns on binding >32 bit values with 32 bit IVs sub _dbh_execute { if ( - DBIx::Class::_ENV_::IV_SIZE < 8 + ( + DBIx::Class::_ENV_::IV_SIZE < 8 + or + DBIx::Class::_ENV_::OS_NAME eq 'MSWin32' + ) and ! defined $DBD::SQLite::__DBIC_CHECK_dbd_mishandles_bound_BIGINT ) { @@ -272,7 +276,15 @@ sub _dbh_execute { | \d+ \s type \s @{[ DBI::SQL_BIGINT() ]} \s as \s [-+]? \d+ (?: \. 0*)? ) - /x ) if DBIx::Class::_ENV_::IV_SIZE < 8 and $DBD::SQLite::__DBIC_CHECK_dbd_mishandles_bound_BIGINT; + /x ) if ( + ( + DBIx::Class::_ENV_::IV_SIZE < 8 + or + DBIx::Class::_ENV_::OS_NAME eq 'MSWin32' + ) + and + $DBD::SQLite::__DBIC_CHECK_dbd_mishandles_bound_BIGINT + ); shift->next::method(@_); } @@ -291,13 +303,9 @@ sub _dbi_attrs_for_bind { my $bindattrs = $self->next::method($ident, $bind); - # somewhere between 1.33 and 1.37 things went horribly wrong if (! defined $DBD::SQLite::__DBIC_CHECK_dbd_can_bind_bigint_values) { - $DBD::SQLite::__DBIC_CHECK_dbd_can_bind_bigint_values = ( - modver_gt_or_eq('DBD::SQLite', '1.34') - and - ! modver_gt_or_eq('DBD::SQLite', '1.37') - ) ? 0 : 1; + $DBD::SQLite::__DBIC_CHECK_dbd_can_bind_bigint_values + = modver_gt_or_eq('DBD::SQLite', '1.37') ? 1 : 0; } # an attempt to detect former effects of RT#79576, bug itself present between @@ -326,23 +334,26 @@ sub _dbi_attrs_for_bind { } elsif ( ! $DBD::SQLite::__DBIC_CHECK_dbd_can_bind_bigint_values - and + ) { # unsigned 32 bit ints have a range of −2,147,483,648 to 2,147,483,647 # alternatively expressed as the hexadecimal numbers below # the comparison math will come out right regardless of ivsize, since # we are operating within 31 bits # P.S. 31 because one bit is lost for the sign - ($bind->[$i][1] > 0x7fff_ffff or $bind->[$i][1] < -0x8000_0000) - ) { - carp_unique( sprintf ( - "An integer value occupying more than 32 bits was supplied for column '%s' " - . 'which your version of DBD::SQLite (%s) can not bind properly so DBIC ' - . 'will treat it as a string instead, consider upgrading to at least ' - . 'DBD::SQLite version 1.37', - $bind->[$i][0]{dbic_colname} || "# $i", - DBD::SQLite->VERSION, - ) ); - undef $bindattrs->[$i]; + if ($bind->[$i][1] > 0x7fff_ffff or $bind->[$i][1] < -0x8000_0000) { + carp_unique( sprintf ( + "An integer value occupying more than 32 bits was supplied for column '%s' " + . 'which your version of DBD::SQLite (%s) can not bind properly so DBIC ' + . 'will treat it as a string instead, consider upgrading to at least ' + . 'DBD::SQLite version 1.37', + $bind->[$i][0]{dbic_colname} || "# $i", + DBD::SQLite->VERSION, + ) ); + undef $bindattrs->[$i]; + } + else { + $bindattrs->[$i] = DBI::SQL_INTEGER() + } } } } diff --git a/lib/DBIx/Class/Storage/DBI/Sybase.pm b/lib/DBIx/Class/Storage/DBI/Sybase.pm index 02464e4..79a449e 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase.pm @@ -83,8 +83,7 @@ sub _ping { if ($dbh->{syb_no_child_con}) { return try { - $self->_connect(@{$self->_dbi_connect_info || [] }) - ->do('select 1'); + $self->_connect->do('select 1'); 1; } catch { diff --git a/lib/DBIx/Class/Storage/DBI/mysql.pm b/lib/DBIx/Class/Storage/DBI/mysql.pm index 2130682..c241749 100644 --- a/lib/DBIx/Class/Storage/DBI/mysql.pm +++ b/lib/DBIx/Class/Storage/DBI/mysql.pm @@ -106,15 +106,17 @@ sub _run_connection_actions { sub sql_maker { my $self = shift; - unless ($self->_sql_maker) { - my $maker = $self->next::method (@_); + # it is critical to get the version *before* calling next::method + # otherwise the potential connect will obliterate the sql_maker + # next::method will populate in the _sql_maker accessor + my $mysql_ver = $self->_server_info->{normalized_dbms_version}; - # mysql 3 does not understand a bare JOIN - my $mysql_ver = $self->_dbh_get_info('SQL_DBMS_VER'); - $maker->needs_inner_join(1) if $mysql_ver =~ /^3/; - } + my $sm = $self->next::method(@_); + + # mysql 3 does not understand a bare JOIN + $sm->needs_inner_join(1) if $mysql_ver < 4; - return $self->_sql_maker; + $sm; } sub sqlt_type { diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm index 7334686..e3fef8b 100644 --- a/lib/DBIx/Class/Storage/DBIHacks.pm +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -444,17 +444,46 @@ sub _resolve_aliastypes_from_select_args { ), ], selecting => [ - ($attrs->{select} - ? ($sql_maker->_render_sqla(select_select => $attrs->{select}))[0] - : ()), + map { $sql_maker->_render_sqla(select_select => $_) =~ /^SELECT\s+(.+)/ } @{$attrs->{select}||[]}, ], ordering => [ map { $_->[0] } $self->_extract_order_criteria ($attrs->{order_by}, $sql_maker), ], }; - # throw away empty chunks - $_ = [ map { $_ || () } @$_ ] for values %$to_scan; + # throw away empty chunks and all 2-value arrayrefs: the thinking is that these are + # bind value specs left in by the sloppy renderer above. It is ok to do this + # at this point, since we are going to end up rewriting this crap anyway + for my $v (values %$to_scan) { + my @nv; + for (@$v) { + next if ( + ! defined $_ + or + ( + ref $_ eq 'ARRAY' + and + ( @$_ == 0 or @$_ == 2 ) + ) + ); + + if (ref $_) { + require Data::Dumper::Concise; + $self->throw_exception("Unexpected ref in scan-plan: " . Data::Dumper::Concise::Dumper($v) ); + } + + push @nv, $_; + } + + $v = \@nv; + } + + # kill all selectors which look like a proper subquery + # this is a sucky heuristic *BUT* - if we get it wrong the query will simply + # fail to run, so we are relatively safe + $to_scan->{selecting} = [ grep { + $_ !~ / \A \s* \( \s* SELECT \s+ .+? \s+ FROM \s+ .+? \) \s* \z /xsi + } @{ $to_scan->{selecting} || [] } ]; # first see if we have any exact matches (qualified or unqualified) for my $type (keys %$to_scan) { diff --git a/lib/DBIx/Class/Storage/TxnScopeGuard.pm b/lib/DBIx/Class/Storage/TxnScopeGuard.pm index 09a3fc5..18c99fa 100644 --- a/lib/DBIx/Class/Storage/TxnScopeGuard.pm +++ b/lib/DBIx/Class/Storage/TxnScopeGuard.pm @@ -5,6 +5,7 @@ use warnings; use Try::Tiny; use Scalar::Util qw/weaken blessed refaddr/; use DBIx::Class; +use DBIx::Class::_Util 'is_exception'; use DBIx::Class::Carp; use namespace::clean; @@ -23,9 +24,9 @@ sub new { # FIXME FRAGILE - any eval that fails but *does not* rethrow between here # and the unwind will trample over $@ and invalidate the entire mechanism # There got to be a saner way of doing this... - if (defined $@ and "$@" ne '') { + if (is_exception $@) { weaken( - $guard->{existing_exception_ref} = (ref $@ eq '') ? \$@ : $@ + $guard->{existing_exception_ref} = (ref($@) eq '') ? \$@ : $@ ); } @@ -58,14 +59,12 @@ sub DESTROY { return unless $self->{dbh}; my $exception = $@ if ( - defined $@ - and - "$@" ne '' + is_exception $@ and ( ! defined $self->{existing_exception_ref} or - refaddr( ref $@ eq '' ? \$@ : $@ ) != refaddr($self->{existing_exception_ref}) + refaddr( ref($@) eq '' ? \$@ : $@ ) != refaddr($self->{existing_exception_ref}) ) ); diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 5b3a427..3e3b68f 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -6,13 +6,60 @@ use strict; use constant SPURIOUS_VERSION_CHECK_WARNINGS => ($] < 5.010 ? 1 : 0); -use Carp; -use Scalar::Util qw(refaddr weaken); +BEGIN { + package # hide from pause + DBIx::Class::_ENV_; + + use Config; + + use constant { + + # but of course + BROKEN_FORK => ($^O eq 'MSWin32') ? 1 : 0, + + HAS_ITHREADS => $Config{useithreads} ? 1 : 0, + + # ::Runmode would only be loaded by DBICTest, which in turn implies t/ + DBICTEST => eval { DBICTest::RunMode->is_author } ? 1 : 0, + + # During 5.13 dev cycle HELEMs started to leak on copy + PEEPEENESS => + # request for all tests would force "non-leaky" illusion and vice-versa + defined $ENV{DBICTEST_ALL_LEAKS} ? !$ENV{DBICTEST_ALL_LEAKS} + # otherwise confess that this perl is busted ONLY on smokers + : eval { DBICTest::RunMode->is_smoker } && ($] >= 5.013005 and $] <= 5.013006) ? 1 + # otherwise we are good + : 0 + , + + ASSERT_NO_INTERNAL_WANTARRAY => $ENV{DBIC_ASSERT_NO_INTERNAL_WANTARRAY} ? 1 : 0, + + IV_SIZE => $Config{ivsize}, + + OS_NAME => $^O, + }; + + if ($] < 5.009_005) { + require MRO::Compat; + constant->import( OLD_MRO => 1 ); + } + else { + require mro; + constant->import( OLD_MRO => 0 ); + } +} + +# FIXME - this is not supposed to be here +# Carp::Skip to the rescue soon +use DBIx::Class::Carp '^DBIx::Class|^DBICTest'; + +use Carp 'croak'; +use Scalar::Util qw(weaken blessed reftype); use base 'Exporter'; -our @EXPORT_OK = qw(sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray); +our @EXPORT_OK = qw(sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray refcount hrefaddr is_exception); -sub sigwarn_silencer { +sub sigwarn_silencer ($) { my $pattern = shift; croak "Expecting a regexp" if ref $pattern ne 'Regexp'; @@ -22,7 +69,72 @@ sub sigwarn_silencer { return sub { &$orig_sig_warn unless $_[0] =~ $pattern }; } -sub modver_gt_or_eq { +sub hrefaddr ($) { sprintf '0x%x', &Scalar::Util::refaddr } + +sub refcount ($) { + croak "Expecting a reference" if ! length ref $_[0]; + + require B; + # No tempvars - must operate on $_[0], otherwise the pad + # will count as an extra ref + B::svref_2object($_[0])->REFCNT; +} + +sub is_exception ($) { + my $e = $_[0]; + + # this is not strictly correct - an eval setting $@ to undef + # is *not* the same as an eval setting $@ to '' + # but for the sake of simplicity assume the following for + # the time being + return 0 unless defined $e; + + my ($not_blank, $suberror); + { + local $@; + eval { + $not_blank = ($e ne '') ? 1 : 0; + 1; + } or $suberror = $@; + } + + if (defined $suberror) { + if (length (my $class = blessed($e) )) { + carp_unique( sprintf( + 'External exception object %s=%s(%s) implements partial (broken) ' + . 'overloading preventing it from being used in simple ($x eq $y) ' + . 'comparisons. Given Perl\'s "globally cooperative" exception ' + . 'handling this type of brokenness is extremely dangerous on ' + . 'exception objects, as it may (and often does) result in silent ' + . '"exception substitution". DBIx::Class tries to work around this ' + . 'as much as possible, but other parts of your software stack may ' + . 'not be even aware of this. Please submit a bugreport against the ' + . 'distribution containing %s and in the meantime apply a fix similar ' + . 'to the one shown at %s, in order to ensure your exception handling ' + . 'is saner application-wide. What follows is the actual error text ' + . "as generated by Perl itself:\n\n%s\n ", + $class, + reftype $e, + hrefaddr $e, + $class, + 'http://v.gd/DBIC_overload_tempfix/', + $suberror, + )); + + # workaround, keeps spice flowing + $not_blank = ("$e" ne '') ? 1 : 0; + } + else { + # not blessed yet failed the 'ne'... this makes 0 sense... + # just throw further + die $suberror + } + } + + return $not_blank; +} + +sub modver_gt_or_eq ($$) { my ($mod, $ver) = @_; croak "Nonsensical module name supplied" @@ -70,8 +182,8 @@ sub modver_gt_or_eq { my $obj = shift; DBIx::Class::Exception->throw( sprintf ( - "Improper use of %s(0x%x) instance in list context at %s line %d\n\n\tStacktrace starts", - ref($obj), refaddr($obj), (caller($cf))[1,2] + "Improper use of %s(%s) instance in list context at %s line %d\n\n\tStacktrace starts", + ref($obj), hrefaddr($obj), (caller($cf))[1,2] ), 'with_stacktrace'); } diff --git a/maint/gen_sqlite_schema_files b/maint/gen_sqlite_schema_files index 03db999..a3793d3 100755 --- a/maint/gen_sqlite_schema_files +++ b/maint/gen_sqlite_schema_files @@ -26,6 +26,7 @@ die "You need to specify one DBIC schema class via --schema-class\n" die "You may not specify more than one deploy path via --deploy-to\n" if @{$args->{'deploy-to'}||[]} > 1; +local $ENV{DBI_DSN}; my $schema = use_module( $args->{'schema-class'}[0] )->connect( $args->{'deploy-to'} ? ( "DBI:SQLite:$args->{'deploy-to'}[0]", undef, undef, { on_connect_do => "PRAGMA synchronous = OFF" } ) diff --git a/maint/travis-ci_scripts/10_before_install.bash b/maint/travis-ci_scripts/10_before_install.bash index b582b34..f861b0e 100755 --- a/maint/travis-ci_scripts/10_before_install.bash +++ b/maint/travis-ci_scripts/10_before_install.bash @@ -11,9 +11,13 @@ if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi # The oneliner is a tad convoluted - basicaly what we do is # slurp the entire file and get the index off the last # `processor : XX` line -export NUMTHREADS=$(( $(perl -0777 -n -e 'print (/ (?: .+ ^ processor \s+ : \s+ (\d+) ) (?! ^ processor ) /smx)' < /proc/cpuinfo) + 1 )) +export NUMTHREADS="$(( $(perl -0777 -n -e 'print (/ (?: .+ ^ processor \s+ : \s+ (\d+) ) (?! ^ processor ) /smx)' < /proc/cpuinfo) + 1 ))" + +export CACHE_DIR="/tmp/poormanscache" + +# install some common tools from APT, more below unless CLEANTEST +apt_install libapp-nopaste-perl tree apt-transport-https -run_or_err "Installing common tools from APT" "sudo apt-get install --allow-unauthenticated -y libapp-nopaste-perl tree" # FIXME - the debian package is oddly broken - uses a bin/env based shebang # so nothing works under a brew. Fix here until #debian-perl patches it up sudo /usr/bin/perl -p -i -e 's|#!/usr/bin/env perl|#!/usr/bin/perl|' $(which nopaste) @@ -25,10 +29,18 @@ if [[ "$CLEANTEST" != "true" ]]; then sudo bash -c 'echo -e "firebird2.5-super\tshared/firebird/enabled\tboolean\ttrue" | debconf-set-selections' sudo bash -c 'echo -e "firebird2.5-super\tshared/firebird/sysdba_password/new_password\tpassword\t123" | debconf-set-selections' - APT_PACKAGES="memcached firebird2.5-super firebird2.5-dev expect" - run_or_err "Installing packages ($APT_PACKAGES)" "sudo apt-get install --allow-unauthenticated -y $APT_PACKAGES" + # add extra APT repo for Oracle + # (https is critical - apt-get update can't seem to follow the 302) + sudo bash -c 'echo -e "\ndeb [arch=i386] https://oss.oracle.com/debian unstable main non-free" >> /etc/apt/sources.list' + + run_or_err "Cloning poor man's cache from github" "git clone --depth=1 --branch=poor_mans_travis_cache https://github.com/ribasushi/travis_futzing.git $CACHE_DIR && $CACHE_DIR/reassemble" + + run_or_err "Priming up the APT cache with $(echo $(ls -d $CACHE_DIR/apt_cache/*.deb))" "sudo cp $CACHE_DIR/apt_cache/*.deb /var/cache/apt/archives" + + apt_install memcached firebird2.5-super firebird2.5-dev unixodbc-dev expect oracle-xe ### config memcached + run_or_err "Starting memcached" "sudo /etc/init.d/memcached start" export DBICTEST_MEMCACHED=127.0.0.1:11211 ### config mysql @@ -50,8 +62,7 @@ if [[ "$CLEANTEST" != "true" ]]; then expect "Password for SYSDBA" send "123\r" sleep 1 - wait - sleep 1 + expect eof ' # creating testdb # FIXME - this step still fails from time to time >:((( @@ -76,6 +87,25 @@ if [[ "$CLEANTEST" != "true" ]]; then if run_or_err "Creating Firebird TestDB" \ "echo \"CREATE DATABASE '/var/lib/firebird/2.5/data/dbic_test.fdb';\" | sudo isql-fb -u sysdba -p 123" then + + 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 + 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 + ' + + sudo bash -c 'cat >> /etc/odbcinst.ini' <<< " +[Firebird] +Description = InterBase/Firebird ODBC Driver +Driver = /usr/lib/x86_64-linux-gnu/libOdbcFb.so +Setup = /usr/lib/x86_64-linux-gnu/libOdbcFb.so +Threading = 1 +FileUsage = 1 +" + export DBICTEST_FIREBIRD_DSN=dbi:Firebird:dbname=/var/lib/firebird/2.5/data/dbic_test.fdb export DBICTEST_FIREBIRD_USER=SYSDBA export DBICTEST_FIREBIRD_PASS=123 @@ -84,18 +114,75 @@ if [[ "$CLEANTEST" != "true" ]]; then export DBICTEST_FIREBIRD_INTERBASE_USER=SYSDBA export DBICTEST_FIREBIRD_INTERBASE_PASS=123 + export DBICTEST_FIREBIRD_ODBC_DSN="dbi:ODBC:Driver=Firebird;Dbname=/var/lib/firebird/2.5/data/dbic_test.fdb" + export DBICTEST_FIREBIRD_ODBC_USER=SYSDBA + export DBICTEST_FIREBIRD_ODBC_PASS=123 + break fi done -### oracle - # FIXME: todo - #DBICTEST_ORA_DSN=dbi:Oracle:host=localhost;sid=XE - #DBICTEST_ORA_USER=dbic_test - #DBICTEST_ORA_PASS=123 - #DBICTEST_ORA_EXTRAUSER_DSN=dbi:Oracle:host=localhost;sid=XE - #DBICTEST_ORA_EXTRAUSER_USER=dbic_test_extra - #DBICTEST_ORA_EXTRAUSER_PASS=123 - #ORACLE_HOME=/usr/lib/oracle/xe/app/oracle/product/10.2.0/client +### config oracle + SRV_ORA_HOME=/usr/lib/oracle/xe/app/oracle/product/10.2.0/server + + # without this some of the more zealous tests can exhaust the amount + # of listeners and oracle is too slow to spin extras up :( + sudo bash -c "echo -e '\nprocesses=150' >> $SRV_ORA_HOME/config/scripts/init.ora" + + EXPECT_ORA_SCRIPT=' + spawn /etc/init.d/oracle-xe configure + + sleep 1 + set send_slow {1 .005} + + expect "Specify the HTTP port that will be used for Oracle Application Express" + sleep 0.5 + send -s "8021\r" + + expect "Specify a port that will be used for the database listener" + sleep 0.5 + send -s "1521\r" + + expect "Specify a password to be used for database accounts" + sleep 0.5 + send -s "adminpass\r" + + expect "Confirm the password" + sleep 0.5 + send -s "adminpass\r" + + expect "Do you want Oracle Database 10g Express Edition to be started on boot" + sleep 0.5 + send -s "n\r" + + sleep 0.5 + expect "Configuring Database" + + sleep 1 + expect eof + wait + ' + + # if we do not redirect to some random file, but instead try to capture + # into a var the way run_or_err does - everything hangs + # FIXME: I couldn't figure it out after 3 hours of headdesking, + # would be nice to know the reason eventually + run_or_err "Configuring OracleXE" "sudo $(which expect) -c '$EXPECT_ORA_SCRIPT' &>/tmp/ora_configure_10.2.log" + + export DBICTEST_ORA_DSN=dbi:Oracle://localhost:1521/XE + export DBICTEST_ORA_USER=dbic_test + export DBICTEST_ORA_PASS=abc123456 + export DBICTEST_ORA_EXTRAUSER_DSN="$DBICTEST_ORA_DSN" + export DBICTEST_ORA_EXTRAUSER_USER=dbic_test_extra + export DBICTEST_ORA_EXTRAUSER_PASS=abc123456 + + run_or_err "Create Oracle users" "ORACLE_SID=XE ORACLE_HOME=$SRV_ORA_HOME $SRV_ORA_HOME/bin/sqlplus -L -S system/adminpass @/dev/stdin <<< ' + CREATE USER $DBICTEST_ORA_USER IDENTIFIED BY $DBICTEST_ORA_PASS; + GRANT connect,resource TO $DBICTEST_ORA_USER; + CREATE USER $DBICTEST_ORA_EXTRAUSER_USER IDENTIFIED BY $DBICTEST_ORA_EXTRAUSER_PASS; + GRANT connect,resource TO $DBICTEST_ORA_EXTRAUSER_USER; + '" + + export ORACLE_HOME="$CACHE_DIR/ora_instaclient/x86-64/oracle_instaclient_10.2.0.5.0" fi diff --git a/maint/travis-ci_scripts/20_install.bash b/maint/travis-ci_scripts/20_install.bash index a05823d..79e75cd 100755 --- a/maint/travis-ci_scripts/20_install.bash +++ b/maint/travis-ci_scripts/20_install.bash @@ -7,7 +7,7 @@ CPAN_MIRROR=$(echo "$PERL_CPANM_OPT" | grep -oP -- '--mirror\s+\S+' | head -n 1 if ! [[ "$CPAN_MIRROR" =~ "http://" ]] ; then echo_err "Unable to extract primary cpan mirror from PERL_CPANM_OPT - something is wrong" echo_err "PERL_CPANM_OPT: $PERL_CPANM_OPT" - CPAN_MIRROR="http://cpan.metacpan.org/" + CPAN_MIRROR="https://cpan.metacpan.org/" PERL_CPANM_OPT="$PERL_CPANM_OPT --mirror $CPAN_MIRROR" echo_err "Using $CPAN_MIRROR for the time being" fi @@ -17,11 +17,6 @@ export PERL_MM_USE_DEFAULT=1 PERL_MM_NONINTERACTIVE=1 PERL_AUTOINSTALL_PREFER_CP # try CPAN's latest offering if requested if [[ "$DEVREL_DEPS" == "true" ]] ; then - if [[ "$CLEANTEST" == "true" ]] ; then - echo_err "DEVREL_DEPS combined with CLEANTEST makes no sense - it is only possible with cpanm" - exit 1 - fi - PERL_CPANM_OPT="$PERL_CPANM_OPT --dev" # FIXME inline-upgrade cpanm, work around https://github.com/travis-ci/travis-ci/issues/1477 diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 54e0b5b..10f380c 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -3,19 +3,53 @@ source maint/travis-ci_scripts/common.bash if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi -# poison the environment - basically look through lib, find all mentioned -# ENVvars and set them to true and see if anything explodes +# poison the environment if [[ "$POISON_ENV" = "true" ]] ; then + + # look through lib, find all mentioned ENVvars and set them + # to true and see if anything explodes for var in $(grep -P '\$ENV\{' -r lib/ | grep -oP 'DBIC_\w+' | sort -u | grep -v DBIC_TRACE) ; do if [[ -z "${!var}" ]] ; then export $var=1 fi done + # bogus nonexisting DBI_* export DBI_DSN="dbi:ODBC:server=NonexistentServerAddress" export DBI_DRIVER="ADO" + # make sure tests do not rely on implicid order of returned results export DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER=1 + + # 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" + + export PERL5LIB="$( ls -d ~/.cpanm/latest-build/DBIx-Class-*/lib | tail -n1 ):$PERL5LIB" + + # 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)" + + # FIXME - this is a kludge in place of proper MDV 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) + # + # use url-spec for DBI due to https://github.com/miyagawa/cpanminus/issues/328 + if perl -M5.013003 -e1 &>/dev/null ; then + # 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 + else + parallel_installdeps_notest T/TI/TIMB/DBI-1.57.tar.gz + fi + + # Test both minimum DBD::SQLite and minimum BigInt SQLite + if [[ "$CLEANTEST" = "true" ]]; then + parallel_installdeps_notest DBD::SQLite@1.37 + else + parallel_installdeps_notest DBD::SQLite@1.29 + fi + fi if [[ "$CLEANTEST" = "true" ]]; then @@ -26,7 +60,7 @@ if [[ "$CLEANTEST" = "true" ]]; then # effects from travis preinstalls) # trick cpanm into executing true as shell - we just need the find+unpack - run_or_err "Downloading DBIC inc/ from CPAN" \ + [[ -d ~/.cpanm/latest-build/DBIx-Class-*/inc ]] || run_or_err "Downloading latest stable DBIC inc/ from CPAN" \ "SHELL=/bin/true cpanm --look DBIx::Class" mv ~/.cpanm/latest-build/DBIx-Class-*/inc . @@ -39,15 +73,30 @@ if [[ "$CLEANTEST" = "true" ]]; then # So instead we still use our stock (possibly old) CPAN, and add some # handholding - # no configure_requires - we will need the usual suspects anyway - # without pre-installign these in one pass things like extract_prereqs won't work - CPAN_is_sane || installdeps ExtUtils::MakeMaker ExtUtils::CBuilder Module::Build + if [[ "$DEVREL_DEPS" == "true" ]] ; then + # Many dists still do not pass tests under tb1.5 properly (and it itself + # does not even install on things like 5.10). Install the *stable-dev* + # latest T::B here, so that it will not show up as a dependency, and + # hence it will not get installed a second time as an unsatisfied dep + # under cpanm --dev + # + # We are also not "quite ready" for SQLA 1.99, do not consider it + # + installdeps 'Test::Builder~<1.005' 'SQL::Abstract~<1.99' + + elif ! CPAN_is_sane ; then + # no configure_requires - we will need the usual suspects anyway + # without pre-installing these in one pass things like extract_prereqs won't work + installdeps ExtUtils::MakeMaker ExtUtils::CBuilder Module::Build + + fi else # we will be running all dbic tests - preinstall lots of stuff, run basic tests # using SQLT and set up whatever databases necessary export DBICTEST_SQLT_DEPLOY=1 + # FIXME - need new TB1.5 devrel # if we run under --dev install latest github of TB1.5 first # (unreleased workaround for precedence warnings) if [[ "$DEVREL_DEPS" == "true" ]] ; then @@ -62,22 +111,19 @@ else parallel_installdeps_notest ExtUtils::MakeMaker parallel_installdeps_notest File::Path parallel_installdeps_notest Carp - parallel_installdeps_notest Module::Build Module::Runtime - parallel_installdeps_notest File::Spec Data::Dumper + parallel_installdeps_notest Module::Build + parallel_installdeps_notest File::Spec Data::Dumper Module::Runtime parallel_installdeps_notest Test::Exception Encode::Locale Test::Fatal 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 JSON::XS DBI DateTime::Format::Builder Class::Accessor::Grouped Package::Variant - parallel_installdeps_notest Moose Module::Install JSON SQL::Translator File::Which indirect multidimensional bareword::filehandles + parallel_installdeps_notest YAML LWP Class::Trigger JSON::XS DateTime::Format::Builder Class::Accessor::Grouped Package::Variant + parallel_installdeps_notest 'SQL::Abstract~<1.99' Moose Module::Install JSON SQL::Translator File::Which - if [[ -n "DBICTEST_FIREBIRD_DSN" ]] ; then + if [[ -n "$DBICTEST_FIREBIRD_INTERBASE_DSN" ]] ; then # the official version is very much outdated and does not compile on 5.14+ # use this rather updated source tree (needs to go to PAUSE): # https://github.com/pilcrow/perl-dbd-interbase - run_or_err "Fetching patched DBD::InterBase" \ - "git clone https://github.com/dbsrgits/perl-dbd-interbase ~/dbd-interbase" - - parallel_installdeps_notest ~/dbd-interbase/ + parallel_installdeps_notest git://github.com/dbsrgits/perl-dbd-interbase.git fi fi @@ -91,18 +137,23 @@ if [[ "$CLEANTEST" = "true" ]]; then # we may need to prepend some stuff to that list HARD_DEPS="$(echo $(make listdeps))" -##### TEMPORARY WORKAROUNDS - if ! CPAN_is_sane ; then +##### TEMPORARY WORKAROUNDS needed in case we will be using CPAN.pm + if [[ "$DEVREL_DEPS" != "true" ]] && ! CPAN_is_sane ; then # combat dzillirium on harness-wide level, otherwise breakage happens weekly echo_err "$(tstamp) Ancient CPAN.pm: engaging TAP::Harness::IgnoreNonessentialDzilAutogeneratedTests during dep install" - perl -MTAP::Harness=3.18 -e1 &>/dev/null || run_or_err "Upgrading TAP::Harness for HARNESS_SUBCLASS support" "cpan TAP::Harness" + perl -MTAP::Harness\ 3.18 -e1 &>/dev/null || run_or_err "Upgrading TAP::Harness for HARNESS_SUBCLASS support" "cpan TAP::Harness" export PERL5LIB="$(pwd)/maint/travis-ci_scripts/lib:$PERL5LIB" export HARNESS_SUBCLASS="TAP::Harness::IgnoreNonessentialDzilAutogeneratedTests" # sanity check, T::H does not report sensible errors when the subclass fails to load perl -MTAP::Harness::IgnoreNonessentialDzilAutogeneratedTests -e1 # DBD::SQLite reasonably wants DBI at config time - HARD_DEPS="DBI $HARD_DEPS" + perl -MDBI -e1 &>/dev/null || HARD_DEPS="DBI $HARD_DEPS" + + # this is a fucked CPAN - won't understand configure_requires of + # various pieces we may run into + # FIXME - need to get these off metacpan or something instead + HARD_DEPS="ExtUtils::Depends B::Hooks::OP::Check $HARD_DEPS" # FIXME # parent is temporary due to Carp https://rt.cpan.org/Ticket/Display.html?id=88494 @@ -167,8 +218,16 @@ while (@chunks) { else # listalldeps is deliberate - will upgrade everything it can find - parallel_installdeps_notest $(make listalldeps) + # we exclude SQLA specifically, since we do not want to pull + # in 1.99_xx on bleadcpan runs + deplist="$(make listalldeps | grep -vP '^(SQL::Abstract)$')" + # assume MDV on POISON_ENV, do not touch DBI/SQLite + if [[ "$POISON_ENV" = "true" ]] ; then + deplist="$(grep -vP '^(DBI|DBD::SQLite)$' <<< "$deplist")" + fi + + parallel_installdeps_notest "$deplist" fi echo_err "$(tstamp) Dependency installation finished" @@ -185,6 +244,13 @@ 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 + echo_err "Something went wrong - higher versions of DBI and/or DBD::SQLite than we expected" + exit 1 +fi + + # announce what are we running echo_err " ===================== DEPENDENCY CONFIGURATION COMPLETE ===================== @@ -196,6 +262,15 @@ $(perl -0777 -p -e 's/.+\n\n(?!\z)//s' < /proc/cpuinfo) = Meminfo $(free -m -t) += Kernel info +$(uname -a) + += Network Configuration +$(ip addr) + += Network Sockets Status +$(sudo netstat -an46p | grep -Pv '\s(CLOSING|(FIN|TIME|CLOSE)_WAIT.?|LAST_ACK)\s') + = Environment $(env | grep -P 'TEST|HARNESS|MAKE|TRAVIS|PERL|DBIC' | LC_ALL=C sort | cat -v) diff --git a/maint/travis-ci_scripts/40_script.bash b/maint/travis-ci_scripts/40_script.bash index 189eae3..8cb9048 100755 --- a/maint/travis-ci_scripts/40_script.bash +++ b/maint/travis-ci_scripts/40_script.bash @@ -38,6 +38,7 @@ if [[ -z "$DBICTRACE" ]] && [[ -z "$POISON_ENV" ]] && [[ -s "$TEST_STDERR_LOG" ] echo "=============================================================" echo "End of test run STDERR output ($STDERR_LOG_SIZE lines)" echo + echo )$POSTMORTEM" fi diff --git a/maint/travis-ci_scripts/50_after_success.bash b/maint/travis-ci_scripts/50_after_success.bash index 949263d..c8d2bac 100755 --- a/maint/travis-ci_scripts/50_after_success.bash +++ b/maint/travis-ci_scripts/50_after_success.bash @@ -4,7 +4,12 @@ source maint/travis-ci_scripts/common.bash if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi if [[ "$CLEANTEST" != "true" ]] ; then - run_or_err "Install Pod::POM separately via cpan" "cpan -f Pod::POM || /bin/true" parallel_installdeps_notest $(perl -Ilib -MDBIx::Class -e 'print join " ", keys %{DBIx::Class::Optional::Dependencies->req_list_for("dist_dir")}') run_or_err "Attempt to build a dist with all prereqs present" "make dist" + echo "Contents of the resulting dist tarball:" + echo "===========================================" + tar -vzxf DBIx-Class-*.tar.gz + echo "===========================================" + run_or_err 'Attempt to configure from re-extracted distdir' \ + 'bash -c "cd \$(find DBIx-Class-* -maxdepth 0 -type d | head -n 1) && perl Makefile.PL"' fi diff --git a/maint/travis-ci_scripts/common.bash b/maint/travis-ci_scripts/common.bash index def7586..da6ce33 100755 --- a/maint/travis-ci_scripts/common.bash +++ b/maint/travis-ci_scripts/common.bash @@ -3,6 +3,7 @@ set -e TEST_STDERR_LOG=/tmp/dbictest.stderr +TIMEOUT_CMD="/usr/bin/timeout --kill-after=9.5m --signal=TERM 9m" echo_err() { echo "$@" 1>&2 ; } @@ -16,17 +17,29 @@ tstamp() { echo -n "[$(date '+%H:%M:%S')]" ; } run_or_err() { echo_err -n "$(tstamp) $1 ... " + LASTCMD="$2" LASTEXIT=0 START_TIME=$SECONDS - LASTOUT=$( bash -c "$2" 2>&1 ) || LASTEXIT=$? + + PRMETER_PIDFILE="$(tempfile)_$SECONDS" + # the double bash is to hide the job control messages + bash -c "bash -c 'echo \$\$ >> $PRMETER_PIDFILE; while true; do sleep 10; echo -n \"\${SECONDS}s ... \"; done' &" + + LASTOUT=$( eval "$2" 2>&1 ) || LASTEXIT=$? + + # stop progress meter + for p in $(cat "$PRMETER_PIDFILE"); do kill $p ; done + DELTA_TIME=$(( $SECONDS - $START_TIME )) if [[ "$LASTEXIT" != "0" ]] ; then - echo_err "FAILED !!! (after ${DELTA_TIME}s)" - echo_err "Command executed:" - echo_err "$2" - echo_err "STDOUT+STDERR:" - echo_err "$LASTOUT" + if [[ -z "$3" ]] ; then + echo_err "FAILED !!! (after ${DELTA_TIME}s)" + echo_err "Command executed:" + echo_err "$LASTCMD" + echo_err "STDOUT+STDERR:" + echo_err "$LASTOUT" + fi return $LASTEXIT else @@ -34,6 +47,16 @@ run_or_err() { fi } +apt_install() { + # flatten + pkgs="$@" + + # Need to do this at every step, the sources list may very well have changed + run_or_err "Updating APT available package list" "sudo apt-get update" + + run_or_err "Installing Debian APT packages: $pkgs" "sudo apt-get install --allow-unauthenticated --no-install-recommends -y $pkgs" +} + extract_prereqs() { # once --verbose is set, --no-verbose can't disable it # do this by hand @@ -45,7 +68,7 @@ extract_prereqs() { || LASTEXIT=$? OUT=${COMBINED_OUT#*!!!STDERRSTDOUTSEPARATOR!!!} - ERR=$(grep -v " is up to date." <<< "${COMBINED_OUT%!!!STDERRSTDOUTSEPARATOR!!!*}") + ERR=${COMBINED_OUT%!!!STDERRSTDOUTSEPARATOR!!!*} if [[ "$LASTEXIT" != "0" ]] ; then echo_err "Error occured (exit code $LASTEXIT) retrieving dependencies of $@:" @@ -54,8 +77,14 @@ extract_prereqs() { exit 1 fi - # throw away ascii art, convert to modnames - PQ=$(perl -p -e 's/^[^a-z]+//i; s/\-[^\-]+$/ /; s/\-/::/g' <<< "$OUT") + # throw away warnings, up-to-date diag, ascii art, convert to modnames + PQ=$(perl -p -e ' + s/^.*?is up to date.*$//; + s/^\!.*//; + s/^[^a-z]+//i; + s/\-[^\-]+$/ /; # strip version part + s/\-/::/g + ' <<< "$OUT") # throw away what was in $@ for m in "$@" ; do @@ -72,10 +101,14 @@ parallel_installdeps_notest() { # one module spec per line MODLIST="$(printf '%s\n' "$@")" - # The reason we do things so "non-interactively" is that xargs -P will have the - # latest cpanm instance overwrite the buildlog. There seems to be no way to - # specify a custom buildlog, hence we just collect the verbose output - # and display it in case of "worker" failure + # We want to trap the output of each process and serially append them to + # each other as opposed to just dumping a jumbled up mass-log that would + # need careful unpicking by a human + # + # While cpanm does maintain individual buildlogs in more recent versions, + # we are not terribly interested in trying to figure out which log is which + # dist. The verbose-output + trap STDIO technique is vastly superior in this + # particular case # # Explanation of inline args: # @@ -90,7 +123,7 @@ parallel_installdeps_notest() { "echo \\ \"$MODLIST\" \\ | xargs -d '\\n' -n 1 -P $NUMTHREADS bash -c \\ - 'OUT=\$(cpanm --notest --no-man-pages \"\$@\" 2>&1 ) || (LASTEXIT=\$?; echo \"\$OUT\"; exit \$LASTEXIT)' \\ + 'OUT=\$($TIMEOUT_CMD cpanm --notest \"\$@\" 2>&1 ) || (LASTEXIT=\$?; echo \"\$OUT\"; exit \$LASTEXIT)' \\ 'giant space monkey penises' " } @@ -98,68 +131,57 @@ parallel_installdeps_notest() { installdeps() { if [[ -z "$@" ]] ; then return; fi - echo_err "$(tstamp) Processing dependencies: $@" + MODLIST=$(printf "%q " "$@" | perl -pe 's/^\s+|\s+$//g') local -x HARNESS_OPTIONS HARNESS_OPTIONS="j$NUMTHREADS" - echo_err -n "Attempting install of $# modules under parallel ($HARNESS_OPTIONS) testing ... " + if ! run_or_err "Attempting install of $# modules under parallel ($HARNESS_OPTIONS) testing ($MODLIST)" "_dep_inst_with_test $MODLIST" quiet_fail ; then + local errlog="failed after ${DELTA_TIME}s Exit:$LASTEXIT Log:$(/usr/bin/nopaste -q -s Shadowcat -d "Parallel testfail" <<< "$LASTOUT")" + echo "$errlog" - LASTEXIT=0 - START_TIME=$SECONDS - LASTOUT=$( cpan_inst "$@" ) || LASTEXIT=$? - DELTA_TIME=$(( $SECONDS - $START_TIME )) - - if [[ "$LASTEXIT" = "0" ]] ; then - echo_err "done (took ${DELTA_TIME}s)" - else - local errlog="after ${DELTA_TIME}s Exit:$LASTEXIT Log:$(/usr/bin/nopaste -q -s Shadowcat -d "Parallel installfail" <<< "$LASTOUT")" - echo_err -n "failed ($errlog) retrying with sequential testing ... " POSTMORTEM="$POSTMORTEM$( echo - echo "Depinstall under $HARNESS_OPTIONS parallel testing failed $errlog" - echo "=============================================================" - echo "Attempted installation of: $@" - echo "=============================================================" + echo "Depinstall of $MODLIST under $HARNESS_OPTIONS parallel testing $errlog" )" HARNESS_OPTIONS="" - LASTEXIT=0 - START_TIME=$SECONDS - LASTOUT=$( cpan_inst "$@" ) || LASTEXIT=$? - DELTA_TIME=$(( $SECONDS - $START_TIME )) - - if [[ "$LASTEXIT" = "0" ]] ; then - echo_err "done (took ${DELTA_TIME}s)" - else - echo_err "FAILED !!! (after ${DELTA_TIME}s)" - echo_err "STDOUT+STDERR:" - echo_err "$LASTOUT" - exit 1 - fi + run_or_err "Retrying same $# modules without parallel testing" "_dep_inst_with_test $MODLIST" fi INSTALLDEPS_OUT="${INSTALLDEPS_OUT}${LASTOUT}" } -cpan_inst() { - /usr/bin/timeout --kill-after=9.5m --signal=TERM 9m cpan "$@" 2>&1 +_dep_inst_with_test() { + if [[ "$DEVREL_DEPS" == "true" ]] ; then + # --dev is already part of CPANM_OPT + LASTCMD="$TIMEOUT_CMD cpanm $@" + $LASTCMD 2>&1 + else + LASTCMD="$TIMEOUT_CMD cpan $@" + $LASTCMD 2>&1 - # older perls do not have a CPAN which can exit with error on failed install - for m in "$@"; do - if ! perl -e ' + # older perls do not have a CPAN which can exit with error on failed install + for m in "$@"; do + if ! perl -e ' -eval ( q{require } . ( +my $mod = ( $ARGV[0] =~ m{ \/ .*? ([^\/]+) $ }x ? do { my @p = split (/\-/, $1); pop @p; join "::", @p } : $ARGV[0] -) ) or ( print $@ and exit 1)' "$m" 2> /dev/null ; then +); - echo -e "$m installation seems to have failed" - return 1 - fi - done +$mod = q{List::Util} if $mod eq q{Scalar::List::Utils}; + +eval qq{require($mod)} or ( print $@ and exit 1) + + ' "$m" 2> /dev/null ; then + echo -e "$m installation seems to have failed" + return 1 + fi + done + fi } CPAN_is_sane() { perl -MCPAN\ 1.94_56 -e 1 &>/dev/null ; } diff --git a/t/39load_namespaces_1.t b/t/39load_namespaces_1.t index d160040..0f8ae1e 100644 --- a/t/39load_namespaces_1.t +++ b/t/39load_namespaces_1.t @@ -13,9 +13,9 @@ eval { __PACKAGE__->load_namespaces; }; ok(!$@, 'load_namespaces doesnt die') or diag $@; -like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/, 'Found warning about extra ResultSet classes'); +like($warnings, qr/load_namespaces found ResultSet class 'DBICNSTest::ResultSet::C' with no corresponding Result class/, 'Found warning about extra ResultSet classes'); -like($warnings, qr/load_namespaces found ResultSet class DBICNSTest::ResultSet::D that does not subclass DBIx::Class::ResultSet/, 'Found warning about ResultSets with incorrect subclass'); +like($warnings, qr/load_namespaces found ResultSet class 'DBICNSTest::ResultSet::D' that does not subclass DBIx::Class::ResultSet/, 'Found warning about ResultSets with incorrect subclass'); my $source_a = DBICNSTest->source('A'); isa_ok($source_a, 'DBIx::Class::ResultSource::Table'); diff --git a/t/39load_namespaces_2.t b/t/39load_namespaces_2.t index 77cb9e0..d9b88fa 100644 --- a/t/39load_namespaces_2.t +++ b/t/39load_namespaces_2.t @@ -18,7 +18,7 @@ eval { ); }; ok(!$@) or diag $@; -like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/); +like($warnings, qr/load_namespaces found ResultSet class 'DBICNSTest::RSet::C' with no corresponding Result class/); my $source_a = DBICNSTest->source('A'); isa_ok($source_a, 'DBIx::Class::ResultSource::Table'); diff --git a/t/39load_namespaces_3.t b/t/39load_namespaces_3.t index c1df868..99ad8a9 100644 --- a/t/39load_namespaces_3.t +++ b/t/39load_namespaces_3.t @@ -16,7 +16,7 @@ lives_ok (sub { resultset_namespace => '+DBICNSTest::RSet', ); }, - qr/load_namespaces found ResultSet class C with no corresponding Result class/, + qr/load_namespaces found ResultSet class 'DBICNSTest::RSet::C' with no corresponding Result class/, ); }); diff --git a/t/39load_namespaces_4.t b/t/39load_namespaces_4.t index 7d9725e..1bdc49d 100644 --- a/t/39load_namespaces_4.t +++ b/t/39load_namespaces_4.t @@ -15,7 +15,7 @@ eval { __PACKAGE__->load_namespaces( default_resultset_class => 'RSBase' ); }; ok(!$@) or diag $@; -like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/); +like($warnings, qr/load_namespaces found ResultSet class 'DBICNSTest::ResultSet::C' with no corresponding Result class/); my $source_a = DBICNSTest->source('A'); isa_ok($source_a, 'DBIx::Class::ResultSource::Table'); diff --git a/t/39load_namespaces_rt41083.t b/t/39load_namespaces_rt41083.t index 79c9c7a..2584290 100644 --- a/t/39load_namespaces_rt41083.t +++ b/t/39load_namespaces_rt41083.t @@ -32,7 +32,7 @@ sub _verify_sources { package DBICNSTest::RtBug41083; use base 'DBIx::Class::Schema'; __PACKAGE__->load_namespaces( - result_namespace => 'Schema_A', + result_namespace => 'Result_A', resultset_namespace => 'ResultSet_A', default_resultset_class => 'ResultSet' ); @@ -52,8 +52,6 @@ sub _verify_sources { package DBICNSTest::RtBug41083; use base 'DBIx::Class::Schema'; __PACKAGE__->load_namespaces( - result_namespace => 'Schema', - resultset_namespace => 'ResultSet', default_resultset_class => 'ResultSet' ); }; diff --git a/t/51threadnodb.t b/t/51threadnodb.t index 9b69fa1..95c9aaf 100644 --- a/t/51threadnodb.t +++ b/t/51threadnodb.t @@ -4,6 +4,11 @@ BEGIN { 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; diff --git a/t/51threads.t b/t/51threads.t index 6dc0d11..382458d 100644 --- a/t/51threads.t +++ b/t/51threads.t @@ -4,6 +4,11 @@ BEGIN { 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; diff --git a/t/51threadtxn.t b/t/51threadtxn.t index 4ab96fb..a0e07bd 100644 --- a/t/51threadtxn.t +++ b/t/51threadtxn.t @@ -7,6 +7,11 @@ BEGIN { 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; diff --git a/t/52leaks.t b/t/52leaks.t index 4923be0..c566a9a 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -47,9 +47,10 @@ if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) { use lib qw(t/lib); use DBICTest::RunMode; -use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; -use Scalar::Util 'refaddr'; +use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs); +use Scalar::Util qw(weaken blessed reftype); use DBIx::Class; +use DBIx::Class::_Util qw(hrefaddr sigwarn_silencer); BEGIN { plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test" if DBIx::Class::_ENV_::PEEPEENESS; @@ -88,7 +89,7 @@ unless (DBICTest::RunMode->is_plain) { # re-populate the registry while checking it, ewwww!) return $obj if (ref $obj) =~ /^TB2::/; - # weaken immediately to avoid weird side effects + # populate immediately to avoid weird side effects return populate_weakregistry ($weak_registry, $obj ); }; @@ -214,9 +215,6 @@ unless (DBICTest::RunMode->is_plain) { my $getcol_rs = $cds_rs->get_column('me.cdid'); my $pref_getcol_rs = $cds_with_stuff->get_column('me.cdid'); - # fire the column getters - my @throwaway = $pref_getcol_rs->all; - my $base_collection = { resultset => $rs, @@ -239,8 +237,8 @@ unless (DBICTest::RunMode->is_plain) { get_column_rs_pref => $pref_getcol_rs, # twice so that we make sure only one H::M object spawned - chained_resultset => $rs->search_rs ({}, { '+columns' => [ 'foo' ] } ), - chained_resultset2 => $rs->search_rs ({}, { '+columns' => [ 'bar' ] } ), + chained_resultset => $rs->search_rs ({}, { '+columns' => { foo => 'artistid' } } ), + chained_resultset2 => $rs->search_rs ({}, { '+columns' => { bar => 'artistid' } } ), row_object => $row_obj, @@ -256,11 +254,40 @@ unless (DBICTest::RunMode->is_plain) { leaky_resultset_cond => $cond_rowobj, }; - # this needs to fire, even if it can't find anything - # see FIXME below - # we run this only on smokers - trying to establish a pattern - $rs_bind_circref->next - if ( ($ENV{TRAVIS}||'') ne 'true' and DBICTest::RunMode->is_smoker); + # fire all resultsets multiple times, once here, more below + # some of these can't find anything (notably leaky_resultset) + my @rsets = grep { + blessed $_ + and + ( + $_->isa('DBIx::Class::ResultSet') + or + $_->isa('DBIx::Class::ResultSetColumn') + ) + } values %$base_collection; + + + my $fire_resultsets = sub { + local $ENV{DBIC_COLUMNS_INCLUDE_FILTER_RELS} = 1; + local $SIG{__WARN__} = sigwarn_silencer( + qr/Unable to deflate 'filter'-type relationship 'artist'.+related object primary key not retrieved/ + ); + + map + { $_, (blessed($_) ? { $_->get_columns } : ()) } + map + { $_->all } + @rsets + ; + }; + + push @{$base_collection->{random_results}}, $fire_resultsets->(); + + # FIXME - something throws a Storable for a spin if we keep + # the results in-collection. The same problem is seen above, + # swept under the rug back in 0a03206a, damned lazy ribantainer +{ + local $base_collection->{random_results}; require Storable; %$base_collection = ( @@ -275,6 +302,87 @@ unless (DBICTest::RunMode->is_plain) { fresh_pager => $rs->page(5)->pager, pager => $pager, ); +} + + # FIXME - ideally this kind of collector ought to be global, but attempts + # with an invasive debugger-based tracer did not quite work out... yet + # Manually scan the innards of everything we have in the base collection + # we assembled so far (skip the DT madness below) *recursively* + # + # Only do this when we do have the bits to look inside CVs properly, + # without it we are liable to pick up object defaults that are locked + # in method closures + if (DBICTest::Util::LeakTracer::CV_TRACING) { + visit_refs( + refs => [ $base_collection ], + action => sub { + populate_weakregistry ($weak_registry, $_[0]); + 1; # true means "keep descending" + }, + ); + + # do a heavy-duty fire-and-compare loop on all resultsets + # this is expensive - not running on install + my $typecounts = {}; + if ( + ! DBICTest::RunMode->is_plain + and + ! $ENV{DBICTEST_IN_PERSISTENT_ENV} + and + # FIXME - investigate wtf is going on with 5.18 + ! ( $] > 5.017 and $ENV{DBIC_TRACE_PROFILE} ) + ) { + + # FIXME - ideally we should be able to just populate an alternative + # registry, subtract everything from the main one, and arrive at + # an "empty" resulting hash + # However due to gross inefficiencies in the ::ResultSet code we + # end up recalculating a new set of aliasmaps which could have very + # well been cached if it wasn't for... anyhow + # What we do here for the time being is similar to the lazy approach + # of Devel::LeakTrace - we just make sure we do not end up with more + # reftypes than when we started. At least we are not blanket-counting + # SVs like D::LT does, but going by reftype... sigh... + + for (values %$weak_registry) { + if ( my $r = reftype($_->{weakref}) ) { + $typecounts->{$r}--; + } + } + + # For now we can only reuse the same registry, see FIXME above/below + #for my $interim_wr ({}, {}) { + for my $interim_wr ( ($weak_registry) x 4 ) { + + visit_refs( + refs => [ $fire_resultsets->(), @rsets ], + action => sub { + populate_weakregistry ($interim_wr, $_[0]); + 1; # true means "keep descending" + }, + ); + + # FIXME - this is what *should* be here + # + ## anything we have seen so far is cool + #delete @{$interim_wr}{keys %$weak_registry}; + # + ## moment of truth - the rest ought to be gone + #assert_empty_weakregistry($interim_wr); + } + + for (values %$weak_registry) { + if ( my $r = reftype($_->{weakref}) ) { + $typecounts->{$r}++; + } + } + } + + for (keys %$typecounts) { + fail ("Amount of $_ refs changed by $typecounts->{$_} during resultset mass-execution") + if ( abs ($typecounts->{$_}) > 1 ); # there is a pad caught somewhere, the +1/-1 can be ignored + } + } if ($has_dt) { my $rs = $base_collection->{icdt_rs} = $schema->resultset('Event'); @@ -296,23 +404,6 @@ unless (DBICTest::RunMode->is_plain) { $base_collection->{"DBI handle $_"} = $_; } - SKIP: { - if ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks') ) { - my @w; - local $SIG{__WARN__} = sub { $_[0] =~ /\QUnhandled type: REGEXP/ ? push @w, @_ : warn @_ }; - - Test::Memory::Cycle::memory_cycle_ok ($base_collection, 'No cycles in the object collection'); - - if ( $] > 5.011 ) { - local $TODO = 'Silence warning due to RT56681'; - is (@w, 0, 'No Devel::Cycle emitted warnings'); - } - } - else { - skip 'Circular ref test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_leaks'), 1; - } - } - populate_weakregistry ($weak_registry, $base_collection->{$_}, "basic $_") for keys %$base_collection; } @@ -355,46 +446,69 @@ unless (DBICTest::RunMode->is_plain) { # Naturally we have some exceptions my $cleared; -for my $slot (keys %$weak_registry) { - if ($slot =~ /^Test::Builder/) { +for my $addr (keys %$weak_registry) { + my $names = join "\n", keys %{$weak_registry->{$addr}{slot_names}}; + + if ($names =~ /^Test::Builder/m) { # T::B 2.0 has result objects and other fancyness - delete $weak_registry->{$slot}; + delete $weak_registry->{$addr}; } - elsif ($slot =~ /^Method::Generate::(?:Accessor|Constructor)/) { - # Moo keeps globals around, this is normal - delete $weak_registry->{$slot}; + elsif ($names =~ /^Hash::Merge/m) { + # only clear one object of a specific behavior - more would indicate trouble + delete $weak_registry->{$addr} + unless $cleared->{hash_merge_singleton}{$weak_registry->{$addr}{weakref}{behavior}}++; } - elsif ($slot =~ /^SQL::Translator::Generator::DDL::SQLite/) { + elsif ( +# # if we can look at closed over pieces - we will register it as a global +# !DBICTest::Util::LeakTracer::CV_TRACING +# and + $names =~ /^SQL::Translator::Generator::DDL::SQLite/m + ) { # SQLT::Producer::SQLite keeps global generators around for quoted # and non-quoted DDL, allow one for each quoting style - delete $weak_registry->{$slot} - unless $cleared->{sqlt_ddl_sqlite}->{@{$weak_registry->{$slot}{weakref}->quote_chars}}++; - } - elsif ($slot =~ /^Hash::Merge/) { - # only clear one object of a specific behavior - more would indicate trouble - delete $weak_registry->{$slot} - unless $cleared->{hash_merge_singleton}{$weak_registry->{$slot}{weakref}{behavior}}++; - } - elsif ($slot =~ /^DateTime::TimeZone/) { - # DT is going through a refactor it seems - let it leak zones for now - delete $weak_registry->{$slot}; + delete $weak_registry->{$addr} + unless $cleared->{sqlt_ddl_sqlite}->{@{$weak_registry->{$addr}{weakref}->quote_chars}}++; } } # FIXME !!! # There is an actual strong circular reference taking place here, but because -# half of it is in XS no leaktracer sees it, and Devel::FindRef is equally -# stumped when trying to trace the origin. The problem is: +# half of it is in XS, so it is a bit harder to track down (it stumps D::FR) +# (our tracker does not yet do it, but it'd be nice) +# The problem is: # # $cond_object --> result_source --> schema --> storage --> $dbh --> {CachedKids} # ^ / # \-------- bound value on prepared/cached STH <-----------/ # { - local $TODO = 'This fails intermittently - see RT#82942'; - if ( my $r = $weak_registry->{'basic leaky_resultset_cond'}{weakref} ) { + my @circreffed; + + for my $r (map + { $_->{weakref} } + grep + { $_->{slot_names}{'basic leaky_resultset_cond'} } + values %$weak_registry + ) { + local $TODO = 'Needs Data::Entangled or somesuch - see RT#82942'; ok(! defined $r, 'Self-referential RS conditions no longer leak!') - or $r->result_source(undef); + or push @circreffed, $r; + } + + if (@circreffed) { + is (scalar @circreffed, 1, 'One resultset expected to leak'); + + # this is useless on its own, it is to showcase the circref-diag + # and eventually test it when it is operational + local $TODO = 'Needs Data::Entangled or somesuch - see RT#82942'; + while (@circreffed) { + weaken (my $r = shift @circreffed); + + populate_weakregistry( (my $mini_registry = {}), $r ); + assert_empty_weakregistry( $mini_registry ); + + $r->result_source(undef); + } } } diff --git a/t/54taint.t b/t/54taint.t index 2a37ed5..7f0db9a 100644 --- a/t/54taint.t +++ b/t/54taint.t @@ -1,21 +1,54 @@ -#!/usr/bin/env perl -T - -# the above line forces Test::Harness into taint-mode -# DO NOT REMOVE - 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'}) { + + # it is possible the test itself is initially invoked in taint mode + # and with relative paths *and* with a relative $^X and some other + # craziness... in short: just be proactive + require File::Spec; + + if (length $ENV{PATH}) { + ( $ENV{PATH} ) = join ( $Config{path_sep}, + map { length($_) ? File::Spec->rel2abs($_) : () } + split /\Q$Config{path_sep}/, $ENV{PATH} + ) =~ /\A(.+)\z/; + } + + my ($perl) = $^X =~ /\A(.+)\z/; + + { + local $ENV{PATH} = "/nosuchrootbindir"; + system( $perl => -T => -e => ' + use warnings; + use strict; + eval { my $x = $ENV{PATH} . (kill (0)); 1 } or exit 42; + exit 0; + '); + } + + if ( ($? >> 8) != 42 ) { + print "1..0 # SKIP Your perl does not seem to like/support -T...\n"; + exit 0; + } + + exec( $perl, qw( -I. -Mt::lib::DBICTest::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 Config; -BEGIN { - for (map { defined $ENV{$_} ? $ENV{$_} : () } (qw/PERLLIB PERL5LIB/) ) { # we unshift, so reverse precedence - my ($envvar) = ($_ =~ /^(.+)$/); # untaint - unshift @INC, map { length($_) ? $_ : () } (split /\Q$Config{path_sep}\E/, $envvar); - } -} +# 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 @@ -23,8 +56,7 @@ BEGIN { # In some cases, prove will have supplied ./lib as an absolute path so it # doesn't seem worth trying to remove the second copy since it won't hurt # anything. -use lib qw(lib); -use lib qw(t/lib); +use lib qw(t/lib lib); use Test::More; use Test::Exception; @@ -34,7 +66,7 @@ throws_ok ( sub { $ENV{PATH} . (kill (0)) }, qr/Insecure dependency in kill/, 'taint mode active' -); +) if length $ENV{PATH}; { package DBICTest::Taint::Classes; @@ -71,4 +103,13 @@ throws_ok ( }, 'Loading classes with Module::Find/load_namespaces worked in taint mode' ); } +# check that we can create a database and all +{ + my $s = DBICTest->init_schema( sqlite_use_file => 1 ); + my $art = $s->resultset('Artist')->search({}, { + prefetch => 'cds', order_by => 'artistid', + })->next; + is ($art->artistid, 1, 'got artist'); +} + done_testing; diff --git a/t/71mysql.t b/t/71mysql.t index 5af59cb..e1e68ee 100644 --- a/t/71mysql.t +++ b/t/71mysql.t @@ -3,6 +3,7 @@ use warnings; use Test::More; use Test::Exception; +use Test::Warn; use DBI::Const::GetInfoType; use Scalar::Util qw/weaken/; @@ -198,22 +199,6 @@ lives_ok { $cd->set_producers ([ $producer ]) } 'set_relationship doesnt die'; my $cd = $rs->next; is ($cd->artist->name, $artist->name, 'Prefetched artist'); }, 'join does not throw (mysql 3 test)'; - - # induce a jointype override, make sure it works even if we don't have mysql3 - my $needs_inner_join = $schema->storage->sql_maker->needs_inner_join; - $schema->storage->sql_maker->needs_inner_join(1); - is_same_sql_bind ( - $rs->as_query, - '( - SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year`, `me`.`genreid`, `me`.`single_track`, - `artist`.`artistid`, `artist`.`name`, `artist`.`rank`, `artist`.`charfield` - FROM cd `me` - INNER JOIN `artist` `artist` ON `artist`.`artistid` = `me`.`artist` - )', - [], - 'overridden default join type works', - ); - $schema->storage->sql_maker->needs_inner_join($needs_inner_join); } ## Can we properly deal with the null search problem? @@ -349,16 +334,22 @@ ZEROINSEARCH: { select => [ \ 'YEAR(year)' ], as => ['y'], distinct => 1, }); - is_deeply ( - [ sort ($rs->get_column ('y')->all) ], + my $y_rs = $rs->get_column ('y'); + + warnings_exist { is_deeply ( + [ sort ($y_rs->all) ], [ sort keys %$cds_per_year ], 'Years group successfully', - ); + ) } qr/ + \QUse of distinct => 1 while selecting anything other than a column \E + \Qdeclared on the primary ResultSource is deprecated\E + /x, 'deprecation warning'; + $rs->create ({ artist => 1, year => '0-1-1', title => 'Jesus Rap' }); is_deeply ( - [ sort $rs->get_column ('y')->all ], + [ sort $y_rs->all ], [ 0, sort keys %$cds_per_year ], 'Zero-year groups successfully', ); @@ -369,11 +360,14 @@ ZEROINSEARCH: { year => { '!=', undef } ]}); - is_deeply ( + warnings_exist { is_deeply ( [ $restrict_rs->get_column('y')->all ], - [ $rs->get_column ('y')->all ], + [ $y_rs->all ], 'Zero year was correctly excluded from resultset', - ); + ) } qr/ + \QUse of distinct => 1 while selecting anything other than a column \E + \Qdeclared on the primary ResultSource is deprecated\E + /x, 'deprecation warning'; } # make sure find hooks determine driver diff --git a/t/73oracle.t b/t/73oracle.t index fc324c5..40dcaac 100644 --- a/t/73oracle.t +++ b/t/73oracle.t @@ -488,7 +488,7 @@ sub _run_tests { # create identically named tables/sequences in the other schema do_creates($dbh2, $q); - # grand select privileges to the 2nd user + # grant select privileges to the 2nd user $dbh->do("GRANT INSERT ON ${q}artist${q} TO " . uc $user2); $dbh->do("GRANT SELECT ON ${q}artist${q} TO " . uc $user2); $dbh->do("GRANT SELECT ON ${q}artist_pk_seq${q} TO " . uc $user2); @@ -551,6 +551,26 @@ sub _run_tests { do_clean ($dbh2); }} +# test driver determination issues that led to the diagnosis/fix in 37b5ab51 +# observed side-effect when count-is-first on a fresh env-based connect + { + local $ENV{DBI_DSN}; + ($ENV{DBI_DSN}, my @user_pass_args) = @{ $schema->storage->connect_info }; + my $s2 = DBICTest::Schema->connect( undef, @user_pass_args ); + ok (! $s2->storage->connected, 'Not connected' ); + is (ref $s2->storage, 'DBIx::Class::Storage::DBI', 'Undetermined driver' ); + + ok ( + $s2->resultset('Artist')->search({ 'me.name' => { like => '%' } }, { prefetch => 'cds' })->count, + 'Some artist count' + ); + ok ( + scalar $s2->resultset('CD')->search({}, { join => 'tracks' } )->all, + 'Some cds returned' + ); + $s2->storage->disconnect; + } + do_clean ($dbh); } diff --git a/t/73oracle_hq.t b/t/73oracle_hq.t index c09cbfd..0f887fa 100644 --- a/t/73oracle_hq.t +++ b/t/73oracle_hq.t @@ -36,11 +36,6 @@ BEGIN { use DBICTest; use DBICTest::Schema; -use DBIC::SqlMakerTest; - -use DBIx::Class::SQLMaker::LimitDialects; -my $ROWS = DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype, -my $TOTAL = DBIx::Class::SQLMaker::LimitDialects->__total_bindtype, my $schema = DBICTest::Schema->connect($dsn, $user, $pass); @@ -114,35 +109,12 @@ do_creates($dbh); connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, }); - is_same_sql_bind ( - $rs->as_query, - '( - SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid - FROM artist me - START WITH name = ? - CONNECT BY parentid = PRIOR artistid - )', - [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } - => 'root'] ], - ); is_deeply ( [ $rs->get_column ('name')->all ], [ qw/root child1 grandchild greatgrandchild child2/ ], 'got artist tree', ); - is_same_sql_bind ( - $rs->count_rs->as_query, - '( - SELECT COUNT( * ) - FROM artist me - START WITH name = ? - CONNECT BY parentid = PRIOR artistid - )', - [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } - => 'root'] ], - ); - is( $rs->count, 5, 'Connect By count ok' ); } @@ -158,19 +130,6 @@ do_creates($dbh); order_siblings_by => { -desc => 'name' }, }); - is_same_sql_bind ( - $rs->as_query, - '( - SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid - FROM artist me - START WITH name = ? - CONNECT BY parentid = PRIOR artistid - ORDER SIBLINGS BY name DESC - )', - [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } - => 'root'] ], - ); - is_deeply ( [ $rs->get_column ('name')->all ], [ qw/root child2 child1 grandchild greatgrandchild/ ], @@ -185,19 +144,6 @@ do_creates($dbh); connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, }); - is_same_sql_bind ( - $rs->as_query, - '( - SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid - FROM artist me - WHERE ( parentid IS NULL ) - START WITH name = ? - CONNECT BY parentid = PRIOR artistid - )', - [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } - => 'root'] ], - ); - is_deeply( [ $rs->get_column('name')->all ], [ 'root' ], @@ -220,48 +166,12 @@ do_creates($dbh); } ); - is_same_sql_bind ( - $rs->as_query, - '( - SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid - FROM artist me - LEFT JOIN cd cds ON cds.artist = me.artistid - WHERE ( cds.title LIKE ? ) - START WITH me.name = ? - CONNECT BY parentid = PRIOR artistid - )', - [ - [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'cds.title', 'sqlt_size' => 100 } - => '%cd'], - [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'me.name', 'sqlt_size' => 100 } - => 'root'], - ], - ); - is_deeply( [ $rs->get_column('name')->all ], [ 'grandchild' ], 'Connect By with a join result name ok' ); - is_same_sql_bind ( - $rs->count_rs->as_query, - '( - SELECT COUNT( * ) - FROM artist me - LEFT JOIN cd cds ON cds.artist = me.artistid - WHERE ( cds.title LIKE ? ) - START WITH me.name = ? - CONNECT BY parentid = PRIOR artistid - )', - [ - [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'cds.title', 'sqlt_size' => 100 } - => '%cd'], - [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'me.name', 'sqlt_size' => 100 } - => 'root'], - ], - ); - is( $rs->count, 1, 'Connect By with a join; count ok' ); } @@ -273,22 +183,6 @@ do_creates($dbh); order_by => { -asc => [ 'LEVEL', 'name' ] }, }); - is_same_sql_bind ( - $rs->as_query, - '( - SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid - FROM artist me - START WITH name = ? - CONNECT BY parentid = PRIOR artistid - ORDER BY LEVEL ASC, name ASC - )', - [ - [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } - => 'root'], - ], - ); - - # Don't use "$rs->get_column ('name')->all" they build a query arround the $rs. # If $rs has a order by, the order by is in the subquery and this doesn't work with Oracle 8i. # TODO: write extra test and fix order by handling on Oracle 8i @@ -322,53 +216,12 @@ do_creates($dbh); rows => 2, }); - is_same_sql_bind ( - $rs->as_query, - '( - SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid - FROM ( - SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid - FROM artist me - START WITH name = ? - CONNECT BY parentid = PRIOR artistid - ORDER BY name ASC, artistid DESC - ) me - WHERE ROWNUM <= ? - )', - [ - [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } - => 'root'], [ $ROWS => 2 ], - ], - ); - is_deeply ( [ $rs->get_column ('name')->all ], [qw/child1 child2/], 'LIMIT a Connect By query - correct names' ); - is_same_sql_bind ( - $rs->count_rs->as_query, - '( - SELECT COUNT( * ) - FROM ( - SELECT me.artistid - FROM ( - SELECT me.artistid - FROM artist me - START WITH name = ? - CONNECT BY parentid = PRIOR artistid - ) me - WHERE ROWNUM <= ? - ) me - )', - [ - [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } - => 'root'], - [ $ROWS => 2 ], - ], - ); - is( $rs->count, 2, 'Connect By; LIMIT count ok' ); } @@ -384,27 +237,6 @@ do_creates($dbh); having => \[ 'count(rank) < ?', [ cnt => 2 ] ], }); - is_same_sql_bind ( - $rs->as_query, - '( - SELECT COUNT(rank) + ? - FROM artist me - START WITH name = ? - CONNECT BY parentid = PRIOR artistid - GROUP BY( rank + ? ) HAVING count(rank) < ? - )', - [ - [ { dbic_colname => '__cbind' } - => 3 ], - [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } - => 'root'], - [ { dbic_colname => '__gbind' } - => 1 ], - [ { dbic_colname => 'cnt' } - => 2 ], - ], - ); - is_deeply ( [ $rs->get_column ('cnt')->all ], [4, 4], @@ -437,19 +269,6 @@ do_creates($dbh); connect_by_nocycle => { parentid => { -prior => { -ident => 'artistid' } } }, }); - is_same_sql_bind ( - $rs->as_query, - '( - SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid, CONNECT_BY_ISCYCLE - FROM artist me - START WITH name = ? - CONNECT BY NOCYCLE parentid = PRIOR artistid - )', - [ - [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } - => 'cycle-root'], - ], - ); is_deeply ( [ $rs->get_column ('name')->all ], [ qw/cycle-root cycle-child1 cycle-grandchild cycle-child2/ ], @@ -461,20 +280,6 @@ do_creates($dbh); 'got artist tree with nocycle (CONNECT_BY_ISCYCLE)', ); - is_same_sql_bind ( - $rs->count_rs->as_query, - '( - SELECT COUNT( * ) - FROM artist me - START WITH name = ? - CONNECT BY NOCYCLE parentid = PRIOR artistid - )', - [ - [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } - => 'cycle-root'], - ], - ); - is( $rs->count, 4, 'Connect By Nocycle count ok' ); } } diff --git a/t/746mssql.t b/t/746mssql.t index 57c44fb..2cc0281 100644 --- a/t/746mssql.t +++ b/t/746mssql.t @@ -11,11 +11,6 @@ plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missin use lib qw(t/lib); use DBICTest; -use DBIC::SqlMakerTest; -use DBIx::Class::SQLMaker::LimitDialects; - -my $OFFSET = DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype; -my $TOTAL = DBIx::Class::SQLMaker::LimitDialects->__total_bindtype; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/}; @@ -373,77 +368,6 @@ SQL }, ); - is_same_sql_bind ( - $owners->page(3)->as_query, - $dialect eq 'Top' - ? '( - SELECT TOP 2147483647 [me].[id], [me].[name], - [books].[id], [books].[source], [books].[owner], [books].[title], [books].[price] - FROM ( - SELECT TOP 2147483647 [me].[id], [me].[name] - FROM ( - SELECT TOP 3 [me].[id], [me].[name], [ORDER__BY__001] - FROM ( - SELECT TOP 9 [me].[id], [me].[name], name + ? AS [ORDER__BY__001] - FROM [owners] [me] - LEFT JOIN [books] [books] - ON [books].[owner] = [me].[id] - WHERE [books].[id] IS NOT NULL AND [me].[name] != ? - GROUP BY [me].[id], [me].[name] - ORDER BY name + ? ASC, [me].[id] - ) [me] - ORDER BY [ORDER__BY__001] DESC, [me].[id] DESC - ) [me] - ORDER BY [ORDER__BY__001] ASC, [me].[id] - ) [me] - LEFT JOIN [books] [books] - ON [books].[owner] = [me].[id] - WHERE [books].[id] IS NOT NULL AND [me].[name] != ? - ORDER BY name + ? ASC, [me].[id] - )' - : '( - SELECT TOP 2147483647 [me].[id], [me].[name], - [books].[id], [books].[source], [books].[owner], [books].[title], [books].[price] - FROM ( - SELECT TOP 2147483647 [me].[id], [me].[name] - FROM ( - SELECT [me].[id], [me].[name], - ROW_NUMBER() OVER( ORDER BY [ORDER__BY__001] ASC, [me].[id] ) AS [rno__row__index] - FROM ( - SELECT [me].[id], [me].[name], name + ? AS [ORDER__BY__001] - FROM [owners] [me] - LEFT JOIN [books] [books] - ON [books].[owner] = [me].[id] - WHERE [books].[id] IS NOT NULL AND [me].[name] != ? - GROUP BY [me].[id], [me].[name] - ) [me] - ) [me] - WHERE [rno__row__index] >= ? AND [rno__row__index] <= ? - ) [me] - LEFT JOIN [books] [books] - ON [books].[owner] = [me].[id] - WHERE [books].[id] IS NOT NULL AND [me].[name] != ? - ORDER BY name + ? ASC, [me].[id] - )' - , - [ - [ { dbic_colname => 'test' } - => 'xxx' ], - [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.name' } - => 'somebogusstring' ], - - ($dialect eq 'Top' - ? [ { dbic_colname => 'test' } => 'xxx' ] # the extra re-order bind - : ([ $OFFSET => 7 ], [ $TOTAL => 9 ]) # parameterised RNO - ), - - [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.name' } - => 'somebogusstring' ], - [ { dbic_colname => 'test' } - => 'xxx' ], - ], - ) if $quoted; - is ($owners->page(1)->all, 3, "$test_type: has_many prefetch returns correct number of rows"); is ($owners->page(1)->count, 3, "$test_type: has-many prefetch returns correct count"); @@ -471,88 +395,6 @@ SQL }, ); - is_same_sql_bind ( - $books->page(3)->as_query, - $dialect eq 'Top' - ? '( - SELECT TOP 2147483647 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], - [owner].[id], [owner].[name] - FROM ( - SELECT TOP 2147483647 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] - FROM ( - SELECT TOP 2 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] - FROM ( - SELECT TOP 6 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] - FROM [books] [me] - JOIN [owners] [owner] - ON [owner].[id] = [me].[owner] - WHERE ( [owner].[name] = ? OR [owner].[name] = ? ) AND [source] = ? - GROUP BY [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] - HAVING 1 = ? - ORDER BY [me].[owner] DESC, [me].[id] - ) [me] - ORDER BY [me].[owner] ASC, [me].[id] DESC - ) [me] - ORDER BY [me].[owner] DESC, [me].[id] - ) [me] - JOIN [owners] [owner] - ON [owner].[id] = [me].[owner] - WHERE ( [owner].[name] = ? OR [owner].[name] = ? ) AND [source] = ? - ORDER BY [me].[owner] DESC, [me].[id] - )' - : '( - SELECT TOP 2147483647 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], - [owner].[id], [owner].[name] - FROM ( - SELECT TOP 2147483647 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] - FROM ( - SELECT [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], - ROW_NUMBER() OVER( ORDER BY [me].[owner] DESC, [me].[id] ) AS [rno__row__index] - FROM ( - SELECT [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] - FROM [books] [me] - JOIN [owners] [owner] - ON [owner].[id] = [me].[owner] - WHERE ( [owner].[name] = ? OR [owner].[name] = ? ) AND [source] = ? - GROUP BY [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] - HAVING 1 = ? - ) [me] - ) [me] - WHERE [rno__row__index] >= ? AND [rno__row__index] <= ? - ) [me] - JOIN [owners] [owner] - ON [owner].[id] = [me].[owner] - WHERE ( [owner].[name] = ? OR [owner].[name] = ? ) AND [source] = ? - ORDER BY [me].[owner] DESC, [me].[id] - )' - , - [ - # inner - [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } - => 'wiggle' ], - [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } - => 'woggle' ], - [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } - => 'Library' ], - [ { dbic_colname => 'test' } - => '1' ], - - # top(?) - $dialect eq 'Top' - ? () - : ( [ $OFFSET => 5 ], [ $TOTAL => 6 ] ) - , - - # outer - [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } - => 'wiggle' ], - [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } - => 'woggle' ], - [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } - => 'Library' ], - ], - ) if $quoted; - is ($books->page(1)->all, 2, "$test_type: Prefetched grouped search returns correct number of rows"); is ($books->page(1)->count, 2, "$test_type: Prefetched grouped search returns correct count"); diff --git a/t/74mssql.t b/t/74mssql.t index 243ae0e..263fecb 100644 --- a/t/74mssql.t +++ b/t/74mssql.t @@ -1,13 +1,6 @@ use strict; use warnings; -# use this if you keep a copy of DBD::Sybase linked to FreeTDS somewhere else -BEGIN { - if (my $lib_dirs = $ENV{DBICTEST_MSSQL_PERL5LIB}) { - unshift @INC, $_ for split /:/, $lib_dirs; - } -} - use Test::More; use Test::Exception; use Scalar::Util 'weaken'; diff --git a/t/751msaccess.t b/t/751msaccess.t index 48ff756..8d8aa7e 100644 --- a/t/751msaccess.t +++ b/t/751msaccess.t @@ -164,6 +164,8 @@ EOF s/^'//, s/'\z// for @bind; + # test is duplicated in t/sqlmaker/msaccess.t, keep a duplicate here anyway, just to be safe + # -- ribasushi is_same_sql_bind( $sql, \@bind, @@ -195,6 +197,8 @@ EOF s/^'//, s/'\z// for @bind; + # test is duplicated in t/sqlmaker/msaccess.t, keep a duplicate here anyway, just to be safe + # -- ribasushi is_same_sql_bind( $sql, \@bind, diff --git a/t/84serialize.t b/t/84serialize.t index 34e2195..ffe0368 100644 --- a/t/84serialize.t +++ b/t/84serialize.t @@ -67,7 +67,8 @@ if ($ENV{DBICTEST_MEMCACHED}) { my $key = 'tmp_dbic_84serialize_memcached_test'; $stores{memcached} = sub { - $memcached->set( $key, $_[0], 60 ); + $memcached->set( $key, $_[0], 60 ) + or die "Unable to insert into $ENV{DBICTEST_MEMCACHED} - is server running?"; local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema; return $memcached->get($key); }; diff --git a/t/88result_set_column.t b/t/88result_set_column.t index cc6f68b..b1c1e96 100644 --- a/t/88result_set_column.t +++ b/t/88result_set_column.t @@ -277,7 +277,7 @@ is_same_sql_bind ( # would silently drop the group_by entirely, likely ending up with nonsensival results # With the current behavior the user will at least get a nice fat exception from the # RDBMS (or maybe the RDBMS will even decide to handle the situation sensibly...) - is_same_sql_bind( + warnings_exist { is_same_sql_bind( $rstypes->{'implicitly grouped'}->get_column('cnt')->as_query, '( SELECT COUNT( me.cdid ) @@ -294,7 +294,10 @@ is_same_sql_bind ( => 'evancarrol' ] ], 'Expected (though nonsensical) SQL generated on rscol-with-distinct-over-function', - ); + ) } qr/ + \QUse of distinct => 1 while selecting anything other than a column \E + \Qdeclared on the primary ResultSource is deprecated\E + /x, 'deprecation warning'; { local $TODO = 'multiplying join leaks through to the count aggregate... this may never actually work'; diff --git a/t/inflate/datetime_mssql.t b/t/inflate/datetime_mssql.t index ae97a46..edbac14 100644 --- a/t/inflate/datetime_mssql.t +++ b/t/inflate/datetime_mssql.t @@ -29,13 +29,6 @@ plan skip_all => 'Test needs ' . $dsn3 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_mssql_ado')) or (not $dsn || $dsn2 || $dsn3); -# use this if you keep a copy of DBD::Sybase linked to FreeTDS somewhere else -BEGIN { - if (my $lib_dirs = $ENV{DBICTEST_MSSQL_PERL5LIB}) { - unshift @INC, $_ for split /:/, $lib_dirs; - } -} - if (not ($dsn || $dsn2 || $dsn3)) { plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ODBC_DSN} and/or $ENV{DBICTEST_MSSQL_DSN} and/or ' diff --git a/t/inflate/hri.t b/t/inflate/hri.t index eece6df..b9ca3d8 100644 --- a/t/inflate/hri.t +++ b/t/inflate/hri.t @@ -2,6 +2,14 @@ use strict; use warnings; use Test::More; + +use DBIx::Class::_Util 'modver_gt_or_eq'; +use base(); +BEGIN { + plan skip_all => 'base.pm 2.20 (only present in perl 5.19.7) is known to break this test' + if modver_gt_or_eq(base => '2.19_01') and ! modver_gt_or_eq(base => '2.21'); +} + use Test::Exception; use lib qw(t/lib); use DBICTest; diff --git a/t/lib/DBICNSTest/RtBug41083/Schema/Foo.pm b/t/lib/DBICNSTest/RtBug41083/Result/Foo.pm similarity index 72% rename from t/lib/DBICNSTest/RtBug41083/Schema/Foo.pm rename to t/lib/DBICNSTest/RtBug41083/Result/Foo.pm index 4c98495..703e59c 100644 --- a/t/lib/DBICNSTest/RtBug41083/Schema/Foo.pm +++ b/t/lib/DBICNSTest/RtBug41083/Result/Foo.pm @@ -1,4 +1,4 @@ -package DBICNSTest::RtBug41083::Schema::Foo; +package DBICNSTest::RtBug41083::Result::Foo; use strict; use warnings; use base 'DBIx::Class::Core'; diff --git a/t/lib/DBICNSTest/RtBug41083/Result/Foo/Sub.pm b/t/lib/DBICNSTest/RtBug41083/Result/Foo/Sub.pm new file mode 100644 index 0000000..6d48de7 --- /dev/null +++ b/t/lib/DBICNSTest/RtBug41083/Result/Foo/Sub.pm @@ -0,0 +1,5 @@ +package DBICNSTest::RtBug41083::Result::Foo::Sub; +use strict; +use warnings; +use base 'DBICNSTest::RtBug41083::Result::Foo'; +1; diff --git a/t/lib/DBICNSTest/RtBug41083/Schema_A/A.pm b/t/lib/DBICNSTest/RtBug41083/Result_A/A.pm similarity index 71% rename from t/lib/DBICNSTest/RtBug41083/Schema_A/A.pm rename to t/lib/DBICNSTest/RtBug41083/Result_A/A.pm index 6a3995f..2494685 100644 --- a/t/lib/DBICNSTest/RtBug41083/Schema_A/A.pm +++ b/t/lib/DBICNSTest/RtBug41083/Result_A/A.pm @@ -1,4 +1,4 @@ -package DBICNSTest::RtBug41083::Schema_A::A; +package DBICNSTest::RtBug41083::Result_A::A; use strict; use warnings; use base 'DBIx::Class::Core'; diff --git a/t/lib/DBICNSTest/RtBug41083/Result_A/A/Sub.pm b/t/lib/DBICNSTest/RtBug41083/Result_A/A/Sub.pm new file mode 100644 index 0000000..dbb6ba0 --- /dev/null +++ b/t/lib/DBICNSTest/RtBug41083/Result_A/A/Sub.pm @@ -0,0 +1,5 @@ +package DBICNSTest::RtBug41083::Result_A::A::Sub; +use strict; +use warnings; +use base 'DBICNSTest::RtBug41083::Result_A::A'; +1; diff --git a/t/lib/DBICNSTest/RtBug41083/Schema/Foo/Sub.pm b/t/lib/DBICNSTest/RtBug41083/Schema/Foo/Sub.pm deleted file mode 100644 index 73ec679..0000000 --- a/t/lib/DBICNSTest/RtBug41083/Schema/Foo/Sub.pm +++ /dev/null @@ -1,5 +0,0 @@ -package DBICNSTest::RtBug41083::Schema::Foo::Sub; -use strict; -use warnings; -use base 'DBICNSTest::RtBug41083::Schema::Foo'; -1; diff --git a/t/lib/DBICNSTest/RtBug41083/Schema_A/A/Sub.pm b/t/lib/DBICNSTest/RtBug41083/Schema_A/A/Sub.pm deleted file mode 100644 index 1128e1e..0000000 --- a/t/lib/DBICNSTest/RtBug41083/Schema_A/A/Sub.pm +++ /dev/null @@ -1,5 +0,0 @@ -package DBICNSTest::RtBug41083::Schema_A::A::Sub; -use strict; -use warnings; -use base 'DBICNSTest::RtBug41083::Schema_A::A'; -1; diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index 8b72950..b0207a7 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -74,6 +74,7 @@ use Carp; use Path::Class::File (); use File::Spec; use Fcntl qw/:DEFAULT :flock/; +use Config; =head1 NAME @@ -124,25 +125,12 @@ our ($global_lock_fh, $global_exclusive_lock); sub import { my $self = shift; - my $tmpdir = DBICTest::RunMode->tmpdir; - my $lockpath = $tmpdir->file('.dbictest_global.lock'); + my $lockpath = DBICTest::RunMode->tmpdir->file('_dbictest_global.lock'); { my $u = local_umask(0); # so that the file opens as 666, and any user can lock - sysopen ($global_lock_fh, $lockpath, O_RDWR|O_CREAT) or do { - my $err = $!; - - my @x_tests = map { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' } map {(-e, -d, -f, -r, -w, -x, -o)} ($tmpdir, $lockpath); - - die sprintf <<"EOE", $lockpath, $err, scalar $>, scalar $), (stat($tmpdir))[4,5,2], @x_tests; -Unable to open %s: %s -Process EUID/EGID: %s / %s -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 - }; + sysopen ($global_lock_fh, $lockpath, O_RDWR|O_CREAT) + or die "Unable to open $lockpath: $!"; } for (@_) { @@ -244,18 +232,19 @@ sub _database { # this is executed on every connect, and thus installs a disconnect/DESTROY # guard for every new $dbh on_connect_do => sub { + my $storage = shift; my $dbh = $storage->_get_dbh; # no fsync on commit $dbh->do ('PRAGMA synchronous = OFF'); - if ($ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}) { - - $storage->throw_exception( - 'PRAGMA reverse_unordered_selects does not work correctly before libsqlite 3.7.9' - ) if $storage->_server_info->{normalized_dbms_version} < 3.007009; - + if ( + $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER} + and + # the pragma does not work correctly before libsqlite 3.7.9 + $storage->_server_info->{normalized_dbms_version} >= 3.007009 + ) { $dbh->do ('PRAGMA reverse_unordered_selects = ON'); } @@ -318,10 +307,16 @@ sub __mk_disconnect_guard { my $cur_inode = (stat($db_file))[1]; if ($orig_inode != $cur_inode) { - # pack/unpack to match the unsigned longs returned by `stat` - $fail_reason = sprintf 'was recreated (initially inode %s, now %s)', ( - map { unpack ('L', pack ('l', $_) ) } ($orig_inode, $cur_inode ) - ); + my @inodes = ($orig_inode, $cur_inode); + # unless this is a fixed perl (P5RT#84590) pack/unpack before display + # to match the unsigned longs returned by `stat` + @inodes = map { unpack ('L', pack ('l', $_) ) } @inodes + unless $Config{st_ino_size}; + + $fail_reason = sprintf + 'was recreated (initially inode %s, now %s)', + @inodes + ; } } diff --git a/t/lib/DBICTest/RunMode.pm b/t/lib/DBICTest/RunMode.pm index bdb569a..ab47d0c 100644 --- a/t/lib/DBICTest/RunMode.pm +++ b/t/lib/DBICTest/RunMode.pm @@ -16,7 +16,10 @@ BEGIN { } use Path::Class qw/file dir/; -use File::Spec; +use Fcntl ':DEFAULT'; +use File::Spec (); +use File::Temp (); +use DBICTest::Util 'local_umask'; _check_author_makefile() unless $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}; @@ -28,16 +31,58 @@ 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] eq '') { - # This means we were give the root dir (C:\ or something equally unacceptable) + 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 - $dir = _find_co_root()->subdir('t')->subdir('var'); - $dir->mkpath; + # 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; @@ -106,7 +151,7 @@ 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 dependenciess into +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 diff --git a/t/lib/DBICTest/Schema.pm b/t/lib/DBICTest/Schema.pm index 61a4386..b39ecbc 100644 --- a/t/lib/DBICTest/Schema.pm +++ b/t/lib/DBICTest/Schema.pm @@ -144,18 +144,6 @@ sub connection { ; }; - # DBD::Firebird and DBD::InterBase could very well talk to the same RDBMS - # make an educated guesstimate based on the DSN - # (worst case scenario we are wrong and the scripts have to wait on each - # other even without actually being able to interfere among themselves) - if ( - ($locktype||'') eq 'InterBase' - and - $_[0] =~ /firebird/i - ) { - $locktype = 'Firebird'; - } - # Never hold more than one lock. This solves the "lock in order" issues # unrelated tests may have # Also if there is no connection - there is no lock to be had @@ -165,7 +153,7 @@ sub connection { # which is fine since the type does not match as checked above undef $locker; - my $lockpath = DBICTest::RunMode->tmpdir->file(".dbictest_$locktype.lock"); + my $lockpath = DBICTest::RunMode->tmpdir->file("_dbictest_$locktype.lock"); #warn "$$ $0 $locktype GRABBING LOCK"; my $lock_fh; diff --git a/t/lib/DBICTest/Schema/Artist.pm b/t/lib/DBICTest/Schema/Artist.pm index 82423fd..79132fb 100644 --- a/t/lib/DBICTest/Schema/Artist.pm +++ b/t/lib/DBICTest/Schema/Artist.pm @@ -149,6 +149,21 @@ __PACKAGE__->has_many( ); __PACKAGE__->many_to_many('artworks', 'artwork_to_artist', 'artwork'); +__PACKAGE__->has_many( + cds_without_genre => 'DBICTest::Schema::CD', + sub { + my $args = shift; + return ( + { + "$args->{foreign_alias}.artist" => { -ident => "$args->{self_alias}.artistid" }, + "$args->{foreign_alias}.genreid" => undef, + }, $args->{self_rowobj} && { + "$args->{foreign_alias}.artist" => $args->{self_rowobj}->artistid, + "$args->{foreign_alias}.genreid" => undef, + } + ), + }, +); sub sqlt_deploy_hook { my ($self, $sqlt_table) = @_; diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index 2c10000..48ec21d 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -4,169 +4,334 @@ use warnings; use strict; use Carp; -use Scalar::Util qw/isweak weaken blessed reftype refaddr/; -use B 'svref_2object'; +use Scalar::Util qw(isweak weaken blessed reftype); +use DBIx::Class::_Util qw(refcount hrefaddr); +use DBIx::Class::Optional::Dependencies; +use Data::Dumper::Concise; use DBICTest::Util 'stacktrace'; +use constant { + CV_TRACING => DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'), + SKIP_SCALAR_REFS => ( $] > 5.017 ) ? 1 : 0, +}; use base 'Exporter'; -our @EXPORT_OK = qw/populate_weakregistry assert_empty_weakregistry/; +our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry visit_refs); my $refs_traced = 0; -my $leaks_found; +my $leaks_found = 0; my %reg_of_regs; +# so we don't trigger stringification +sub _describe_ref { + sprintf '%s%s(%s)', + (defined blessed $_[0]) ? blessed($_[0]) . '=' : '', + reftype $_[0], + hrefaddr $_[0], + ; +} + sub populate_weakregistry { - my ($weak_registry, $target, $slot) = @_; + my ($weak_registry, $target, $note) = @_; croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; croak 'Target is not a reference' unless length ref $target; - my $refaddr = refaddr $target; + my $refaddr = hrefaddr $target; - $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification - (defined blessed $target) ? blessed($target) . '=' : '', - reftype $target, - $refaddr, - ); + # a registry could be fed to itself or another registry via recursive sweeps + return $target if $reg_of_regs{$refaddr}; - if (defined $weak_registry->{$slot}{weakref}) { - if ( $weak_registry->{$slot}{refaddr} != $refaddr ) { - print STDERR "Bail out! Weak Registry slot collision $slot: $weak_registry->{$slot}{weakref} / $target\n"; - exit 255; - } + weaken( $reg_of_regs{ hrefaddr($weak_registry) } = $weak_registry ) + unless( $reg_of_regs{ hrefaddr($weak_registry) } ); + + # an explicit "garbage collection" pass every time we store a ref + # if we do not do this the registry will keep growing appearing + # as if the traced program is continuously slowly leaking memory + for my $reg (values %reg_of_regs) { + (defined $reg->{$_}{weakref}) or delete $reg->{$_} + for keys %$reg; } - else { - $weak_registry->{$slot} = { + + # FIXME/INVESTIGATE - something fishy is going on with refs to plain + # strings, perhaps something to do with the CoW work etc... + return $target if SKIP_SCALAR_REFS and reftype($target) eq 'SCALAR'; + + if (! defined $weak_registry->{$refaddr}{weakref}) { + $weak_registry->{$refaddr} = { stacktrace => stacktrace(1), - refaddr => $refaddr, - renumber => $_[2] ? 0 : 1, + weakref => $target, }; - weaken( $weak_registry->{$slot}{weakref} = $target ); + weaken( $weak_registry->{$refaddr}{weakref} ); $refs_traced++; } - weaken( $reg_of_regs{ refaddr($weak_registry) } = $weak_registry ) - unless( $reg_of_regs{ refaddr($weak_registry) } ); + my $desc = _describe_ref($target); + $weak_registry->{$refaddr}{slot_names}{$desc} = 1; + if ($note) { + $note =~ s/\s*\Q$desc\E\s*//g; + $weak_registry->{$refaddr}{slot_names}{$note} = 1; + } $target; } -# Renumber everything we auto-named on a thread spawn +# Regenerate the slots names on a thread spawn sub CLONE { my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs; %reg_of_regs = (); for my $reg (@individual_regs) { - my @live_slots = grep { defined $reg->{$_}{weakref} } keys %$reg + my @live_slots = grep { defined $_->{weakref} } values %$reg or next; - my @live_instances = @{$reg}{@live_slots}; - $reg = {}; # get a fresh hashref in the new thread ctx - weaken( $reg_of_regs{refaddr($reg)} = $reg ); + weaken( $reg_of_regs{hrefaddr($reg)} = $reg ); - while (@live_slots) { - my $slot = shift @live_slots; - my $inst = shift @live_instances; + for my $slot_info (@live_slots) { + my $new_addr = hrefaddr $slot_info->{weakref}; - my $refaddr = $inst->{refaddr} = refaddr($inst); + # replace all slot names + $slot_info->{slot_names} = { map { + my $name = $_; + $name =~ s/\(0x[0-9A-F]+\)/sprintf ('(%s)', $new_addr)/ieg; + ($name => 1); + } keys %{$slot_info->{slot_names}} }; - $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', $refaddr)/ieg - if $inst->{renumber}; - - $reg->{$slot} = $inst; + $reg->{$new_addr} = $slot_info; } } } +sub visit_refs { + my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; + + $args->{seen_refs} ||= {}; + + my $visited_cnt = '0E0'; + for my $i (0 .. $#{$args->{refs}} ) { + + next unless length ref $args->{refs}[$i]; # not-a-ref + + my $addr = hrefaddr $args->{refs}[$i]; + + # no diving into weakregistries + next if $reg_of_regs{$addr}; + + next if $args->{seen_refs}{$addr}++; + $visited_cnt++; + + my $r = $args->{refs}[$i]; + + $args->{action}->($r) or next; + + # This may end up being necessarry some day, but do not slow things + # down for now + #if ( defined( my $t = tied($r) ) ) { + # $visited_cnt += visit_refs({ %$args, refs => [ $t ] }); + #} + + my $type = reftype $r; + + local $@; + eval { + if ($type eq 'HASH') { + $visited_cnt += visit_refs({ %$args, refs => [ map { + ( !isweak($r->{$_}) ) ? $r->{$_} : () + } keys %$r ] }); + } + elsif ($type eq 'ARRAY') { + $visited_cnt += visit_refs({ %$args, refs => [ map { + ( !isweak($r->[$_]) ) ? $r->[$_] : () + } 0..$#$r ] }); + } + elsif ($type eq 'REF' and !isweak($$r)) { + $visited_cnt += visit_refs({ %$args, refs => [ $$r ] }); + } + elsif (CV_TRACING and $type eq 'CODE') { + $visited_cnt += visit_refs({ %$args, refs => [ map { + ( !isweak($_) ) ? $_ : () + } scalar PadWalker::closed_over($r) ] }); # scalar due to RT#92269 + } + 1; + } or warn "Could not descend into @{[ _describe_ref($r) ]}: $@\n"; + } + $visited_cnt; +} + +sub visit_namespaces { + my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; + + my $visited = 1; + + $args->{package} ||= '::'; + $args->{package} = '::' if $args->{package} eq 'main'; + + if ( $args->{action}->($args->{package}) ) { + + my $base = $args->{package}; + $base = '' if $base eq '::'; + + + $visited += visit_namespaces({ %$args, package => $_ }) for map + { $_ =~ /(.+?)::$/ && "${base}::$1" } + grep + { $_ =~ /(? sub { + + no strict 'refs'; + + my $pkg = shift; + $pkg = '' if $pkg eq '::'; + $pkg .= '::'; + + # the unless regex at the end skips some dangerous namespaces outright + # (but does not prevent descent) + $refs_per_pkg->{$pkg} += visit_refs ( + seen_refs => $seen_refs, + + # FIXME FIXME FIXME + # This is so damn odd - if we feed a constsub {1} (or in fact almost + # anything other than the actionsub below, any scalarref will show + # up as a leak, trapped by... something... + # Ideally we should be able to const this to sub{1} and just return + # $seen_refs (in fact it is identical to the dummy list at the end of + # a run here). Alas this doesn't seem to work, so punt for now... + action => sub { ++$dummy_addresslist->{ hrefaddr $_[0] } }, + + refs => [ map { my $sym = $_; + # *{"$pkg$sym"}{CODE} won't simply work - MRO-cached CVs are invisible there + ( CV_TRACING ? Class::MethodCache::get_cv("${pkg}$sym") : () ), + + ( defined *{"$pkg$sym"}{SCALAR} and length ref ${"$pkg$sym"} and ! isweak( ${"$pkg$sym"} ) ) + ? ${"$pkg$sym"} : () + , + + ( map { + ( defined *{"$pkg$sym"}{$_} and ! isweak(defined *{"$pkg$sym"}{$_}) ) + ? *{"$pkg$sym"}{$_} + : () + } qw(HASH ARRAY IO GLOB) ), + + } keys %$pkg ], + ) unless $pkg =~ /^ :: (?: + DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3 + ) :: $/x; + } + ); + +# use Devel::Dwarn; +# Ddie [ map +# { { $_ => $refs_per_pkg->{$_} } } +# sort +# {$refs_per_pkg->{$a} <=> $refs_per_pkg->{$b} } +# keys %$refs_per_pkg +# ]; + + $seen_refs; +} + sub assert_empty_weakregistry { my ($weak_registry, $quiet) = @_; + # in case we hooked bless any extra object creation will wreak + # havoc during the assert phase + local *CORE::GLOBAL::bless; + *CORE::GLOBAL::bless = sub { CORE::bless( $_[0], (@_ > 1) ? $_[1] : caller() ) }; + croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; + defined $weak_registry->{$_}{weakref} or delete $weak_registry->{$_} + for keys %$weak_registry; + return unless keys %$weak_registry; my $tb = eval { Test::Builder->new } - or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense'; + or croak "Calling assert_empty_weakregistry in $0 without a loaded Test::Builder makes no sense"; + + for my $addr (keys %$weak_registry) { + $weak_registry->{$addr}{display_name} = join ' | ', ( + sort + { length $a <=> length $b or $a cmp $b } + keys %{$weak_registry->{$addr}{slot_names}} + ); - for my $slot (sort keys %$weak_registry) { - next if ! defined $weak_registry->{$slot}{weakref}; - $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!") - unless isweak( $weak_registry->{$slot}{weakref} ); + $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $weak_registry->{$addr}{display_name} IS NOT A WEAKREF !!!!") + if defined $weak_registry->{$addr}{weakref} and ! isweak( $weak_registry->{$addr}{weakref} ); } + # the walk is very expensive - if we are $quiet (running in an END block) + # we do not really need to be too thorough + unless ($quiet) { + delete $weak_registry->{$_} for keys %{ symtable_referenced_addresses() }; + } - # compile a list of refs stored as CAG class data, so we can skip them - # intelligently below - my ($classdata_refcounts, $symwalker, $refwalker); - $refwalker = sub { - return unless length ref $_[0]; + for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) { - my $seen = $_[1] || {}; - return if $seen->{refaddr $_[0]}++; + next if ! defined $weak_registry->{$addr}{weakref}; - $classdata_refcounts->{refaddr $_[0]}++; + $leaks_found++ unless $tb->in_todo; + $tb->ok (0, "Leaked $weak_registry->{$addr}{display_name}"); - my $type = reftype $_[0]; - if ($type eq 'HASH') { - $refwalker->($_, $seen) for values %{$_[0]}; - } - elsif ($type eq 'ARRAY') { - $refwalker->($_, $seen) for @{$_[0]}; - } - elsif ($type eq 'REF') { - $refwalker->($$_, $seen); - } - }; - - $symwalker = sub { - no strict 'refs'; - my $pkg = shift || '::'; - - $refwalker->(${"${pkg}$_"}) for grep { $_ =~ /__cag_(?!pkg_gen__|supers__)/ } keys %$pkg; - - $symwalker->("${pkg}$_") for grep { $_ =~ /(?(); - - for my $slot (keys %$weak_registry) { - if ( - defined $weak_registry->{$slot}{weakref} - and - my $expected_refcnt = $classdata_refcounts->{$weak_registry->{$slot}{refaddr}} - ) { - # need to store the SVref and examine it separately, - # to push the weakref instance off the pad - my $sv = svref_2object($weak_registry->{$slot}{weakref}); - delete $weak_registry->{$slot} if $sv->REFCNT == $expected_refcnt; - } - } - } + my $diag = do { + local $Data::Dumper::Maxdepth = 1; + sprintf "\n%s (refcnt %d) => %s\n", + $weak_registry->{$addr}{display_name}, + refcount($weak_registry->{$addr}{weakref}), + ( + ref($weak_registry->{$addr}{weakref}) eq 'CODE' + and + B::svref_2object($weak_registry->{$addr}{weakref})->XSUB + ) ? '__XSUB__' : Dumper( $weak_registry->{$addr}{weakref} ) + ; + }; - for my $slot (sort keys %$weak_registry) { - ! defined $weak_registry->{$slot}{weakref} and next if $quiet; + # FIXME - need to add a circular reference seeker based on the visitor + # (will need a bunch of modifications, punting with just a stub for now) - $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do { - $leaks_found = 1; + $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 50) . "\n" + if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); - my $diag = ''; + $diag =~ s/^/ /mg; - $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n" - if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); + if (my $stack = $weak_registry->{$addr}{stacktrace}) { + $diag .= " Reference first seen$stack"; + } - if (my $stack = $weak_registry->{$slot}{stacktrace}) { - $diag .= " Reference first seen$stack"; - } + $tb->diag($diag); + +# if ($leaks_found == 1) { +# # using the fh dumper due to intermittent buffering issues +# # in case we decide to exit soon after (possibly via _exit) +# require Devel::MAT::Dumper; +# local $Devel::MAT::Dumper::MAX_STRING = -1; +# open( my $fh, '>:raw', "leaked_${addr}_pid$$.pmat" ) or die $!; +# Devel::MAT::Dumper::dumpfh( $fh ); +# close ($fh) or die $!; +# +# use POSIX; +# POSIX::_exit(1); +# } + } - $tb->diag($diag) if $diag; - }; + if (! $quiet and !$leaks_found and ! $tb->in_todo) { + $tb->ok(1, sprintf "No leaks found at %s line %d", (caller())[1,2] ); } } diff --git a/t/lib/DBICTest/WithTaint.pm b/t/lib/DBICTest/WithTaint.pm new file mode 100644 index 0000000..abad25d --- /dev/null +++ b/t/lib/DBICTest/WithTaint.pm @@ -0,0 +1,4 @@ +# keep stricture tests happy +use strict; +use warnings; +1; diff --git a/t/multi_create/standard.t b/t/multi_create/standard.t index 5a02947..6c1efd8 100644 --- a/t/multi_create/standard.t +++ b/t/multi_create/standard.t @@ -444,7 +444,11 @@ throws_ok ( sub { #$t->cd($t->new_related('cd', { artist => undef } ) ); #$t->{_rel_in_storage} = 0; $t->insert; -}, qr/cd.artist may not be NULL/, "Exception propogated properly"); +}, qr/DBI Exception.+(?x: + \QNOT NULL constraint failed: cd.artist\E + | + \Qcd.artist may not be NULL\E +)/s, "Exception propogated properly"); lives_ok ( sub { $schema->resultset('CD')->create ({ diff --git a/t/prefetch/correlated.t b/t/prefetch/correlated.t index 8d99ff8..6452a94 100644 --- a/t/prefetch/correlated.t +++ b/t/prefetch/correlated.t @@ -138,4 +138,103 @@ is_same_sql_bind( 'Expected SQL on correlated realiased subquery' ); +# test for subselect identifier leakage +# NOTE - the hodge-podge mix of literal and regular identifuers is *deliberate* +for my $quote_names (0,1) { + my $schema = DBICTest->init_schema( quote_names => $quote_names ); + + my ($ql, $qr) = $schema->storage->sql_maker->_quote_chars; + + my $art_rs = $schema->resultset('Artist')->search ({}, { + order_by => 'me.artistid', + prefetch => 'cds', + rows => 2, + }); + + my $inner_lim_bindtype = { sqlt_datatype => 'integer' }; + + for my $inner_relchain (qw( cds_unordered cds ) ) { + + my $stupid_latest_competition_release_query = $schema->resultset('Artist')->search( + { 'competition.artistid' => { '!=', { -ident => 'me.artistid' } } }, + { alias => 'competition' }, + )->search_related( $inner_relchain, {}, { + rows => 1, order_by => 'year', columns => { year => \'year' }, distinct => 1 + })->get_column(\'year')->max_rs; + + my $final_query = $art_rs->search( {}, { + '+columns' => { max_competition_release => \[ + @${ $stupid_latest_competition_release_query->as_query } + ]}, + }); + + # we are using cds_unordered explicitly above - do the sorting manually + my @results = sort { $a->{artistid} <=> $b->{artistid} } @{$final_query->all_hri}; + @$_ = sort { $a->{cdid} <=> $b->{cdid} } @$_ for map { $_->{cds} } @results; + + is_deeply ( + \@results, + [ + { artistid => 1, charfield => undef, max_competition_release => 1998, name => "Caterwauler McCrae", rank => 13, cds => [ + { artist => 1, cdid => 1, genreid => 1, single_track => undef, title => "Spoonful of bees", year => 1999 }, + { artist => 1, cdid => 2, genreid => undef, single_track => undef, title => "Forkful of bees", year => 2001 }, + { artist => 1, cdid => 3, genreid => undef, single_track => undef, title => "Caterwaulin' Blues", year => 1997 }, + ] }, + { artistid => 2, charfield => undef, max_competition_release => 1997, name => "Random Boy Band", rank => 13, cds => [ + { artist => 2, cdid => 4, genreid => undef, single_track => undef, title => "Generic Manufactured Singles", year => 2001 }, + ] }, + ], + "Expected result from weird query", + ); + + # the decomposition to sql/bind is *deliberate* in both instances + # we want to ensure this keeps working for lietral sql, even when + # as_query switches to return an overloaded dq node + my ($sql, @bind) = @${ $final_query->as_query }; + + my $correlated_sql = qq{ ( + SELECT MAX( year ) + FROM ( + SELECT year + FROM ${ql}artist${qr} ${ql}competition${qr} + JOIN cd ${ql}${inner_relchain}${qr} + ON ${ql}${inner_relchain}${qr}.${ql}artist${qr} = ${ql}competition${qr}.${ql}artistid${qr} + WHERE ${ql}competition${qr}.${ql}artistid${qr} != ${ql}me${qr}.${ql}artistid${qr} + GROUP BY year + ORDER BY MIN( ${ql}year${qr} ) + LIMIT ? + ) ${ql}${inner_relchain}${qr} + )}; + + is_same_sql_bind( + $sql, + \@bind, + qq{ ( + SELECT ${ql}me${qr}.${ql}artistid${qr}, ${ql}me${qr}.${ql}name${qr}, ${ql}me${qr}.${ql}rank${qr}, ${ql}me${qr}.${ql}charfield${qr}, + $correlated_sql, + ${ql}cds${qr}.${ql}cdid${qr}, ${ql}cds${qr}.${ql}artist${qr}, ${ql}cds${qr}.${ql}title${qr}, ${ql}cds${qr}.${ql}year${qr}, ${ql}cds${qr}.${ql}genreid${qr}, ${ql}cds${qr}.${ql}single_track${qr} + FROM ( + SELECT ${ql}me${qr}.${ql}artistid${qr}, ${ql}me${qr}.${ql}name${qr}, ${ql}me${qr}.${ql}rank${qr}, ${ql}me${qr}.${ql}charfield${qr}, + $correlated_sql + FROM ${ql}artist${qr} ${ql}me${qr} + ORDER BY ${ql}me${qr}.${ql}artistid${qr} + LIMIT ? + ) ${ql}me${qr} + LEFT JOIN cd ${ql}cds${qr} + ON ${ql}cds${qr}.${ql}artist${qr} = ${ql}me${qr}.${ql}artistid${qr} + ORDER BY ${ql}me${qr}.${ql}artistid${qr} + ) }, + [ + [ $inner_lim_bindtype + => 1 ], + [ $inner_lim_bindtype + => 1 ], + [ { sqlt_datatype => 'integer' } + => 2 ], + ], + "No leakage of correlated subquery identifiers (quote_names => $quote_names, inner alias '$inner_relchain')" + ); + } +} + done_testing; diff --git a/t/prefetch/multiple_hasmany_torture.t b/t/prefetch/multiple_hasmany_torture.t index b524aa9..1623937 100644 --- a/t/prefetch/multiple_hasmany_torture.t +++ b/t/prefetch/multiple_hasmany_torture.t @@ -9,25 +9,6 @@ use DBICTest; my $schema = DBICTest->init_schema(); -my $mo_rs = $schema->resultset('Artist')->search( - { 'me.artistid' => 4 }, - { - prefetch => [ - { - cds => [ - { tracks => { cd_single => 'tracks' } }, - { cd_to_producer => 'producer' } - ] - }, - { artwork_to_artist => 'artwork' } - ], - - result_class => 'DBIx::Class::ResultClass::HashRefInflator', - - order_by => [qw/tracks.position tracks.trackid producer.producerid tracks_2.trackid artwork.cd_id/], - } -); - $schema->resultset('Artist')->create( { name => 'mo', @@ -78,11 +59,7 @@ $schema->resultset('Artist')->create( } ); -my $mo = $mo_rs->next; - -is( @{$mo->{cds}}, 2, 'two CDs' ); - -cmp_deeply( $mo, { +my $artist_with_extras = { artistid => 4, charfield => undef, name => 'mo', rank => 1337, artwork_to_artist => [ { artist_id => 4, artwork_cd_id => 1, artwork => { cd_id => 1 } }, @@ -125,6 +102,26 @@ cmp_deeply( $mo, { ], } ], +}; + +my $art_rs = $schema->resultset('Artist')->search({ 'me.artistid' => 4 }); + + +my $art_rs_prefetch = $art_rs->search({}, { + order_by => [qw/tracks.position tracks.trackid producer.producerid tracks_2.trackid artwork.cd_id/], + result_class => 'DBIx::Class::ResultClass::HashRefInflator', + prefetch => [ + { + cds => [ + { tracks => { cd_single => 'tracks' } }, + { cd_to_producer => 'producer' } + ] + }, + { artwork_to_artist => 'artwork' } + ], }); +cmp_deeply( $art_rs_prefetch->next, $artist_with_extras ); + + done_testing; diff --git a/t/relationship/custom_with_null_in_cond.t b/t/relationship/custom_with_null_in_cond.t new file mode 100644 index 0000000..e7a7acb --- /dev/null +++ b/t/relationship/custom_with_null_in_cond.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::More; + +use lib 't/lib'; +use DBICTest; + +my $schema = DBICTest->init_schema(); + +my $artist_rs = $schema->resultset('Artist'); + +for my $rel_rs( + $artist_rs->search_related_rs( + cds_without_genre => { artist => 1 }, { order_by => 'cdid' } + ), + $artist_rs->find(1)->search_related_rs( + cds_without_genre => {}, { order_by => 'cdid' } + ), +) { + + is_deeply( + $rel_rs->all_hri, + [ + { + artist => 1, + cdid => 2, + genreid => undef, + single_track => undef, + title => "Forkful of bees", + year => 2001 + }, + { + artist => 1, + cdid => 3, + genreid => undef, + single_track => undef, + title => "Caterwaulin' Blues", + year => 1997 + }, + ] + ); +} + +done_testing; diff --git a/t/relationship/update_or_create_multi.t b/t/relationship/update_or_create_multi.t index 8710048..c7cce7a 100644 --- a/t/relationship/update_or_create_multi.t +++ b/t/relationship/update_or_create_multi.t @@ -69,7 +69,12 @@ throws_ok { year => 2020, title => 'the best thing since sliced bread', }) -} qr/\Qcd.artist may not be NULL/, 'ambiguous find + create failed'; +} qr/DBI Exception.+(?x: + \QNOT NULL constraint failed: cd.artist\E + | + \Qcd.artist may not be NULL\E +)/s, 'ambiguous find + create failed' +; # expect a create, after a failed search using *only* the # *current* relationship and the unique column constraints diff --git a/t/search/preserve_original_rs.t b/t/search/preserve_original_rs.t index a87fe9a..cb9a306 100644 --- a/t/search/preserve_original_rs.t +++ b/t/search/preserve_original_rs.t @@ -97,7 +97,13 @@ for my $s (qw/a2a artw cd artw_back/) { is ($fresh->count_rs({ cdid => 1})->next, 1 ); ok (! exists $fresh->{cursor}, 'Still no cursor on fresh rs'); - ok (! exists $fresh->{_attrs}{_sqlmaker_select_args}, 'select args did not leak through' ); + ok (! exists $fresh->{_attrs}{_last_sqlmaker_alias_map}, 'aliasmap did not leak through' ); + + my $n = $fresh->next; + + # check that we are not testing for deprecated slotnames + ok ($fresh->{cursor}, 'Cursor at expected slot after fire'); + ok (exists $fresh->{_attrs}{_last_sqlmaker_alias_map}, 'aliasmap at expected slot after fire' ); } done_testing; diff --git a/t/search/subquery.t b/t/search/subquery.t index 382a46d..a281fe9 100644 --- a/t/search/subquery.t +++ b/t/search/subquery.t @@ -46,7 +46,7 @@ my @tests = ( ], }, sqlbind => \[ - "( SELECT (SELECT id FROM cd me LIMIT ?) FROM artist me )", + "( SELECT (SELECT me.id FROM cd me LIMIT ?) FROM artist me )", [ $ROWS => 1 ], ], }, @@ -59,7 +59,7 @@ my @tests = ( ], }, sqlbind => \[ - "( SELECT me.artistid, me.name, me.rank, me.charfield, (SELECT id FROM cd me LIMIT ?) FROM artist me )", + "( SELECT me.artistid, me.name, me.rank, me.charfield, (SELECT me.id FROM cd me LIMIT ?) FROM artist me )", [ $ROWS => 1 ], ], }, diff --git a/t/sqlmaker/hierarchical/oracle.t b/t/sqlmaker/hierarchical/oracle.t new file mode 100644 index 0000000..1283140 --- /dev/null +++ b/t/sqlmaker/hierarchical/oracle.t @@ -0,0 +1,314 @@ +use strict; +use warnings; + +use Test::More; +use lib qw(t/lib); + +use DBIx::Class::Optional::Dependencies; +plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener') + unless DBIx::Class::Optional::Dependencies->req_ok_for ('id_shortener'); + +use DBICTest::Schema::Artist; +BEGIN { + DBICTest::Schema::Artist->add_column('parentid'); + + DBICTest::Schema::Artist->has_many( + children => 'DBICTest::Schema::Artist', + { 'foreign.parentid' => 'self.artistid' } + ); + + DBICTest::Schema::Artist->belongs_to( + parent => 'DBICTest::Schema::Artist', + { 'foreign.artistid' => 'self.parentid' } + ); +} + +use DBICTest; +use DBICTest::Schema; +use DBIC::SqlMakerTest; + +use DBIx::Class::SQLMaker::LimitDialects; +my $ROWS = DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype; +my $TOTAL = DBIx::Class::SQLMaker::LimitDialects->__total_bindtype; + +for my $q ( '', '"' ) { + + my $schema = DBICTest->init_schema( + storage_type => 'DBIx::Class::Storage::DBI::Oracle::Generic', + no_deploy => 1, + quote_char => $q, + ); + + # select the whole tree + { + my $rs = $schema->resultset('Artist')->search({}, { + start_with => { name => 'root' }, + connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, + }); + + is_same_sql_bind ( + $rs->as_query, + "( + SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q} + FROM ${q}artist${q} ${q}me${q} + START WITH ${q}name${q} = ? + CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} + )", + [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } + => 'root'] ], + ); + + is_same_sql_bind ( + $rs->count_rs->as_query, + "( + SELECT COUNT( * ) + FROM ${q}artist${q} ${q}me${q} + START WITH ${q}name${q} = ? + CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} + )", + [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } + => 'root'] ], + ); + } + + # use order siblings by statement + { + my $rs = $schema->resultset('Artist')->search({}, { + start_with => { name => 'root' }, + connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, + order_siblings_by => { -desc => 'name' }, + }); + + is_same_sql_bind ( + $rs->as_query, + "( + SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q} + FROM ${q}artist${q} ${q}me${q} + START WITH ${q}name${q} = ? + CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} + ORDER SIBLINGS BY ${q}name${q} DESC + )", + [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } + => 'root'] ], + ); + } + + # get the root node + { + my $rs = $schema->resultset('Artist')->search({ parentid => undef }, { + start_with => { name => 'root' }, + connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, + }); + + is_same_sql_bind ( + $rs->as_query, + "( + SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q} + FROM ${q}artist${q} ${q}me${q} + WHERE ( ${q}parentid${q} IS NULL ) + START WITH ${q}name${q} = ? + CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} + )", + [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } + => 'root'] ], + ); + } + + # combine a connect by with a join + { + my $rs = $schema->resultset('Artist')->search( + {'cds.title' => { -like => '%cd'} }, + { + join => 'cds', + start_with => { 'me.name' => 'root' }, + connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, + } + ); + + is_same_sql_bind ( + $rs->as_query, + "( + SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q} + FROM ${q}artist${q} ${q}me${q} + LEFT JOIN cd ${q}cds${q} ON ${q}cds${q}.${q}artist${q} = ${q}me${q}.${q}artistid${q} + WHERE ( ${q}cds${q}.${q}title${q} LIKE ? ) + START WITH ${q}me${q}.${q}name${q} = ? + CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} + )", + [ + [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'cds.title', 'sqlt_size' => 100 } + => '%cd'], + [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'me.name', 'sqlt_size' => 100 } + => 'root'], + ], + ); + + is_same_sql_bind ( + $rs->count_rs->as_query, + "( + SELECT COUNT( * ) + FROM ${q}artist${q} ${q}me${q} + LEFT JOIN cd ${q}cds${q} ON ${q}cds${q}.${q}artist${q} = ${q}me${q}.${q}artistid${q} + WHERE ( ${q}cds${q}.${q}title${q} LIKE ? ) + START WITH ${q}me${q}.${q}name${q} = ? + CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} + )", + [ + [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'cds.title', 'sqlt_size' => 100 } + => '%cd'], + [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'me.name', 'sqlt_size' => 100 } + => 'root'], + ], + ); + } + + # combine a connect by with order_by + { + my $rs = $schema->resultset('Artist')->search({}, { + start_with => { name => 'root' }, + connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, + order_by => { -asc => [ 'LEVEL', 'name' ] }, + }); + + is_same_sql_bind ( + $rs->as_query, + "( + SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q} + FROM ${q}artist${q} ${q}me${q} + START WITH ${q}name${q} = ? + CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} + ORDER BY ${q}LEVEL${q} ASC, ${q}name${q} ASC + )", + [ + [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } + => 'root'], + ], + ); + } + + # limit a connect by + { + my $rs = $schema->resultset('Artist')->search({}, { + start_with => { name => 'root' }, + connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, + order_by => [ { -asc => 'name' }, { -desc => 'artistid' } ], + rows => 2, + }); + + is_same_sql_bind ( + $rs->as_query, + "( + SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q} + FROM ( + SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q} + FROM ${q}artist${q} ${q}me${q} + START WITH ${q}name${q} = ? + CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} + ORDER BY ${q}name${q} ASC, ${q}artistid${q} DESC + ) ${q}me${q} + WHERE ROWNUM <= ? + )", + [ + [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } + => 'root'], [ $ROWS => 2 ], + ], + ); + + is_same_sql_bind ( + $rs->count_rs->as_query, + "( + SELECT COUNT( * ) + FROM ( + SELECT ${q}me${q}.${q}artistid${q} + FROM ( + SELECT ${q}me${q}.${q}artistid${q} + FROM ${q}artist${q} ${q}me${q} + START WITH ${q}name${q} = ? + CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} + ) ${q}me${q} + WHERE ROWNUM <= ? + ) ${q}me${q} + )", + [ + [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } + => 'root'], + [ $ROWS => 2 ], + ], + ); + } + + # combine a connect_by with group_by and having + # add some bindvals to make sure things still work + { + my $rs = $schema->resultset('Artist')->search({}, { + select => \[ 'COUNT(rank) + ?', [ __cbind => 3 ] ], + as => 'cnt', + start_with => { name => 'root' }, + connect_by => { parentid => { -prior => { -ident => 'artistid' } } }, + group_by => \[ 'rank + ? ', [ __gbind => 1] ], + having => \[ 'count(rank) < ?', [ cnt => 2 ] ], + }); + + is_same_sql_bind ( + $rs->as_query, + "( + SELECT COUNT(rank) + ? + FROM ${q}artist${q} ${q}me${q} + START WITH ${q}name${q} = ? + CONNECT BY ${q}parentid${q} = PRIOR ${q}artistid${q} + GROUP BY( rank + ? ) + HAVING count(rank) < ? + )", + [ + [ { dbic_colname => '__cbind' } + => 3 ], + [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } + => 'root'], + [ { dbic_colname => '__gbind' } + => 1 ], + [ { dbic_colname => 'cnt' } + => 2 ], + ], + ); + } + + # select the whole cycle tree with nocylce + { + my $rs = $schema->resultset('Artist')->search({}, { + start_with => { name => 'cycle-root' }, + '+select' => \ 'CONNECT_BY_ISCYCLE', + '+as' => [ 'connector' ], + connect_by_nocycle => { parentid => { -prior => { -ident => 'artistid' } } }, + }); + + is_same_sql_bind ( + $rs->as_query, + "( + SELECT ${q}me${q}.${q}artistid${q}, ${q}me${q}.${q}name${q}, ${q}me${q}.${q}rank${q}, ${q}me${q}.${q}charfield${q}, ${q}me${q}.${q}parentid${q}, CONNECT_BY_ISCYCLE + FROM ${q}artist${q} ${q}me${q} + START WITH ${q}name${q} = ? + CONNECT BY NOCYCLE ${q}parentid${q} = PRIOR ${q}artistid${q} + )", + [ + [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } + => 'cycle-root'], + ], + ); + + is_same_sql_bind ( + $rs->count_rs->as_query, + "( + SELECT COUNT( * ) + FROM ${q}artist${q} ${q}me${q} + START WITH ${q}name${q} = ? + CONNECT BY NOCYCLE ${q}parentid${q} = PRIOR ${q}artistid${q} + )", + [ + [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 } + => 'cycle-root'], + ], + ); + } +} + +done_testing; diff --git a/t/sqlmaker/limit_dialects/fetch_first.t b/t/sqlmaker/limit_dialects/fetch_first.t index 431423e..4665b4c 100644 --- a/t/sqlmaker/limit_dialects/fetch_first.t +++ b/t/sqlmaker/limit_dialects/fetch_first.t @@ -114,6 +114,15 @@ for my $ord_set ( exselect_outer => 'ORDER__BY__001, ORDER__BY__002, ORDER__BY__003', exselect_inner => 'title AS ORDER__BY__001, bar AS ORDER__BY__002, sensors AS ORDER__BY__003', }, + + { + order_by => [ + 'name', + ], + order_inner => 'name', + order_outer => 'name DESC', + order_req => 'name', + }, ) { my $o_sel = $ord_set->{exselect_outer} ? ', ' . $ord_set->{exselect_outer} @@ -124,8 +133,13 @@ for my $ord_set ( : '' ; + my $rs = $books_45_and_owners->search ({}, {order_by => $ord_set->{order_by}}); + + # query actually works + ok( defined $rs->count, 'Query actually works' ); + is_same_sql_bind( - $books_45_and_owners->search ({}, {order_by => $ord_set->{order_by}})->as_query, + $rs->as_query, "(SELECT me.id, me.source, me.owner, me.price, owner__id, owner__name FROM ( SELECT me.id, me.source, me.owner, me.price, owner__id, owner__name$o_sel @@ -145,6 +159,7 @@ for my $ord_set ( [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ] ], ); + } # with groupby diff --git a/t/sqlmaker/limit_dialects/mssql_torture.t b/t/sqlmaker/limit_dialects/mssql_torture.t new file mode 100644 index 0000000..7806dfb --- /dev/null +++ b/t/sqlmaker/limit_dialects/mssql_torture.t @@ -0,0 +1,259 @@ +use strict; +use warnings; +use Test::More; +use lib qw(t/lib); +use DBICTest; +use DBIC::SqlMakerTest; +use DBIx::Class::SQLMaker::LimitDialects; +my $OFFSET = DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype; +my $TOTAL = DBIx::Class::SQLMaker::LimitDialects->__total_bindtype; + +my $schema = DBICTest->init_schema ( + storage_type => 'DBIx::Class::Storage::DBI::MSSQL', + no_deploy => 1, + quote_names => 1 +); +# prime caches +$schema->storage->sql_maker; + +# more involved limit dialect torture testcase migrated from the +# live mssql tests +my $tests = { + pref_hm_and_page_and_group_rs => { + + rs => scalar $schema->resultset ('Owners')->search ( + { + 'books.id' => { '!=', undef }, + 'me.name' => { '!=', 'somebogusstring' }, + }, + { + prefetch => 'books', + order_by => [ { -asc => \['name + ?', [ test => 'xxx' ]] }, 'me.id' ], # test bindvar propagation + group_by => [ map { "me.$_" } $schema->source('Owners')->columns ], # the literal order_by requires an explicit group_by + rows => 3, + unsafe_subselect_ok => 1, + }, + )->page(3), + + result => { + Top => [ + '( + SELECT TOP 2147483647 [me].[id], [me].[name], + [books].[id], [books].[source], [books].[owner], [books].[title], [books].[price] + FROM ( + SELECT TOP 2147483647 [me].[id], [me].[name] + FROM ( + SELECT TOP 3 [me].[id], [me].[name], [ORDER__BY__001] + FROM ( + SELECT TOP 9 [me].[id], [me].[name], name + ? AS [ORDER__BY__001] + FROM [owners] [me] + LEFT JOIN [books] [books] + ON [books].[owner] = [me].[id] + WHERE [books].[id] IS NOT NULL AND [me].[name] != ? + GROUP BY [me].[id], [me].[name] + ORDER BY name + ? ASC, [me].[id] + ) [me] + ORDER BY [ORDER__BY__001] DESC, [me].[id] DESC + ) [me] + ORDER BY [ORDER__BY__001] ASC, [me].[id] + ) [me] + LEFT JOIN [books] [books] + ON [books].[owner] = [me].[id] + WHERE [books].[id] IS NOT NULL AND [me].[name] != ? + ORDER BY name + ? ASC, [me].[id] + )', + [ + [ { dbic_colname => 'test' } + => 'xxx' ], + + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.name' } + => 'somebogusstring' ], + + [ { dbic_colname => 'test' } => 'xxx' ], # the extra re-order bind + + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.name' } + => 'somebogusstring' ], + + [ { dbic_colname => 'test' } + => 'xxx' ], + ], + ], + + RowNumberOver => [ + '( + SELECT TOP 2147483647 [me].[id], [me].[name], + [books].[id], [books].[source], [books].[owner], [books].[title], [books].[price] + FROM ( + SELECT TOP 2147483647 [me].[id], [me].[name] + FROM ( + SELECT [me].[id], [me].[name], + ROW_NUMBER() OVER( ORDER BY [ORDER__BY__001] ASC, [me].[id] ) AS [rno__row__index] + FROM ( + SELECT [me].[id], [me].[name], name + ? AS [ORDER__BY__001] + FROM [owners] [me] + LEFT JOIN [books] [books] + ON [books].[owner] = [me].[id] + WHERE [books].[id] IS NOT NULL AND [me].[name] != ? + GROUP BY [me].[id], [me].[name] + ) [me] + ) [me] + WHERE [rno__row__index] >= ? AND [rno__row__index] <= ? + ) [me] + LEFT JOIN [books] [books] + ON [books].[owner] = [me].[id] + WHERE [books].[id] IS NOT NULL AND [me].[name] != ? + ORDER BY name + ? ASC, [me].[id] + )', + [ + [ { dbic_colname => 'test' } + => 'xxx' ], + + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.name' } + => 'somebogusstring' ], + + [ $OFFSET => 7 ], # parameterised RNO + + [ $TOTAL => 9 ], + + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.name' } + => 'somebogusstring' ], + + [ { dbic_colname => 'test' } + => 'xxx' ], + ], + ], + } + }, + + pref_bt_and_page_and_group_rs => { + + rs => scalar $schema->resultset ('BooksInLibrary')->search ( + { + 'owner.name' => [qw/wiggle woggle/], + }, + { + distinct => 1, + having => \['1 = ?', [ test => 1 ] ], #test having propagation + prefetch => 'owner', + rows => 2, # 3 results total + order_by => [{ -desc => 'me.owner' }, 'me.id'], + unsafe_subselect_ok => 1, + }, + )->page(3), + + result => { + Top => [ + '( + SELECT TOP 2147483647 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], + [owner].[id], [owner].[name] + FROM ( + SELECT TOP 2147483647 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] + FROM ( + SELECT TOP 2 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] + FROM ( + SELECT TOP 6 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] + FROM [books] [me] + JOIN [owners] [owner] + ON [owner].[id] = [me].[owner] + WHERE ( [owner].[name] = ? OR [owner].[name] = ? ) AND [source] = ? + GROUP BY [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] + HAVING 1 = ? + ORDER BY [me].[owner] DESC, [me].[id] + ) [me] + ORDER BY [me].[owner] ASC, [me].[id] DESC + ) [me] + ORDER BY [me].[owner] DESC, [me].[id] + ) [me] + JOIN [owners] [owner] + ON [owner].[id] = [me].[owner] + WHERE ( [owner].[name] = ? OR [owner].[name] = ? ) AND [source] = ? + ORDER BY [me].[owner] DESC, [me].[id] + )', + [ + # inner + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } + => 'wiggle' ], + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } + => 'woggle' ], + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } + => 'Library' ], + [ { dbic_colname => 'test' } + => '1' ], + + # outer + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } + => 'wiggle' ], + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } + => 'woggle' ], + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } + => 'Library' ], + ], + ], + RowNumberOver => [ + '( + SELECT TOP 2147483647 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], + [owner].[id], [owner].[name] + FROM ( + SELECT TOP 2147483647 [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] + FROM ( + SELECT [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], + ROW_NUMBER() OVER( ORDER BY [me].[owner] DESC, [me].[id] ) AS [rno__row__index] + FROM ( + SELECT [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] + FROM [books] [me] + JOIN [owners] [owner] + ON [owner].[id] = [me].[owner] + WHERE ( [owner].[name] = ? OR [owner].[name] = ? ) AND [source] = ? + GROUP BY [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price] + HAVING 1 = ? + ) [me] + ) [me] + WHERE [rno__row__index] >= ? AND [rno__row__index] <= ? + ) [me] + JOIN [owners] [owner] + ON [owner].[id] = [me].[owner] + WHERE ( [owner].[name] = ? OR [owner].[name] = ? ) AND [source] = ? + ORDER BY [me].[owner] DESC, [me].[id] + )', + [ + # inner + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } + => 'wiggle' ], + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } + => 'woggle' ], + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } + => 'Library' ], + [ { dbic_colname => 'test' } + => '1' ], + + [ $OFFSET => 5 ], + [ $TOTAL => 6 ], + + # outer + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } + => 'wiggle' ], + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' } + => 'woggle' ], + [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } + => 'Library' ], + ], + ], + }, + }, +}; + +for my $tname (keys %$tests) { + for my $limtype (keys %{$tests->{$tname}{result}} ) { + + delete $schema->storage->_sql_maker->{_cached_syntax}; + $schema->storage->_sql_maker->limit_dialect ($limtype); + + is_same_sql_bind( + $tests->{$tname}{rs}->as_query, + @{ $tests->{$tname}{result}{$limtype} }, + "Correct SQL for $limtype on $tname", + ); + } +} + +done_testing; diff --git a/t/sqlmaker/limit_dialects/torture.t b/t/sqlmaker/limit_dialects/torture.t index 6671e37..d9beaea 100644 --- a/t/sqlmaker/limit_dialects/torture.t +++ b/t/sqlmaker/limit_dialects/torture.t @@ -392,7 +392,7 @@ my $tests = { '( SELECT me.id, owner__id, owner__name, bar, baz FROM ( - SELECT me.id, owner__id, owner__name, bar, baz, ROWNUM rownum__index + SELECT me.id, owner__id, owner__name, bar, baz, ROWNUM AS rownum__index FROM ( SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz FROM books me @@ -428,7 +428,7 @@ my $tests = { '( SELECT me.id, owner__id, owner__name, bar, baz FROM ( - SELECT me.id, owner__id, owner__name, bar, baz, ROWNUM rownum__index + SELECT me.id, owner__id, owner__name, bar, baz, ROWNUM AS rownum__index FROM ( SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz FROM books me @@ -459,7 +459,7 @@ my $tests = { FROM ( SELECT me.name, me.id FROM ( - SELECT me.name, me.id, ROWNUM rownum__index + SELECT me.name, me.id, ROWNUM AS rownum__index FROM ( SELECT me.name, me.id FROM owners me diff --git a/t/sqlmaker/msaccess.t b/t/sqlmaker/msaccess.t index 6d76f82..5b5b6ce 100644 --- a/t/sqlmaker/msaccess.t +++ b/t/sqlmaker/msaccess.t @@ -5,9 +5,81 @@ use lib qw(t/lib); use DBICTest; use DBIC::SqlMakerTest; -use DBIx::Class::SQLMaker::ACCESS (); +# the entire point of the subclass is that parenthesis have to be +# just right for ACCESS to be happy +# globalize for entirety of the test +$SQL::Abstract::Test::parenthesis_significant = 1; -my $sa = DBIx::Class::SQLMaker::ACCESS->new; +my $schema = DBICTest->init_schema (storage_type => 'DBIx::Class::Storage::DBI::ACCESS', no_deploy => 1, quote_names => 1); + +is_same_sql_bind( + $schema->resultset('Artist')->search( + { + artistid => 1, + }, + { + join => [{ cds => 'tracks' }], + '+select' => [ 'tracks.title' ], + '+as' => [ 'track_title' ], + } + )->as_query, + '( + SELECT [me].[artistid], [me].[name], [me].[rank], [me].[charfield], + [tracks].[title] + FROM ( + ( + [artist] [me] + LEFT JOIN cd [cds] + ON [cds].[artist] = [me].[artistid] + ) + LEFT JOIN [track] [tracks] + ON [tracks].[cd] = [cds].[cdid] + ) + WHERE [artistid] = ? + )', + [ + [{ sqlt_datatype => 'integer', dbic_colname => 'artistid' } + => 1 ], + ], + 'correct SQL for two-step left join' +); + +is_same_sql_bind( + $schema->resultset('Track')->search( + { + trackid => 1, + }, + { + join => [{ cd => 'artist' }], + '+select' => [ 'artist.name' ], + '+as' => [ 'artist_name' ], + } + )->as_query, + '( + SELECT [me].[trackid], [me].[cd], [me].[position], [me].[title], [me].[last_updated_on], [me].[last_updated_at], + [artist].[name] + FROM ( + ( + [track] [me] + INNER JOIN cd [cd] + ON [cd].[cdid] = [me].[cd] + ) + INNER JOIN [artist] [artist] + ON [artist].[artistid] = [cd].[artist] + ) + WHERE [trackid] = ? + )', + [ + [{ sqlt_datatype => 'integer', dbic_colname => 'trackid' } + => 1 ], + ], + 'correct SQL for two-step inner join', +); + + +my $sa = $schema->storage->sql_maker; +# the legacy tests assume no quoting - leave things as-is +$sa->quote_char(undef); # my ($self, $table, $fields, $where, $order, @rest) = @_; my ($sql, @bind) = $sa->select( diff --git a/t/sqlmaker/mysql.t b/t/sqlmaker/mysql.t index 2755a3d..b5ce8a5 100644 --- a/t/sqlmaker/mysql.t +++ b/t/sqlmaker/mysql.t @@ -12,6 +12,7 @@ use DBIC::DebugObj; my $schema = DBICTest::Schema->connect (DBICTest->_database, { quote_char => '`' }); # cheat require DBIx::Class::Storage::DBI::mysql; +*DBIx::Class::Storage::DBI::mysql::_get_server_version = sub { 5 }; bless ( $schema->storage, 'DBIx::Class::Storage::DBI::mysql' ); # check that double-subqueries are properly wrapped @@ -102,7 +103,7 @@ bless ( $schema->storage, 'DBIx::Class::Storage::DBI::mysql' ); FROM ( SELECT `artist`.`artistid` FROM cd `me` - INNER JOIN `artist` `artist` + JOIN `artist` `artist` ON `artist`.`artistid` = `me`.`artist` WHERE `artist`.`name` LIKE ? ) `_forced_double_subquery` @@ -138,4 +139,32 @@ bless ( $schema->storage, 'DBIx::Class::Storage::DBI::mysql' ); ); } +# Test support for inner joins on mysql v3 +for ( + [ 3 => 'INNER JOIN' ], + [ 4 => 'JOIN' ], +) { + my ($ver, $join_op) = @$_; + + no warnings 'redefine'; + local *DBIx::Class::Storage::DBI::mysql::_get_server_version = sub { $ver }; + + # we do not care at this point if data is available, just do a reconnect cycle + # to clear all caches + $schema->storage->disconnect; + $schema->storage->ensure_connected; + + is_same_sql_bind ( + $schema->resultset('CD')->search ({}, { prefetch => 'artist' })->as_query, + "( + SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year`, `me`.`genreid`, `me`.`single_track`, + `artist`.`artistid`, `artist`.`name`, `artist`.`rank`, `artist`.`charfield` + FROM cd `me` + $join_op `artist` `artist` ON `artist`.`artistid` = `me`.`artist` + )", + [], + "default join type works for version $ver", + ); +} + done_testing; diff --git a/t/storage/base.t b/t/storage/base.t index ab7e89c..df3641e 100644 --- a/t/storage/base.t +++ b/t/storage/base.t @@ -147,33 +147,41 @@ for my $type (keys %$invocations) { } # make sure connection-less storages do not throw on _determine_driver -{ - local $ENV{DBI_DSN}; - local $ENV{DBI_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 + if $env_dsn and $env_dsn !~ /\:SQLite\:/; - my $s = DBICTest::Schema->connect; + local $ENV{DBI_DSN} = $env_dsn || ''; + + my $s = DBICTest::Schema->connect(); is_deeply ( $s->storage->connect_info, [], - 'Starting with no connection info', + 'Starting with no explicitly passed in connect info' + . ($env_dsn ? ' (with DBI_DSN)' : ''), ); - isa_ok( - $s->storage->sql_maker, - 'DBIx::Class::SQLMaker', - 'Getting back an SQLMaker succesfully', - ); + my $sm = $s->storage->sql_maker; + + ok (! $s->storage->connected, 'Storage does not appear connected after SQLMaker instance is taken'); - ok (! $s->storage->_driver_determined, 'Driver undetermined'); + if ($env_dsn) { + isa_ok($sm, 'DBIx::Class::SQLMaker'); - ok (! $s->storage->connected, 'Storage does not appear connected'); + ok ( $s->storage->_driver_determined, 'Driver determined (with DBI_DSN)'); + isa_ok ( $s->storage, 'DBIx::Class::Storage::DBI::SQLite' ); + } + else { + isa_ok($sm, 'DBIx::Class::SQLMaker'); - throws_ok { - $s->storage->ensure_connected - } qr/You did not provide any connection_info/, - 'sensible exception on empty conninfo connect' + ok (! $s->storage->_driver_determined, 'Driver undetermined'); + + throws_ok { + $s->storage->ensure_connected + } qr/You did not provide any connection_info/, + 'sensible exception on empty conninfo connect'; + } } done_testing; - -1; diff --git a/t/storage/dbi_env.t b/t/storage/dbi_env.t index fd5f1d6..462da11 100644 --- a/t/storage/dbi_env.t +++ b/t/storage/dbi_env.t @@ -4,6 +4,7 @@ use lib qw(t/lib); use DBICTest; use Test::More; use Test::Exception; +use DBIx::Class::_Util 'sigwarn_silencer'; BEGIN { delete @ENV{qw(DBI_DSN DBI_DRIVER)} } @@ -16,6 +17,17 @@ my $dbname = DBICTest->_sqlite_dbname(sqlite_use_file => 1); sub count_sheep { my $schema = shift; + + local $SIG{__WARN__} = sigwarn_silencer( + qr/ + \QThis version of DBIC does not yet seem to supply a driver for your particular RDBMS\E + | + \QUnable to extract a driver name from connect info\E + | + \QYour storage class (DBIx::Class::Storage::DBI) does not set sql_limit_dialect\E + /x + ); + scalar $schema->resultset('Artist')->search( { name => "Exploding Sheep" } ) ->all; } @@ -87,4 +99,21 @@ $schema = DBICTest::Schema->connect; lives_ok { count_sheep($schema) } 'SQLite in DBI_DRIVER (not DBI_DSN)'; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite'; +# make sure that dynamically setting DBI_DSN post-connect works +{ + local $ENV{DBI_DSN}; + + my $s = DBICTest::Schema->connect(); + + throws_ok { + $s->storage->ensure_connected + } qr/You did not provide any connection_info/, + 'sensible exception on empty conninfo connect'; + + $ENV{DBI_DSN} = 'dbi:SQLite::memory:'; + + lives_ok { $s->storage->ensure_connected } 'Second connection attempt worked'; + isa_ok ( $s->storage, 'DBIx::Class::Storage::DBI::SQLite' ); +} + done_testing; diff --git a/t/storage/deploy.t b/t/storage/deploy.t index 78e2c8c..433f58e 100644 --- a/t/storage/deploy.t +++ b/t/storage/deploy.t @@ -15,6 +15,8 @@ BEGIN { unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy') } +local $ENV{DBI_DSN}; + # this is how maint/gen_schema did it (connect() to force a storage # instance, but no conninfo) # there ought to be more code like this in the wild diff --git a/t/storage/error.t b/t/storage/error.t index d5980eb..61d6782 100644 --- a/t/storage/error.t +++ b/t/storage/error.t @@ -15,7 +15,11 @@ warnings_are ( sub { sub { $schema->resultset('CD')->create({ title => 'vacation in antarctica' }) }, - qr/DBI Exception.+cd\.artist.+NULL/s + qr/DBI Exception.+(?x: + \QNOT NULL constraint failed: cd.artist\E + | + \Qcd.artist may not be NULL\E + )/s ); # as opposed to some other error }, [], 'No warnings besides exception' ); diff --git a/t/storage/on_connect_do.t b/t/storage/on_connect_do.t index 2874a9d..115fadb 100644 --- a/t/storage/on_connect_do.t +++ b/t/storage/on_connect_do.t @@ -36,6 +36,11 @@ $schema->storage->disconnect; ok $schema->connection( sub { DBI->connect(DBICTest->_database, undef, undef, { AutoCommit => 0 }) }, { + # DO NOT REMOVE - this seems like an unrelated piece of info, + # but is in fact a test for a bug where setting an accessor-via-option + # would trigger an early connect *bypassing* the on_connect_* pieces + cursor_class => 'DBIx::Class::Storage::Cursor', + on_connect_do => [ 'CREATE TABLE TEST_empty (id INTEGER)', [ 'INSERT INTO TEST_empty VALUES (?)', {}, 2 ], diff --git a/t/storage/replicated.t b/t/storage/replicated.t index dfd3870..509b3e6 100644 --- a/t/storage/replicated.t +++ b/t/storage/replicated.t @@ -204,10 +204,11 @@ TESTSCHEMACLASSES: { } } - ## Cleanup after ourselves. Unlink all gthe slave paths. + ## Cleanup after ourselves. Unlink all the slave paths. sub cleanup { my $self = shift @_; + $_->disconnect for values %{ $self->schema->storage->replicants }; foreach my $slave (@{$self->slave_paths}) { if(-e $slave) { unlink $slave; @@ -912,6 +913,7 @@ is $debug{storage_type}, 'REPLICANT', "got last query from a replicant: $debug{d is $debug{storage_type}, 'REPLICANT', "got last query from a replicant: $debug{dsn}"; } + ## Delete the old database files $replicated->cleanup; diff --git a/t/storage/txn.t b/t/storage/txn.t index 09260f0..efe3641 100644 --- a/t/storage/txn.t +++ b/t/storage/txn.t @@ -26,9 +26,10 @@ my $code = sub { (ref $schema)->txn_do(sub{}); }, qr/storage/, "can't call txn_do without storage"); - throws_ok ( sub { + throws_ok { $schema->txn_do(''); - }, qr/must be a CODE reference/, '$coderef parameter check ok'); + } qr/\Qrun() requires a coderef to execute as its first argument/, + '$coderef parameter check ok'; } # Test successful txn_do() - scalar/list context diff --git a/t/storage/txn_scope_guard.t b/t/storage/txn_scope_guard.t index ca67c98..4a2c14b 100644 --- a/t/storage/txn_scope_guard.t +++ b/t/storage/txn_scope_guard.t @@ -178,8 +178,8 @@ for my $post_poison (0,1) { # this always fails ! $pre_poison or - # I do not underdtand why but on <= 5.8.8 and $pre_poison && $post_poison passes... - $] > 5.008008 + # I do not understand why but on <= 5.8.8 and on 5.10.0 "$pre_poison && $post_poison" passes... + ($] > 5.008008 and $] < 5.010000 ) or $] > 5.010000 )); is (@w, 2, "Both expected warnings found - \$\@ pre-poison: $pre_poison, post-poison: $post_poison" ); @@ -197,51 +197,24 @@ for my $post_poison (0,1) { require Text::Balanced; - my $great_success; - { - local $TODO = 'RT#74994 *STILL* not fixed'; - - lives_ok { - # this is what poisons $@ - Text::Balanced::extract_bracketed( '(foo', '()' ); - - my $s = DBICTest->init_schema( deploy => 0 ); - my $g = $s->txn_scope_guard; - $g->commit; - $great_success++; - } 'Text::Balanced is no longer screwing up $@'; - } - - # delete all of this when T::B dep is bumped - unless ($great_success) { - -# hacky workaround for desperate folk -# intended to be copypasted into your app - { - require Text::Balanced; - require overload; - - local $@; - - # this is what poisons $@ - Text::Balanced::extract_bracketed( '(foo', '()' ); + my @w; + local $SIG{__WARN__} = sub { + $_[0] =~ /External exception object .+? \Qimplements partial (broken) overloading/ + ? push @w, @_ + : warn @_ + }; - if ($@ and overload::Overloaded($@) and ! overload::Method($@,'fallback') ) { - my $class = ref $@; - eval "package $class; overload->import(fallback => 1);" - } - } -# end of hacky workaround + lives_ok { + # this is what poisons $@ + Text::Balanced::extract_bracketed( '(foo', '()' ); - lives_ok { - # this is what poisons $@ - Text::Balanced::extract_bracketed( '(foo', '()' ); + my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); + my $g = $s->txn_scope_guard; + $g->commit; + } 'Broken Text::Balanced is not screwing up txn_guard'; - my $s = DBICTest->init_schema( deploy => 0 ); - my $g = $s->txn_scope_guard; - $g->commit; - } 'Monkeypatched Text::Balanced is no longer screwing up $@'; - } + local $TODO = 'RT#74994 *STILL* not fixed'; + is(scalar @w, 0, 'no warnings \o/'); } done_testing; diff --git a/xt/standalone_testschema_resultclasses.t b/xt/standalone_testschema_resultclasses.t index 38278c0..7ed0381 100644 --- a/xt/standalone_testschema_resultclasses.t +++ b/xt/standalone_testschema_resultclasses.t @@ -1,35 +1,56 @@ use warnings; use strict; +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 DBIx::Class::_Util 'sigwarn_silencer'; use lib 't/lib'; +my $worker = sub { + my $fn = shift; + + if (my @offenders = grep { $_ !~ m{DBIx/Class/(?:_Util|Carp)\.pm} } grep { $_ =~ /(^|\/)DBI/ } keys %INC) { + die "Wtf - DBI* modules present in %INC: @offenders"; + } + + local $SIG{__WARN__} = sigwarn_silencer( qr/\bdeprecated\b/i ); + require( ( $fn =~ m| t/lib/ (.+) |x )[0] ); # untaint and strip lib-part (. is unavailable under -T) + + return 42; +}; + + find({ wanted => sub { return unless ( -f $_ and $_ =~ /\.pm$/ ); - my $pid = fork(); - if (! defined $pid) { - die "fork failed: $!" + 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; + is ($t->join, 42, "Thread loading $_ did not finish successfully") + || diag ($t->can('error') ? $t->error : 'threads.pm too old to retrieve the error :(' ); } - elsif (!$pid) { - if (my @offenders = grep { $_ ne 'DBIx/Class/_Util.pm' } grep { $_ =~ /(^|\/)DBI/ } keys %INC) { - die "Wtf - DBI* modules present in %INC: @offenders"; + else { + my $pid = fork(); + if (! defined $pid) { + die "fork failed: $!" + } + elsif (!$pid) { + $worker->($_); + exit 0; } - local $SIG{__WARN__} = sigwarn_silencer( qr/\bdeprecated\b/i ); - require( ( $_ =~ m| t/lib/ (.+) |x )[0] ); # untaint and strip lib-part (. is unavailable under -T) - exit 0; + is ( waitpid($pid, 0), $pid, "Fork $pid terminated sucessfully"); + my $ex = $? >> 8; + is ( $ex, 0, "Loading $_ ($pid) exitted with $ex" ); } - - is ( waitpid($pid, 0), $pid, "Fork $pid terminated sucessfully"); - my $ex = $? >> 8; - is ( $ex, 0, "Loading $_ ($pid) exitted with $ex" ); }, no_chdir => 1,