From 707f8405bdc0f2b7e3c013db710ab5bfaab7cc88 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 26 Mar 2014 08:11:43 +0100 Subject: [PATCH 001/262] Add progress meter to travis builds --- maint/travis-ci_scripts/common.bash | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/maint/travis-ci_scripts/common.bash b/maint/travis-ci_scripts/common.bash index d50aebb43..9af687721 100755 --- a/maint/travis-ci_scripts/common.bash +++ b/maint/travis-ci_scripts/common.bash @@ -19,9 +19,18 @@ run_or_err() { LASTEXIT=0 START_TIME=$SECONDS + + 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' &" + # the tee is a handy debugging tool when stumpage is exceedingly strong #LASTOUT=$( bash -c "$2" 2>&1 | tee /dev/stderr) || LASTEXIT=$? LASTOUT=$( bash -c "$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 From dabe173af17cc03d112fdf37586e257acc4ef294 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= Date: Fri, 28 Mar 2014 16:48:17 +0000 Subject: [PATCH 002/262] Populate caches for related result sets even if they're empty --- lib/DBIx/Class/ResultSet.pm | 4 ++-- t/prefetch/empty_cache.t | 39 +++++++++++++++++++++++++++++++++++++ 2 files changed, 41 insertions(+), 2 deletions(-) create mode 100644 t/prefetch/empty_cache.t diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index ffade2120..84a2b133d 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -3186,11 +3186,11 @@ sub related_resultset { if (my $cache = $self->get_cache) { my @related_cache = map - { @{$_->related_resultset($rel)->get_cache||[]} } + { $_->related_resultset($rel)->get_cache || () } @$cache ; - $new->set_cache(\@related_cache) if @related_cache; + $new->set_cache([ map @$_, @related_cache ]) if @related_cache == @$cache; } $new; diff --git a/t/prefetch/empty_cache.t b/t/prefetch/empty_cache.t new file mode 100644 index 000000000..9f42d5a11 --- /dev/null +++ b/t/prefetch/empty_cache.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use Test::More; + +use lib qw(t/lib); +use DBICTest; + +my $schema = DBICTest->init_schema(); + +my $queries; +my $debugcb = sub { $queries++; }; +my $orig_debug = $schema->storage->debug; + +{ + $queries = 0; + $schema->storage->debugcb($debugcb); + $schema->storage->debug(1); + + my $cds_rs = $schema->resultset('CD') + ->search(\'0 = 1', { prefetch => 'tracks', cache => 1 }); + + my @cds = $cds_rs->all; + is( $queries, 1, '->all on empty original resultset hit db' ); + is_deeply( $cds_rs->get_cache, [], 'empty cache on original resultset' ); + is( 0+@cds, 0, 'empty original resultset' ); + + my $tracks_rs = $cds_rs->related_resultset('tracks'); + is_deeply( $tracks_rs->get_cache, [], 'empty cache on related resultset' ); + + my @tracks = $tracks_rs->all; + is( $queries, 1, "->all on empty related resultset didn't hit db" ); + is( 0+@tracks, 0, 'empty related resultset' ); + + $schema->storage->debugcb(undef); + $schema->storage->debug($orig_debug); +} + +done_testing; From 1e25c37c2a1b37307c6b151b1672664dfaa10766 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= Date: Mon, 7 Apr 2014 13:29:29 +0100 Subject: [PATCH 003/262] Add Changes entry for empty related cache population With a more user-oriented description than the commit message, i.e. explaining the symptom fixed, rather than the underlying change. --- Changes | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Changes b/Changes index 387cb0a05..71cd4cbfa 100644 --- a/Changes +++ b/Changes @@ -4,6 +4,8 @@ Revision history for DBIx::Class - 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 + - Avoid unnecessary database hits when accessing prefetched related + resultsets with no rows. 0.08270 2014-01-30 21:54 (PST) * Fixes From 2969955b86b7862986fca2bc369785c7a48021cf Mon Sep 17 00:00:00 2001 From: Karen Etheridge Date: Tue, 27 May 2014 16:09:20 -0700 Subject: [PATCH 004/262] spelling fix --- lib/DBIx/Class/ResultSource.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 3233e3ab4..5cb4036f9 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -639,7 +639,7 @@ sub _pri_cols_or_die { } # same as above but mandating single-column PK (used by relationship condition -# inferrence) +# inference) sub _single_pri_col_or_die { my $self = shift; my ($pri, @too_many) = $self->_pri_cols_or_die; From bb99e92d8912469ba2477ef3a9360df84e41b3c2 Mon Sep 17 00:00:00 2001 From: Karen Etheridge Date: Mon, 28 Jul 2014 12:02:23 -0700 Subject: [PATCH 005/262] document including literal SQL and values in a resultset with "columns" --- lib/DBIx/Class/ResultSet.pm | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 84a2b133d..49a490fd1 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -3991,6 +3991,13 @@ is the same as select => [qw/foo baz/], as => [qw/foo bar/] +Like elsewhere, literal SQL or literal values can be included by +using a scalar reference, and these values will be available in the result +with C: + + # equivalent SQL: SELECT 1, "a string", IF(x,1,2) ... + columns => [ { foo => \1, bar => \'"a string"', baz => \'IF(x,1,2)' } ] + =head2 +columns =over 4 From fcc901c7fabd7c01defd0ce93fbbec45aefce86a Mon Sep 17 00:00:00 2001 From: Karen Etheridge Date: Mon, 28 Jul 2014 12:08:11 -0700 Subject: [PATCH 006/262] use standard '' quoting for string literals --- lib/DBIx/Class/ResultSet.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 49a490fd1..2c831b1c0 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -3995,8 +3995,8 @@ Like elsewhere, literal SQL or literal values can be included by using a scalar reference, and these values will be available in the result with C: - # equivalent SQL: SELECT 1, "a string", IF(x,1,2) ... - columns => [ { foo => \1, bar => \'"a string"', baz => \'IF(x,1,2)' } ] + # equivalent SQL: SELECT 1, 'a string', IF(x,1,2) ... + columns => [ { foo => \1, bar => \q{'a string'}, baz => \'IF(x,1,2)' } ] =head2 +columns From 83d2991997f6070366d3d2bcd3f1bcc07562b930 Mon Sep 17 00:00:00 2001 From: Karen Etheridge Date: Mon, 28 Jul 2014 12:13:30 -0700 Subject: [PATCH 007/262] show more ways to include literal bind values --- lib/DBIx/Class/ResultSet.pm | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 2c831b1c0..c799da793 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -3991,12 +3991,19 @@ is the same as select => [qw/foo baz/], as => [qw/foo bar/] -Like elsewhere, literal SQL or literal values can be included by -using a scalar reference, and these values will be available in the result -with C: +Like elsewhere, literal SQL or literal values can be included by using a +scalar reference or a literal bind value, and these values will be available +in the result with C (see also +L): # equivalent SQL: SELECT 1, 'a string', IF(x,1,2) ... - columns => [ { foo => \1, bar => \q{'a string'}, baz => \'IF(x,1,2)' } ] + columns => [ + { + foo => \1, + bar => \q{'a string'}, + baz => \[ '?', 'IF(x,1,2)' ], + } + ] =head2 +columns From 4e4b848d72799014662362db1ef3af20c702ba66 Mon Sep 17 00:00:00 2001 From: Karen Etheridge Date: Wed, 8 Oct 2014 12:42:49 -0700 Subject: [PATCH 008/262] cross-reference alias with current_source_alias --- lib/DBIx/Class/ResultSet.pm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index c799da793..32b3be4c3 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -3232,6 +3232,8 @@ source alias of the current result set: }); } +The current table alias can be altered with L. + =cut sub current_source_alias { From dbfb29f0609a5eef347d81b8fdb9b7cce222970f Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 29 Feb 2016 12:50:54 +0100 Subject: [PATCH 009/262] (optdep) last-from-block is a compile-time warning, silence properly Without this we do get warnings under RELEASE_TESTING=1 as warnings are then enabled file-wide --- lib/DBIx/Class/Optional/Dependencies.pm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm index a7ab5e5bc..786828a7d 100644 --- a/lib/DBIx/Class/Optional/Dependencies.pm +++ b/lib/DBIx/Class/Optional/Dependencies.pm @@ -861,7 +861,9 @@ sub skip_without { if ( my $err = $self->req_missing_for($groups) ) { my ($fn, $ln) = (caller(0))[1,2]; $tb->skip("block in $fn around line $ln requires $err"); - local $^W = 0; + + BEGIN { ${^WARNING_BITS} = "" } + last SKIP; } From 970ed9a14ced481ba1011b2ed68fa9d8a4c2d5ae Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 28 Feb 2016 14:04:08 +0100 Subject: [PATCH 010/262] Revert part of bbcc1fe8 - the 'queue unstick hack' belongs in DBICTest DBICTest::Util is more likely to be loaded before Test::More, voiding the check in the BEGIN. DBICTest on the other hand is almost invariably loaded after T::M. --- t/lib/DBICTest.pm | 19 +++++++++++++++++++ t/lib/DBICTest/Util.pm | 14 -------------- 2 files changed, 19 insertions(+), 14 deletions(-) diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index c0c91c276..849caa1d7 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -4,6 +4,25 @@ package # hide from PAUSE use strict; use warnings; + +# this noop trick initializes the STDOUT, so that the TAP::Harness +# issued IO::Select->can_read calls (which are blocking wtf wtf wtf) +# keep spinning and scheduling jobs +# This results in an overall much smoother job-queue drainage, since +# the Harness blocks less +# (ideally this needs to be addressed in T::H, but a quick patchjob +# broke everything so tabling it for now) +BEGIN { + # FIXME - there probably is some way to determine a harness run (T::H or + # prove) but I do not know it offhand, especially on older environments + # Go with the safer option + if ($INC{'Test/Builder.pm'}) { + local $| = 1; + print "#\n"; + } +} + + use DBICTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); use DBICTest::Schema; use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index f747210c0..37c79166b 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -3,20 +3,6 @@ package DBICTest::Util; use warnings; use strict; -# this noop trick initializes the STDOUT, so that the TAP::Harness -# issued IO::Select->can_read calls (which are blocking wtf wtf wtf) -# keep spinning and scheduling jobs -# This results in an overall much smoother job-queue drainage, since -# the Harness blocks less -# (ideally this needs to be addressed in T::H, but a quick patchjob -# broke everything so tabling it for now) -BEGIN { - if ($INC{'Test/Builder.pm'}) { - local $| = 1; - print "#\n"; - } -} - use constant DEBUG_TEST_CONCURRENCY_LOCKS => ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0] || From e3be2b6ff05d6794ccd8807af8cb494403690639 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 28 Feb 2016 13:37:46 +0100 Subject: [PATCH 011/262] Move find_co_root into DBICTest::Util This is the first step of rearranging the utility pieces, removing reliance on Path::Class in general No visible functional changes, the old sub _find_co_root left as-is for the time being, with an eval wrapped around it to retain the old "best effort" behavior. Will be revisited in subsequent commits. --- lib/DBIx/Class/_Util.pm | 43 +++++++++++++++++++++++++++++++++++++++ t/lib/DBICTest/RunMode.pm | 30 +++++---------------------- t/lib/DBICTest/Util.pm | 41 +++++++++++++++++++++++++++++++++++-- xt/extra/lean_startup.t | 1 + 4 files changed, 88 insertions(+), 27 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 4afa4c225..846920df4 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -82,6 +82,7 @@ our @EXPORT_OK = qw( scope_guard detected_reinvoked_destructor is_exception dbic_internal_try quote_sub qsub perlstring serialize deep_clone + parent_dir UNRESOLVABLE_CONDITION ); @@ -409,6 +410,48 @@ sub modver_gt_or_eq_and_lt ($$$) { ) ? 1 : 0; } + +# +# Why not just use some higher-level module or at least File::Spec here? +# Because: +# 1) This is a *very* rarely used function, and the deptree is large +# enough already as it is +# +# 2) (more importantly) Our tooling is utter shit in this area. There +# is no comprehensive support for UNC paths in PathTools and there +# are also various small bugs in representation across different +# path-manipulation CPAN offerings. +# +# Since this routine is strictly used for logical path processing (it +# *must* be able to work with not-yet-existing paths), use this seemingly +# simple but I *think* complete implementation to feed to other consumers +# +# If bugs are ever uncovered in this routine, *YOU ARE URGED TO RESIST* +# the impulse to bring in an external dependency. During runtime there +# is exactly one spot that could potentially maybe once in a blue moon +# use this function. Keep it lean. +# +sub parent_dir ($) { + ( $_[0] =~ m{ [\/\\] ( \.{0,2} ) ( [\/\\]* ) \z }x ) + ? ( + $_[0] + . + ( ( length($1) and ! length($2) ) ? '/' : '' ) + . + '../' + ) + : ( + require File::Spec + and + File::Spec->catpath ( + ( File::Spec->splitpath( "$_[0]" ) )[0,1], + '/', + ) + ) + ; +} + + { my $list_ctx_ok_stack_marker; diff --git a/t/lib/DBICTest/RunMode.pm b/t/lib/DBICTest/RunMode.pm index 93f917c5b..590abde0e 100644 --- a/t/lib/DBICTest/RunMode.pm +++ b/t/lib/DBICTest/RunMode.pm @@ -66,7 +66,11 @@ use Path::Class qw/file dir/; use Fcntl ':DEFAULT'; use File::Spec (); use File::Temp (); -use DBICTest::Util 'local_umask'; +use DBICTest::Util qw( local_umask find_co_root ); + +# Try to determine the root of a checkout/untar if possible +# return a Path::Class::Dir object or undef +sub _find_co_root { eval { dir( find_co_root() ) } } _check_author_makefile() unless $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}; @@ -271,28 +275,4 @@ sub is_plain { ) } -# Try to determine the root of a checkout/untar if possible -# or return undef -sub _find_co_root { - - my @mod_parts = split /::/, (__PACKAGE__ . '.pm'); - my $rel_path = join ('/', @mod_parts); # %INC stores paths with / regardless of OS - - return undef unless ($INC{$rel_path}); - - # a bit convoluted, but what we do here essentially is: - # - get the file name of this particular module - # - do 'cd ..' as many times as necessary to get to t/lib/../.. - - my $root = dir ($INC{$rel_path}); - for (1 .. @mod_parts + 2) { - $root = $root->parent; - } - - return (-f $root->file ('Makefile.PL') ) - ? $root - : undef - ; -} - 1; diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 37c79166b..27f7527c3 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -13,12 +13,12 @@ use Config; use Carp qw(cluck confess croak); use Fcntl ':flock'; use Scalar::Util qw(blessed refaddr); -use DBIx::Class::_Util 'scope_guard'; +use DBIx::Class::_Util qw( scope_guard parent_dir ); use base 'Exporter'; our @EXPORT_OK = qw( dbg stacktrace - local_umask + local_umask find_co_root visit_namespaces check_customcond_args await_flock DEBUG_TEST_CONCURRENCY_LOCKS @@ -98,6 +98,43 @@ sub local_umask ($) { }); } +# Try to determine the root of a checkout/untar if possible +# OR throws an exception +my $co_root; +sub find_co_root () { + + $co_root ||= do { + + my @mod_parts = split /::/, (__PACKAGE__ . '.pm'); + my $inc_key = join ('/', @mod_parts); # %INC stores paths with / regardless of OS + + # a bit convoluted, but what we do here essentially is: + # - get the file name of this particular module + # - do 'cd ..' as many times as necessary to get to t/lib/../.. + + my $root = $INC{$inc_key} + or croak "\$INC{'$inc_key'} seems to be missing, this can't happen..."; + + $root = parent_dir $root + for 1 .. @mod_parts + 2; + + # do the check twice so that the exception is more informative in the + # very unlikely case of realpath returning garbage + # (Paththools are in really bad shape - handholding all the way down) + for my $call_realpath (0,1) { + + require Cwd and $root = ( Cwd::realpath($root) . '/' ) + if $call_realpath; + + croak "Unable to find root of DBIC checkout/untar: '${root}Makefile.PL' does not exist" + unless -f "${root}Makefile.PL"; + } + + $root; + } +} + + sub stacktrace { my $frame = shift; $frame++; diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index 8c220dd74..2a5c8d5ea 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -110,6 +110,7 @@ BEGIN { Sub::Defer Sub::Quote + File::Spec Scalar::Util List::Util Storable From c0329273268971824784f239f32c7246e68da9c5 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 29 Feb 2016 11:35:26 +0100 Subject: [PATCH 012/262] Institute a central "load this first in testing" package Instead of the hodge-podge of "what loads first where" make a verified focal package and move some of the stuff within DBICTest::RunMode there There are no other changes aside from the load order --- .../56_autogen_schema_files.pl | 2 +- t/00describe_environment.t | 4 +- t/05components.t | 4 +- t/100extra_source.t | 4 +- t/100populate.t | 4 +- t/101populate_rs.t | 4 +- t/101source.t | 4 +- t/102load_classes.t | 4 +- t/104view.t | 4 +- t/106dbic_carp.t | 4 +- t/107obj_result_class.t | 4 +- t/18insert_default.t | 4 +- t/19retrieve_on_insert.t | 4 +- t/20setuperrors.t | 4 +- t/26dumper.t | 4 +- t/33exception_wrap.t | 4 +- t/34exception_action.t | 4 +- t/35exception_inaction.t | 4 +- t/39load_namespaces_1.t | 4 +- t/39load_namespaces_2.t | 4 +- t/39load_namespaces_3.t | 4 +- t/39load_namespaces_4.t | 4 +- t/39load_namespaces_exception.t | 4 +- t/39load_namespaces_rt41083.t | 4 +- t/39load_namespaces_stress.t | 4 +- t/40compose_connection.t | 4 +- t/46where_attribute.t | 4 +- t/50fork.t | 3 +- t/51threadnodb.t | 3 +- t/51threads.t | 4 +- t/51threadtxn.t | 4 +- t/52leaks.t | 4 +- t/54taint.t | 2 + t/60core.t | 4 +- t/61findnot.t | 4 +- t/63register_class.t | 4 +- t/63register_column.t | 4 +- t/63register_source.t | 4 +- t/64db.t | 4 +- t/65multipk.t | 4 +- t/67pager.t | 4 +- t/69update.t | 4 +- t/70auto.t | 4 +- t/71mysql.t | 3 +- t/72pg.t | 3 +- t/72pg_bytea.t | 3 +- t/73oracle.t | 2 +- t/73oracle_blob.t | 3 +- t/73oracle_hq.t | 3 +- t/745db2.t | 3 +- t/746db2_400.t | 3 +- t/746mssql.t | 3 +- t/746sybase.t | 2 +- t/747mssql_ado.t | 3 +- t/748informix.t | 3 +- t/749sqlanywhere.t | 4 +- t/74mssql.t | 3 +- t/750firebird.t | 4 +- t/751msaccess.t | 4 +- t/752sqlite.t | 4 +- t/76joins.t | 3 +- t/76select.t | 4 +- t/77join_count.t | 4 +- t/78self_referencial.t | 4 +- t/79aliasing.t | 4 +- t/80unique.t | 4 +- t/82cascade_copy.t | 4 +- t/83cache.t | 4 +- t/84serialize.t | 4 +- t/85utf8.t | 4 +- t/86might_have.t | 4 +- t/86sqlt.t | 3 +- t/87ordered.t | 4 +- t/88result_set_column.t | 4 +- t/90join_torture.t | 4 +- t/93autocast.t | 4 +- t/93single_accessor_object.t | 4 +- t/94pk_mutation.t | 4 +- t/94versioning.t | 3 +- t/97result_class.t | 4 +- t/99dbic_sqlt_parser.t | 3 +- t/admin/02ddl.t | 3 +- t/admin/03data.t | 3 +- t/cdbi/01-columns.t | 1 + t/cdbi/02-Film.t | 1 + t/cdbi/03-subclassing.t | 1 + t/cdbi/04-lazy.t | 1 + t/cdbi/06-hasa.t | 1 + t/cdbi/08-inheritcols.t | 1 + t/cdbi/09-has_many.t | 1 + t/cdbi/11-triggers.t | 1 + t/cdbi/12-filter.t | 1 + t/cdbi/13-constraint.t | 1 + t/cdbi/14-might_have.t | 1 + t/cdbi/15-accessor.t | 1 + t/cdbi/16-reserved.t | 1 + t/cdbi/18-has_a.t | 1 + t/cdbi/19-set_sql.t | 1 + t/cdbi/21-iterator.t | 1 + t/cdbi/22-deflate_order.t | 1 + t/cdbi/22-self_referential.t | 1 + t/cdbi/23-cascade.t | 1 + t/cdbi/24-meta_info.t | 1 + t/cdbi/26-mutator.t | 1 + t/cdbi/30-pager.t | 1 + t/cdbi/68-inflate_has_a.t | 3 +- t/cdbi/70_implicit_inflate.t | 1 + t/cdbi/71_column_object.t | 2 + t/cdbi/98-failure.t | 1 + t/cdbi/DeepAbstractSearch/01_search.t | 2 +- t/cdbi/abstract/search_where.t | 1 + t/cdbi/columns_as_hashes.t | 1 + .../columns_dont_override_custom_accessors.t | 1 + t/cdbi/construct.t | 1 + t/cdbi/copy.t | 1 + t/cdbi/early_column_heisenbug.t | 1 + t/cdbi/has_many_loads_foreign_class.t | 1 + t/cdbi/hasa_without_loading.t | 1 + t/cdbi/max_min_value_of.t | 1 + t/cdbi/mk_group_accessors.t | 1 + t/cdbi/multi_column_set.t | 1 + t/cdbi/object_cache.t | 1 + t/cdbi/retrieve_from_sql_with_limit.t | 1 + t/cdbi/set_to_undef.t | 1 + t/cdbi/set_vs_DateTime.t | 1 + t/cdbi/sweet/08pager.t | 3 +- t/cdbi/testlib/DBIC/Test/SQLite.pm | 1 - t/cdbi/testlib/MyBase.pm | 2 - t/count/count_rs.t | 4 +- t/count/distinct.t | 4 +- t/count/group_by_func.t | 5 +- t/count/grouped_pager.t | 5 +- t/count/in_subquery.t | 4 +- t/count/joined.t | 5 +- t/count/prefetch.t | 4 +- t/count/search_related.t | 5 +- t/delete/cascade_missing.t | 4 +- t/delete/complex.t | 4 +- t/delete/m2m.t | 4 +- t/delete/related.t | 4 +- t/icdt/core.t | 3 +- t/icdt/datetime_missing_deps.t | 4 +- t/icdt/engine_specific/firebird.t | 3 +- t/icdt/engine_specific/informix.t | 3 +- t/icdt/engine_specific/msaccess.t | 3 +- t/icdt/engine_specific/mssql.t | 3 +- t/icdt/engine_specific/oracle.t | 3 +- t/icdt/engine_specific/sqlanywhere.t | 3 +- t/icdt/engine_specific/sqlite.t | 3 +- t/icdt/engine_specific/sybase.t | 3 +- t/icdt/offline_mysql.t | 3 +- t/icdt/offline_pg.t | 3 +- t/inflate/file_column.t | 5 +- t/inflate/hri.t | 4 +- t/inflate/hri_torture.t | 4 +- t/inflate/serialize.t | 4 +- t/lib/ANFANG.pm | 126 ++++++++++++++++++ t/lib/DBICTest.pm | 11 +- t/lib/DBICTest/Base.pm | 3 +- t/lib/DBICTest/RunMode.pm | 58 -------- t/lib/DBICTest/Schema.pm | 3 + t/lib/DBICTest/Util.pm | 2 + t/lib/DBICTest/Util/LeakTracer.pm | 2 + t/multi_create/cd_single.t | 4 +- t/multi_create/diamond.t | 4 +- t/multi_create/existing_in_chain.t | 4 +- t/multi_create/find_or_multicreate.t | 4 +- t/multi_create/has_many.t | 4 +- t/multi_create/in_memory.t | 4 +- t/multi_create/insert_defaults.t | 4 +- t/multi_create/m2m.t | 4 +- t/multi_create/multilev_single_PKeqFK.t | 4 +- t/multi_create/standard.t | 4 +- t/multi_create/torture.t | 4 +- t/ordered/cascade_delete.t | 4 +- t/ordered/unordered_movement.t | 4 +- t/prefetch/attrs_untouched.t | 4 +- t/prefetch/correlated.t | 4 +- t/prefetch/count.t | 4 +- t/prefetch/diamond.t | 4 +- t/prefetch/double_prefetch.t | 4 +- t/prefetch/empty_cache.t | 4 +- t/prefetch/false_colvalues.t | 4 +- t/prefetch/grouped.t | 3 +- t/prefetch/incomplete.t | 4 +- t/prefetch/join_type.t | 4 +- t/prefetch/lazy_cursor.t | 4 +- t/prefetch/manual.t | 4 +- t/prefetch/multiple_hasmany.t | 4 +- t/prefetch/multiple_hasmany_torture.t | 4 +- t/prefetch/o2m_o2m_order_by_with_limit.t | 4 +- t/prefetch/one_to_many_to_one.t | 4 +- t/prefetch/refined_search_on_relation.t | 4 +- t/prefetch/restricted_children_set.t | 4 +- t/prefetch/standard.t | 4 +- t/prefetch/via_search_related.t | 4 +- t/prefetch/with_limit.t | 4 +- t/relationship/after_update.t | 4 +- t/relationship/core.t | 4 +- t/relationship/custom.t | 4 +- t/relationship/custom_opaque.t | 4 +- t/relationship/custom_with_null_in_cond.t | 4 +- t/relationship/doesnt_exist.t | 4 +- t/relationship/dynamic_foreign_columns.t | 4 +- t/relationship/info.t | 4 +- t/relationship/proxy.t | 4 +- .../resolve_relationship_condition.t | 4 +- t/relationship/set_column_on_fk.t | 4 +- t/relationship/update_or_create_multi.t | 4 +- t/relationship/update_or_create_single.t | 4 +- t/resultset/as_query.t | 4 +- t/resultset/as_subselect_rs.t | 4 +- t/resultset/bind_attr.t | 4 +- t/resultset/create_with_rs_inherited_values.t | 4 +- t/resultset/find_on_subquery_cond.t | 4 +- t/resultset/inflate_result_api.t | 4 +- t/resultset/inflatemap_abuse.t | 4 +- t/resultset/is_ordered.t | 4 +- t/resultset/is_paged.t | 4 +- t/resultset/nulls_only.t | 4 +- t/resultset/plus_select.t | 4 +- t/resultset/rowparser_internals.t | 4 +- t/resultset/update_delete.t | 3 +- t/resultset_class.t | 5 +- t/resultset_overload.t | 4 +- t/resultsource/bare_resultclass_exception.t | 3 +- t/resultsource/set_primary_key.t | 4 +- t/row/copy_with_extra_selection.t | 4 +- t/row/filter_column.t | 4 +- t/row/find_one_has_many.t | 4 +- t/row/inflate_result.t | 4 +- t/row/pkless.t | 4 +- t/row/set_extra_column.t | 4 +- t/row/sourceless.t | 4 +- t/schema/anon.t | 4 +- t/schema/clone.t | 4 +- t/search/distinct.t | 4 +- t/search/empty_attrs.t | 4 +- t/search/preserve_original_rs.t | 4 +- t/search/reentrancy.t | 4 +- t/search/related_has_many.t | 4 +- t/search/related_strip_prefetch.t | 4 +- t/search/select_chains.t | 4 +- t/search/select_chains_unbalanced.t | 4 +- t/search/stack_cond.t | 4 +- t/search/subquery.t | 4 +- t/sqlmaker/bind_transport.t | 4 +- t/sqlmaker/core.t | 3 +- t/sqlmaker/core_quoted.t | 4 +- t/sqlmaker/dbihacks_internals.t | 4 +- t/sqlmaker/hierarchical/oracle.t | 2 +- t/sqlmaker/legacy_joins.t | 4 +- t/sqlmaker/limit_dialects/basic.t | 4 +- t/sqlmaker/limit_dialects/custom.t | 4 +- t/sqlmaker/limit_dialects/fetch_first.t | 4 +- t/sqlmaker/limit_dialects/first_skip.t | 4 +- t/sqlmaker/limit_dialects/generic_subq.t | 4 +- t/sqlmaker/limit_dialects/mssql_torture.t | 4 +- t/sqlmaker/limit_dialects/rno.t | 4 +- t/sqlmaker/limit_dialects/rownum.t | 4 +- t/sqlmaker/limit_dialects/skip_first.t | 4 +- t/sqlmaker/limit_dialects/toplimit.t | 4 +- t/sqlmaker/limit_dialects/torture.t | 4 +- t/sqlmaker/literal_with_bind.t | 4 +- t/sqlmaker/msaccess.t | 4 +- t/sqlmaker/mysql.t | 4 +- t/sqlmaker/nest_deprec.t | 4 +- t/sqlmaker/oracle.t | 3 +- t/sqlmaker/oraclejoin.t | 2 +- t/sqlmaker/order_by_bindtransport.t | 4 +- t/sqlmaker/order_by_func.t | 4 +- t/sqlmaker/quotes.t | 4 +- t/sqlmaker/sqlite.t | 4 +- t/storage/base.t | 4 +- t/storage/cursor.t | 4 +- t/storage/dbh_do.t | 4 +- t/storage/dbi_coderef.t | 4 +- t/storage/dbi_env.t | 4 +- t/storage/dbic_pretty.t | 3 +- t/storage/debug.t | 4 +- t/storage/deploy.t | 3 +- .../deprecated_exception_source_bind_attrs.t | 4 +- t/storage/disable_sth_caching.t | 4 +- t/storage/error.t | 4 +- t/storage/exception.t | 4 +- t/storage/global_destruction.t | 4 +- t/storage/nobindvars.t | 4 +- t/storage/on_connect_call.t | 4 +- t/storage/on_connect_do.t | 4 +- t/storage/ping_count.t | 4 +- t/storage/prefer_stringification.t | 4 +- t/storage/quote_names.t | 4 +- t/storage/reconnect.t | 4 +- t/storage/replicated.t | 3 +- t/storage/savepoints.t | 4 +- t/storage/stats.t | 4 +- t/storage/txn.t | 4 +- t/storage/txn_scope_guard.t | 4 +- t/update/all.t | 4 +- t/update/ident_cond.t | 4 +- t/update/type_aware.t | 4 +- t/zzzzzzz_authors.t | 4 +- t/zzzzzzz_perl_perf_bug.t | 4 +- xt/dist/authors.t | 2 + ...able_standalone_testschema_resultclasses.t | 10 +- xt/dist/pod_coverage.t | 3 +- xt/dist/postdistdir/pod_validity.t | 3 +- xt/dist/postdistdir/whitespace.t | 3 +- xt/dist/strictures.t | 7 +- xt/extra/c3_mro.t | 4 +- xt/extra/dbicadmin.t | 18 +-- .../diagnostics/deprecated_rs_attributes.t | 4 +- .../diagnostics/malformed_rel_declaration.t | 4 +- xt/extra/diagnostics/many_to_many_warning.t | 4 +- xt/extra/diagnostics/resultset_manager.t | 4 +- xt/extra/diagnostics/search_in_void_ctx.t | 4 +- .../diagnostics/unresolvable_relationship.t | 4 +- xt/extra/internals/dbictest_unlink_guard.t | 4 +- .../internals/discard_changes_in_DESTROY.t | 4 +- xt/extra/internals/ensure_class_loaded.t | 4 +- xt/extra/internals/merge_joinpref_attr.t | 4 +- xt/extra/internals/namespaces_cleaned.t | 6 +- xt/extra/lean_startup.t | 2 + xt/extra/multicreate_opcount.t | 4 +- xt/extra/sqlite_deadlock.t | 4 +- xt/extra/sqlite_view_deps.t | 3 +- 326 files changed, 951 insertions(+), 375 deletions(-) create mode 100644 t/lib/ANFANG.pm diff --git a/maint/Makefile.PL.inc/56_autogen_schema_files.pl b/maint/Makefile.PL.inc/56_autogen_schema_files.pl index 6096010f6..0cd34a035 100644 --- a/maint/Makefile.PL.inc/56_autogen_schema_files.pl +++ b/maint/Makefile.PL.inc/56_autogen_schema_files.pl @@ -1,6 +1,6 @@ require File::Spec; my $test_ddl_fn = File::Spec->catfile(qw( t lib sqlite.sql )); -my @test_ddl_cmd = qw( -I lib -I t/lib -- maint/gen_sqlite_schema_files --schema-class DBICTest::Schema ); +my @test_ddl_cmd = qw( -I lib -Mt::lib::ANFANG -- maint/gen_sqlite_schema_files --schema-class DBICTest::Schema ); my $example_ddl_fn = File::Spec->catfile(qw( examples Schema db example.sql )); my $example_db_fn = File::Spec->catfile(qw( examples Schema db example.db )); diff --git a/t/00describe_environment.t b/t/00describe_environment.t index 35e6b02f4..a88c18741 100644 --- a/t/00describe_environment.t +++ b/t/00describe_environment.t @@ -11,9 +11,9 @@ BEGIN { @initial_INC = @INC; } -BEGIN { - unshift @INC, 't/lib'; +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } +BEGIN { if ( "$]" < 5.010) { # Pre-5.10 perls pollute %INC on unsuccesfull module diff --git a/t/05components.t b/t/05components.t index 63138635a..b6f2c3e3a 100644 --- a/t/05components.t +++ b/t/05components.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; use DBICTest::ForeignComponent; diff --git a/t/100extra_source.t b/t/100extra_source.t index 490bbeccb..b345ce16c 100644 --- a/t/100extra_source.t +++ b/t/100extra_source.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; { diff --git a/t/100populate.t b/t/100populate.t index 4b7f9292d..2817e5b2b 100644 --- a/t/100populate.t +++ b/t/100populate.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest; use DBIx::Class::_Util qw(sigwarn_silencer serialize); use Math::BigInt; diff --git a/t/101populate_rs.t b/t/101populate_rs.t index 5686c3ec4..7f356d9df 100644 --- a/t/101populate_rs.t +++ b/t/101populate_rs.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + ## ---------------------------------------------------------------------------- ## Tests for the $resultset->populate method. ## @@ -14,7 +16,7 @@ use warnings; use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; diff --git a/t/101source.t b/t/101source.t index 477a4dd8b..889945b98 100644 --- a/t/101source.t +++ b/t/101source.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema; diff --git a/t/102load_classes.t b/t/102load_classes.t index 893601498..ef99b3aec 100644 --- a/t/102load_classes.t +++ b/t/102load_classes.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib 't/lib'; + use DBICTest; my $warnings; diff --git a/t/104view.t b/t/104view.t index 4abe7e82a..a3668b2b4 100644 --- a/t/104view.t +++ b/t/104view.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/106dbic_carp.t b/t/106dbic_carp.t index f6bd91d8a..171e7db1f 100644 --- a/t/106dbic_carp.t +++ b/t/106dbic_carp.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -7,7 +9,7 @@ BEGIN { $ENV{DBIC_TRACE} = 0 } use Test::More; use Test::Warn; use Test::Exception; -use lib 't/lib'; + use DBICTest; use DBIx::Class::Carp; diff --git a/t/107obj_result_class.t b/t/107obj_result_class.t index f616bcbbc..d09d5c2bb 100644 --- a/t/107obj_result_class.t +++ b/t/107obj_result_class.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + package ResultClassInflator; sub new { bless {}, __PACKAGE__ } @@ -11,7 +13,7 @@ use warnings; use Test::More tests => 6; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/18insert_default.t b/t/18insert_default.t index 17657cc66..db8fb5663 100644 --- a/t/18insert_default.t +++ b/t/18insert_default.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/19retrieve_on_insert.t b/t/19retrieve_on_insert.t index d25818066..c8ecf34b2 100644 --- a/t/19retrieve_on_insert.t +++ b/t/19retrieve_on_insert.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/20setuperrors.t b/t/20setuperrors.t index ede7e294a..609581749 100644 --- a/t/20setuperrors.t +++ b/t/20setuperrors.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; use Test::Exception; -use lib 't/lib'; + use DBICTest; throws_ok ( diff --git a/t/26dumper.t b/t/26dumper.t index ade503184..c964655c3 100644 --- a/t/26dumper.t +++ b/t/26dumper.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; @@ -5,7 +7,7 @@ use Test::More; use Data::Dumper; $Data::Dumper::Sortkeys = 1; -use lib qw(t/lib); + use_ok('DBICTest'); my $schema = DBICTest->init_schema(); diff --git a/t/33exception_wrap.t b/t/33exception_wrap.t index 3b351ab9d..0acc6901f 100644 --- a/t/33exception_wrap.t +++ b/t/33exception_wrap.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -5,8 +7,6 @@ use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); - use DBICTest; my $schema = DBICTest->init_schema; diff --git a/t/34exception_action.t b/t/34exception_action.t index d7885d5e2..c9c0f6b81 100644 --- a/t/34exception_action.t +++ b/t/34exception_action.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest; # Set up the "usual" sqlite for DBICTest diff --git a/t/35exception_inaction.t b/t/35exception_inaction.t index 0d8597f94..ffbabc543 100644 --- a/t/35exception_inaction.t +++ b/t/35exception_inaction.t @@ -1,7 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib 't/lib'; + use DBICTest::RunMode; BEGIN { if( DBICTest::RunMode->is_plain ) { diff --git a/t/39load_namespaces_1.t b/t/39load_namespaces_1.t index 0f8ae1ee9..c6355a718 100644 --- a/t/39load_namespaces_1.t +++ b/t/39load_namespaces_1.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; # do not remove even though it is not used my $warnings; diff --git a/t/39load_namespaces_2.t b/t/39load_namespaces_2.t index d9b88fa9f..e38dfd594 100644 --- a/t/39load_namespaces_2.t +++ b/t/39load_namespaces_2.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; # do not remove even though it is not used plan tests => 6; diff --git a/t/39load_namespaces_3.t b/t/39load_namespaces_3.t index 99ad8a952..144feb6cb 100644 --- a/t/39load_namespaces_3.t +++ b/t/39load_namespaces_3.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest; # do not remove even though it is not used lives_ok (sub { diff --git a/t/39load_namespaces_4.t b/t/39load_namespaces_4.t index 1bdc49d56..d0e82ed71 100644 --- a/t/39load_namespaces_4.t +++ b/t/39load_namespaces_4.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; # do not remove even though it is not used plan tests => 6; diff --git a/t/39load_namespaces_exception.t b/t/39load_namespaces_exception.t index c5a03df6e..e0d65ece5 100644 --- a/t/39load_namespaces_exception.t +++ b/t/39load_namespaces_exception.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; # do not remove even though it is not used plan tests => 1; diff --git a/t/39load_namespaces_rt41083.t b/t/39load_namespaces_rt41083.t index 258429031..0e33420ea 100644 --- a/t/39load_namespaces_rt41083.t +++ b/t/39load_namespaces_rt41083.t @@ -1,7 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib 't/lib'; + use DBICTest; # do not remove even though it is not used use Test::More tests => 8; diff --git a/t/39load_namespaces_stress.t b/t/39load_namespaces_stress.t index db178ee2a..b688669c8 100644 --- a/t/39load_namespaces_stress.t +++ b/t/39load_namespaces_stress.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Time::HiRes qw/gettimeofday/; -use lib qw(t/lib); + use DBICTest; # do not remove even though it is not used our $src_count = 100; diff --git a/t/40compose_connection.t b/t/40compose_connection.t index 051ab9ba3..2732a5e62 100644 --- a/t/40compose_connection.t +++ b/t/40compose_connection.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; warnings_exist { DBICTest->init_schema( compose_connection => 1, sqlite_use_file => 1 ) } diff --git a/t/46where_attribute.t b/t/46where_attribute.t index f798ace4e..ba1c7d09e 100644 --- a/t/46where_attribute.t +++ b/t/46where_attribute.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/50fork.t b/t/50fork.t index a9fbdec88..c3c60ec88 100644 --- a/t/50fork.t +++ b/t/50fork.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_pg'; use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $main_pid = $$; diff --git a/t/51threadnodb.t b/t/51threadnodb.t index 3af78d575..4e242f555 100644 --- a/t/51threadnodb.t +++ b/t/51threadnodb.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use Config; BEGIN { unless ($Config{useithreads}) { @@ -17,7 +19,6 @@ use warnings; use Test::More; use DBIx::Class::_Util 'sigwarn_silencer'; -use lib qw(t/lib); use DBICTest; plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' diff --git a/t/51threads.t b/t/51threads.t index ae3addc49..0f24f7ece 100644 --- a/t/51threads.t +++ b/t/51threads.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use Config; BEGIN { unless ($Config{useithreads}) { @@ -23,7 +25,7 @@ use Test::Exception; plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' if "$]" < 5.008005; -use lib qw(t/lib); + use DBICTest; # README: If you set the env var to a number greater than 10, diff --git a/t/51threadtxn.t b/t/51threadtxn.t index e74c7c175..3e285cace 100644 --- a/t/51threadtxn.t +++ b/t/51threadtxn.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + # README: If you set the env var to a number greater than 10, # we will use that many children @@ -26,7 +28,7 @@ plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' if "$]" < 5.008005; use Scalar::Util 'weaken'; -use lib qw(t/lib); + use DBICTest; my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; diff --git a/t/52leaks.t b/t/52leaks.t index c6b64c261..b61856d67 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + # work around brain damage in PPerl (yes, it has to be a global) $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /\QUse of "goto" to jump into a construct is deprecated/ @@ -21,7 +23,7 @@ use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest::RunMode; use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs); use Scalar::Util qw(weaken blessed reftype); diff --git a/t/54taint.t b/t/54taint.t index 6b866e6d1..fbf028666 100644 --- a/t/54taint.t +++ b/t/54taint.t @@ -1,3 +1,5 @@ +BEGIN { $ENV{DBICTEST_ANFANG_DEFANG} = 1 } + use strict; use warnings; use Config; diff --git a/t/60core.t b/t/60core.t index 595df62d1..d01a5fd8d 100644 --- a/t/60core.t +++ b/t/60core.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/61findnot.t b/t/61findnot.t index ab709e365..e9fe1ac75 100644 --- a/t/61findnot.t +++ b/t/61findnot.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/63register_class.t b/t/63register_class.t index 63704644e..0229713f0 100644 --- a/t/63register_class.t +++ b/t/63register_class.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More tests => 2; -use lib qw(t/lib); + use DBICTest; use DBICTest::Schema; use DBICTest::Schema::Artist; diff --git a/t/63register_column.t b/t/63register_column.t index 21de95d54..7f5d2c3a1 100644 --- a/t/63register_column.t +++ b/t/63register_column.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; lives_ok { diff --git a/t/63register_source.t b/t/63register_source.t index 6951962a8..b4eb206d3 100644 --- a/t/63register_source.t +++ b/t/63register_source.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::Exception tests => 1; -use lib qw(t/lib); + use DBICTest; use DBICTest::Schema; use DBIx::Class::ResultSource::Table; diff --git a/t/64db.t b/t/64db.t index 1a0046d3c..9f293e2db 100644 --- a/t/64db.t +++ b/t/64db.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/65multipk.t b/t/65multipk.t index cd0e108ef..31c0d41c8 100644 --- a/t/65multipk.t +++ b/t/65multipk.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/67pager.t b/t/67pager.t index fa7c93a0e..994cf406b 100644 --- a/t/67pager.t +++ b/t/67pager.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/69update.t b/t/69update.t index ea1eaae89..bd9d31423 100644 --- a/t/69update.t +++ b/t/69update.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/70auto.t b/t/70auto.t index 839c80725..49717765e 100644 --- a/t/70auto.t +++ b/t/70auto.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/71mysql.t b/t/71mysql.t index 1b967de8a..9d2c5d0f8 100644 --- a/t/71mysql.t +++ b/t/71mysql.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_mysql'; use strict; @@ -11,7 +12,7 @@ use B::Deparse; use DBI::Const::GetInfoType; use Scalar::Util qw/weaken/; -use lib qw(t/lib); + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}; diff --git a/t/72pg.t b/t/72pg.t index 71213e84a..eda3e03d4 100644 --- a/t/72pg.t +++ b/t/72pg.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_pg'; use strict; @@ -8,8 +9,6 @@ use Test::Exception; use Test::Warn; use Sub::Name; use Config; -use DBIx::Class::Optional::Dependencies (); -use lib qw(t/lib); use DBICTest; use SQL::Abstract 'is_literal_value'; use DBIx::Class::_Util 'is_exception'; diff --git a/t/72pg_bytea.t b/t/72pg_bytea.t index 7049b319c..15f8db5f2 100644 --- a/t/72pg_bytea.t +++ b/t/72pg_bytea.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw(test_rdbms_pg binary_data); use strict; @@ -6,7 +7,7 @@ use warnings; use Test::More; use DBIx::Class::_Util 'modver_gt_or_eq'; -use lib qw(t/lib); + use DBICTest; my ($dsn, $dbuser, $dbpass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; diff --git a/t/73oracle.t b/t/73oracle.t index c6211e289..efbb9961d 100644 --- a/t/73oracle.t +++ b/t/73oracle.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_oracle'; use strict; @@ -8,7 +9,6 @@ use Test::More; use Sub::Name; use Try::Tiny; -use lib qw(t/lib); use DBICTest; $ENV{NLS_SORT} = "BINARY"; diff --git a/t/73oracle_blob.t b/t/73oracle_blob.t index 0391d4b13..a6f6a4ea0 100644 --- a/t/73oracle_blob.t +++ b/t/73oracle_blob.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_oracle'; use strict; @@ -8,8 +9,6 @@ use Test::More; use Sub::Name; use Try::Tiny; -use lib qw(t/lib); - use DBICTest::Schema::BindType; BEGIN { DBICTest::Schema::BindType->add_columns( diff --git a/t/73oracle_hq.t b/t/73oracle_hq.t index 57bdc2b8e..0dde66965 100644 --- a/t/73oracle_hq.t +++ b/t/73oracle_hq.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_oracle'; use strict; @@ -10,8 +11,6 @@ use Test::More; # dealing with HQs. So just punt on the entire shuffle thing. BEGIN { $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} = 0 } -use lib qw(t/lib); - use DBICTest::Schema::Artist; BEGIN { DBICTest::Schema::Artist->add_column('parentid'); diff --git a/t/745db2.t b/t/745db2.t index 17a63430c..34cc2a1e5 100644 --- a/t/745db2.t +++ b/t/745db2.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_db2'; use strict; @@ -6,7 +7,7 @@ use warnings; use Test::More; use Test::Exception; use Try::Tiny; -use lib qw(t/lib); + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_DB2_${_}" } qw/DSN USER PASS/}; diff --git a/t/746db2_400.t b/t/746db2_400.t index b6c43502c..c06d4e4a8 100644 --- a/t/746db2_400.t +++ b/t/746db2_400.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_db2_400'; use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use DBIx::Class::Optional::Dependencies (); -use lib qw(t/lib); + use DBICTest; # Probably best to pass the DBQ option in the DSN to specify a specific diff --git a/t/746mssql.t b/t/746mssql.t index 23778a47a..c7753c7d7 100644 --- a/t/746mssql.t +++ b/t/746mssql.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_mssql_odbc'; use strict; @@ -7,7 +8,7 @@ use Test::More; use Test::Exception; use Try::Tiny; -use lib qw(t/lib); + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/}; diff --git a/t/746sybase.t b/t/746sybase.t index 0b8406c5c..818ed26a9 100644 --- a/t/746sybase.t +++ b/t/746sybase.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_ase'; use strict; @@ -8,7 +9,6 @@ use Test::More; use Test::Exception; use DBIx::Class::_Util 'sigwarn_silencer'; -use lib qw(t/lib); use DBICTest; my @storage_types = ( diff --git a/t/747mssql_ado.t b/t/747mssql_ado.t index 9c1d084a2..6fdb8cce4 100644 --- a/t/747mssql_ado.t +++ b/t/747mssql_ado.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_mssql_ado'; use strict; @@ -7,7 +8,7 @@ use Test::More; use Test::Exception; use Try::Tiny; use DBIx::Class::Optional::Dependencies (); -use lib qw(t/lib); + use DBICTest; # Example DSN (from frew): diff --git a/t/748informix.t b/t/748informix.t index 08fc4b5f1..cd9ad354b 100644 --- a/t/748informix.t +++ b/t/748informix.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_informix'; use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_INFORMIX_${_}" } qw/DSN USER PASS/}; diff --git a/t/749sqlanywhere.t b/t/749sqlanywhere.t index a52b5bda6..d4067b5bf 100644 --- a/t/749sqlanywhere.t +++ b/t/749sqlanywhere.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -6,7 +8,7 @@ use Test::Exception; use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SQLANYWHERE_${_}" } qw/DSN USER PASS/}; diff --git a/t/74mssql.t b/t/74mssql.t index 4f72cc4a8..5ade8a7ff 100644 --- a/t/74mssql.t +++ b/t/74mssql.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_mssql_sybase'; use strict; @@ -6,7 +7,7 @@ use warnings; use Test::More; use Test::Exception; use Scalar::Util 'weaken'; -use lib qw(t/lib); + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_${_}" } qw/DSN USER PASS/}; diff --git a/t/750firebird.t b/t/750firebird.t index 45dd8950a..b0a2749c0 100644 --- a/t/750firebird.t +++ b/t/750firebird.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -7,7 +9,7 @@ use DBIx::Class::Optional::Dependencies (); use DBIx::Class::_Util 'scope_guard'; use List::Util 'shuffle'; use Try::Tiny; -use lib qw(t/lib); + use DBICTest; my $env2optdep = { diff --git a/t/751msaccess.t b/t/751msaccess.t index dfd581679..479124aa8 100644 --- a/t/751msaccess.t +++ b/t/751msaccess.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -6,7 +8,7 @@ use Test::Exception; use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSACCESS_ODBC_${_}" } qw/DSN USER PASS/}; diff --git a/t/752sqlite.t b/t/752sqlite.t index f61f07ee6..fe076d1c4 100644 --- a/t/752sqlite.t +++ b/t/752sqlite.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -7,7 +9,7 @@ use Test::Warn; use Time::HiRes 'time'; use Math::BigInt; -use lib qw(t/lib); + use DBICTest; use DBIx::Class::_Util qw( sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt ); diff --git a/t/76joins.t b/t/76joins.t index d20faeca5..d98fd5a70 100644 --- a/t/76joins.t +++ b/t/76joins.t @@ -1,8 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/76select.t b/t/76select.t index 9d09380bc..b3b491ad8 100644 --- a/t/76select.t +++ b/t/76select.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/77join_count.t b/t/77join_count.t index 8350e2e8b..9de1a83ed 100644 --- a/t/77join_count.t +++ b/t/77join_count.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/78self_referencial.t b/t/78self_referencial.t index a02677d34..fe89bce37 100644 --- a/t/78self_referencial.t +++ b/t/78self_referencial.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/79aliasing.t b/t/79aliasing.t index 00e5e930a..70738c612 100644 --- a/t/79aliasing.t +++ b/t/79aliasing.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/80unique.t b/t/80unique.t index b38022504..726a2b22c 100644 --- a/t/80unique.t +++ b/t/80unique.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/82cascade_copy.t b/t/82cascade_copy.t index ec3ba92fe..505b79b5c 100644 --- a/t/82cascade_copy.t +++ b/t/82cascade_copy.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/83cache.t b/t/83cache.t index 5812083c2..a89772dac 100644 --- a/t/83cache.t +++ b/t/83cache.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/84serialize.t b/t/84serialize.t index ffa63fa0f..0cacfc10c 100644 --- a/t/84serialize.t +++ b/t/84serialize.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; use Storable qw(dclone freeze nfreeze thaw); use Scalar::Util qw/refaddr/; diff --git a/t/85utf8.t b/t/85utf8.t index e1f2caef8..3e4483596 100644 --- a/t/85utf8.t +++ b/t/85utf8.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; { diff --git a/t/86might_have.t b/t/86might_have.t index 05ba5390d..62655e035 100644 --- a/t/86might_have.t +++ b/t/86might_have.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/86sqlt.t b/t/86sqlt.t index a6b17ecf3..486b5ed4e 100644 --- a/t/86sqlt.t +++ b/t/86sqlt.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'deploy'; use strict; @@ -7,7 +8,7 @@ use Test::More; use Test::Warn; use Scalar::Util 'blessed'; -use lib qw(t/lib); + use DBICTest; my $custom_deployment_statements_called = 0; diff --git a/t/87ordered.t b/t/87ordered.t index 1eb079bb0..219c942a6 100644 --- a/t/87ordered.t +++ b/t/87ordered.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + # vim: filetype=perl use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; use POSIX (); diff --git a/t/88result_set_column.t b/t/88result_set_column.t index e1b73a354..f27c5dd86 100644 --- a/t/88result_set_column.t +++ b/t/88result_set_column.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -10,7 +12,7 @@ use Test::Exception; # and that's a whole another bag of dicks BEGIN { $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} = 0 } -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/90join_torture.t b/t/90join_torture.t index 27111e447..8ba193e5e 100644 --- a/t/90join_torture.t +++ b/t/90join_torture.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/93autocast.t b/t/93autocast.t index 49c1f5710..084f71467 100644 --- a/t/93autocast.t +++ b/t/93autocast.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; { # Fake storage driver for sqlite with autocast diff --git a/t/93single_accessor_object.t b/t/93single_accessor_object.t index a285b1af8..bcb53a140 100644 --- a/t/93single_accessor_object.t +++ b/t/93single_accessor_object.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; # Test various uses of passing an object to find, create, and update on a single diff --git a/t/94pk_mutation.t b/t/94pk_mutation.t index 3cdc47cb9..082e5c4c5 100644 --- a/t/94pk_mutation.t +++ b/t/94pk_mutation.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/94versioning.t b/t/94versioning.t index 9dcdcf15f..c3751b205 100644 --- a/t/94versioning.t +++ b/t/94versioning.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw(deploy test_rdbms_mysql); use strict; @@ -11,7 +12,7 @@ use Path::Class; use File::Copy; use Time::HiRes qw/time sleep/; -use lib qw(t/lib); + use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; diff --git a/t/97result_class.t b/t/97result_class.t index faff994c0..b7e3c4783 100644 --- a/t/97result_class.t +++ b/t/97result_class.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/99dbic_sqlt_parser.t b/t/99dbic_sqlt_parser.t index a9e708fe4..555183310 100644 --- a/t/99dbic_sqlt_parser.t +++ b/t/99dbic_sqlt_parser.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'deploy'; use strict; @@ -10,7 +11,7 @@ use Test::Warn; use Test::Exception; use Scalar::Util (); -use lib qw(t/lib); + use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; diff --git a/t/admin/02ddl.t b/t/admin/02ddl.t index b2414c356..9b6d9e53c 100644 --- a/t/admin/02ddl.t +++ b/t/admin/02ddl.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( admin deploy ); use strict; @@ -9,7 +10,7 @@ use Test::Warn; use Path::Class; -use lib qw(t/lib); + use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; diff --git a/t/admin/03data.t b/t/admin/03data.t index d73f61987..460a89e2e 100644 --- a/t/admin/03data.t +++ b/t/admin/03data.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'admin'; use strict; @@ -6,7 +7,7 @@ use warnings; use Test::More; use Test::Exception; -use lib 't/lib'; + use DBICTest; use DBIx::Class::Admin; diff --git a/t/cdbi/01-columns.t b/t/cdbi/01-columns.t index 76bce5241..827684d2d 100644 --- a/t/cdbi/01-columns.t +++ b/t/cdbi/01-columns.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/02-Film.t b/t/cdbi/02-Film.t index 7a6f9e9c5..95a460f5e 100644 --- a/t/cdbi/02-Film.t +++ b/t/cdbi/02-Film.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/03-subclassing.t b/t/cdbi/03-subclassing.t index 8a73a0944..b5ac32f7a 100644 --- a/t/cdbi/03-subclassing.t +++ b/t/cdbi/03-subclassing.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/04-lazy.t b/t/cdbi/04-lazy.t index 2e37827ae..96d574335 100644 --- a/t/cdbi/04-lazy.t +++ b/t/cdbi/04-lazy.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/06-hasa.t b/t/cdbi/06-hasa.t index d191b6589..6d47c1232 100644 --- a/t/cdbi/06-hasa.t +++ b/t/cdbi/06-hasa.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/08-inheritcols.t b/t/cdbi/08-inheritcols.t index bc9b90a9b..eabe09e17 100644 --- a/t/cdbi/08-inheritcols.t +++ b/t/cdbi/08-inheritcols.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/09-has_many.t b/t/cdbi/09-has_many.t index a19500ab3..bac11ed9b 100644 --- a/t/cdbi/09-has_many.t +++ b/t/cdbi/09-has_many.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/11-triggers.t b/t/cdbi/11-triggers.t index cd322e579..5f346d04c 100644 --- a/t/cdbi/11-triggers.t +++ b/t/cdbi/11-triggers.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/12-filter.t b/t/cdbi/12-filter.t index de68fa118..f39b848de 100644 --- a/t/cdbi/12-filter.t +++ b/t/cdbi/12-filter.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/13-constraint.t b/t/cdbi/13-constraint.t index ba9f654db..bd7bb984b 100644 --- a/t/cdbi/13-constraint.t +++ b/t/cdbi/13-constraint.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/14-might_have.t b/t/cdbi/14-might_have.t index 52a2abde1..9b332c7f2 100644 --- a/t/cdbi/14-might_have.t +++ b/t/cdbi/14-might_have.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/15-accessor.t b/t/cdbi/15-accessor.t index 85f8464f4..5b349668c 100644 --- a/t/cdbi/15-accessor.t +++ b/t/cdbi/15-accessor.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/16-reserved.t b/t/cdbi/16-reserved.t index ce8a4b394..cc01d8010 100644 --- a/t/cdbi/16-reserved.t +++ b/t/cdbi/16-reserved.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/18-has_a.t b/t/cdbi/18-has_a.t index dfb5819a1..a7b069c06 100644 --- a/t/cdbi/18-has_a.t +++ b/t/cdbi/18-has_a.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/19-set_sql.t b/t/cdbi/19-set_sql.t index a98181087..14cfc37d5 100644 --- a/t/cdbi/19-set_sql.t +++ b/t/cdbi/19-set_sql.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/21-iterator.t b/t/cdbi/21-iterator.t index 14a1b3002..49e8ec9e9 100644 --- a/t/cdbi/21-iterator.t +++ b/t/cdbi/21-iterator.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/22-deflate_order.t b/t/cdbi/22-deflate_order.t index 71d8d7d9c..a54eaf70d 100644 --- a/t/cdbi/22-deflate_order.t +++ b/t/cdbi/22-deflate_order.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( cdbicompat test_rdbms_mysql Time::Piece::MySQL>=0 ); $| = 1; diff --git a/t/cdbi/22-self_referential.t b/t/cdbi/22-self_referential.t index 43ad050ba..a70f5d1a1 100644 --- a/t/cdbi/22-self_referential.t +++ b/t/cdbi/22-self_referential.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/23-cascade.t b/t/cdbi/23-cascade.t index 809f45820..c66cffb73 100644 --- a/t/cdbi/23-cascade.t +++ b/t/cdbi/23-cascade.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/24-meta_info.t b/t/cdbi/24-meta_info.t index 703e3fd8b..7004de142 100644 --- a/t/cdbi/24-meta_info.t +++ b/t/cdbi/24-meta_info.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( cdbicompat Time::Piece>=0 ); use strict; diff --git a/t/cdbi/26-mutator.t b/t/cdbi/26-mutator.t index 54a4229ef..7042731b3 100644 --- a/t/cdbi/26-mutator.t +++ b/t/cdbi/26-mutator.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/30-pager.t b/t/cdbi/30-pager.t index d192d973c..eaac34093 100644 --- a/t/cdbi/30-pager.t +++ b/t/cdbi/30-pager.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/68-inflate_has_a.t b/t/cdbi/68-inflate_has_a.t index 37eac4bf7..639849463 100644 --- a/t/cdbi/68-inflate_has_a.t +++ b/t/cdbi/68-inflate_has_a.t @@ -1,10 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt cdbicompat ); use strict; use warnings; use Test::More; -use lib 't/lib'; + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/cdbi/70_implicit_inflate.t b/t/cdbi/70_implicit_inflate.t index fa53816d9..1c58f2ca2 100644 --- a/t/cdbi/70_implicit_inflate.t +++ b/t/cdbi/70_implicit_inflate.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( cdbicompat rdbms_sqlite ic_dt ); use strict; diff --git a/t/cdbi/71_column_object.t b/t/cdbi/71_column_object.t index e00820b73..54b0f418d 100644 --- a/t/cdbi/71_column_object.t +++ b/t/cdbi/71_column_object.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + # Columns in CDBI could be defined as Class::DBI::Column objects rather than # or as well as with __PACKAGE__->columns(); use DBIx::Class::Optional::Dependencies -skip_all_without => qw( cdbicompat Class::DBI>=3.000005 ); diff --git a/t/cdbi/98-failure.t b/t/cdbi/98-failure.t index 9a993c407..becb8c4d6 100644 --- a/t/cdbi/98-failure.t +++ b/t/cdbi/98-failure.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/DeepAbstractSearch/01_search.t b/t/cdbi/DeepAbstractSearch/01_search.t index f4911c762..8b2101a06 100644 --- a/t/cdbi/DeepAbstractSearch/01_search.t +++ b/t/cdbi/DeepAbstractSearch/01_search.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( cdbicompat Class::DBI::Plugin::DeepAbstractSearch>=0 ); use strict; @@ -5,7 +6,6 @@ use warnings; use Test::More; -use lib 't/lib'; use DBICTest; my $DB = DBICTest->_sqlite_dbname(sqlite_use_file => 1);; diff --git a/t/cdbi/abstract/search_where.t b/t/cdbi/abstract/search_where.t index 2c15ecc54..28e5b04e2 100644 --- a/t/cdbi/abstract/search_where.t +++ b/t/cdbi/abstract/search_where.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/columns_as_hashes.t b/t/cdbi/columns_as_hashes.t index 9731ae370..a8953c332 100644 --- a/t/cdbi/columns_as_hashes.t +++ b/t/cdbi/columns_as_hashes.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/columns_dont_override_custom_accessors.t b/t/cdbi/columns_dont_override_custom_accessors.t index 5748b6e00..2e99668fd 100644 --- a/t/cdbi/columns_dont_override_custom_accessors.t +++ b/t/cdbi/columns_dont_override_custom_accessors.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/construct.t b/t/cdbi/construct.t index d10e6a1a5..5040b06e2 100644 --- a/t/cdbi/construct.t +++ b/t/cdbi/construct.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/copy.t b/t/cdbi/copy.t index f587ae03d..2741aadaf 100644 --- a/t/cdbi/copy.t +++ b/t/cdbi/copy.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/early_column_heisenbug.t b/t/cdbi/early_column_heisenbug.t index e91b40125..8ecea27ba 100644 --- a/t/cdbi/early_column_heisenbug.t +++ b/t/cdbi/early_column_heisenbug.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/has_many_loads_foreign_class.t b/t/cdbi/has_many_loads_foreign_class.t index 5485972cb..a0af15abc 100644 --- a/t/cdbi/has_many_loads_foreign_class.t +++ b/t/cdbi/has_many_loads_foreign_class.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/hasa_without_loading.t b/t/cdbi/hasa_without_loading.t index 3b92c4db1..e365fd519 100644 --- a/t/cdbi/hasa_without_loading.t +++ b/t/cdbi/hasa_without_loading.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/max_min_value_of.t b/t/cdbi/max_min_value_of.t index aba3821f5..aff1dd7d1 100644 --- a/t/cdbi/max_min_value_of.t +++ b/t/cdbi/max_min_value_of.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/mk_group_accessors.t b/t/cdbi/mk_group_accessors.t index 5fc1994a2..fdd960076 100644 --- a/t/cdbi/mk_group_accessors.t +++ b/t/cdbi/mk_group_accessors.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/multi_column_set.t b/t/cdbi/multi_column_set.t index 1f1d1ac6e..cf0632a10 100644 --- a/t/cdbi/multi_column_set.t +++ b/t/cdbi/multi_column_set.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/object_cache.t b/t/cdbi/object_cache.t index db0dc06df..378395aea 100644 --- a/t/cdbi/object_cache.t +++ b/t/cdbi/object_cache.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/retrieve_from_sql_with_limit.t b/t/cdbi/retrieve_from_sql_with_limit.t index 404536155..b209ba0ca 100644 --- a/t/cdbi/retrieve_from_sql_with_limit.t +++ b/t/cdbi/retrieve_from_sql_with_limit.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; diff --git a/t/cdbi/set_to_undef.t b/t/cdbi/set_to_undef.t index 5b642e026..149be2c5a 100644 --- a/t/cdbi/set_to_undef.t +++ b/t/cdbi/set_to_undef.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt cdbicompat ); use strict; diff --git a/t/cdbi/set_vs_DateTime.t b/t/cdbi/set_vs_DateTime.t index 2fe087921..05d66b50d 100644 --- a/t/cdbi/set_vs_DateTime.t +++ b/t/cdbi/set_vs_DateTime.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt cdbicompat ); use strict; diff --git a/t/cdbi/sweet/08pager.t b/t/cdbi/sweet/08pager.t index 7f94e51b2..b91f89736 100644 --- a/t/cdbi/sweet/08pager.t +++ b/t/cdbi/sweet/08pager.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; -use lib 't/lib'; + use DBICTest; DBICTest::Schema::CD->load_components(qw/CDBICompat CDBICompat::Pager/); diff --git a/t/cdbi/testlib/DBIC/Test/SQLite.pm b/t/cdbi/testlib/DBIC/Test/SQLite.pm index 76822cdd5..72aa0c1c3 100644 --- a/t/cdbi/testlib/DBIC/Test/SQLite.pm +++ b/t/cdbi/testlib/DBIC/Test/SQLite.pm @@ -39,7 +39,6 @@ table, and tie it to the class. # change too much BEGIN { $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} = 0 } -use lib 't/lib'; use DBICTest; use base qw/DBIx::Class/; diff --git a/t/cdbi/testlib/MyBase.pm b/t/cdbi/testlib/MyBase.pm index 1fe93178f..8cffd74d1 100644 --- a/t/cdbi/testlib/MyBase.pm +++ b/t/cdbi/testlib/MyBase.pm @@ -5,8 +5,6 @@ use warnings; use strict; use DBI; - -use lib 't/lib'; use DBICTest; use base qw(DBIx::Class::CDBICompat); diff --git a/t/count/count_rs.t b/t/count/count_rs.t index 174f6307f..7afd11e8d 100644 --- a/t/count/count_rs.t +++ b/t/count/count_rs.t @@ -1,8 +1,8 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib qw(t/lib); - use Test::More; use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/count/distinct.t b/t/count/distinct.t index e916ab941..edd3d35d4 100644 --- a/t/count/distinct.t +++ b/t/count/distinct.t @@ -1,11 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); - use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/count/group_by_func.t b/t/count/group_by_func.t index 661cc9ec2..14f3f8ae7 100644 --- a/t/count/group_by_func.t +++ b/t/count/group_by_func.t @@ -1,10 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; - -use lib qw(t/lib); - use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/count/grouped_pager.t b/t/count/grouped_pager.t index 6bb61531b..5c23fad63 100644 --- a/t/count/grouped_pager.t +++ b/t/count/grouped_pager.t @@ -1,10 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; - -use lib qw(t/lib); - use DBICTest; plan tests => 7; diff --git a/t/count/in_subquery.t b/t/count/in_subquery.t index 85f48d083..765815d9f 100644 --- a/t/count/in_subquery.t +++ b/t/count/in_subquery.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/count/joined.t b/t/count/joined.t index bb8eb4c48..e6f3afa85 100644 --- a/t/count/joined.t +++ b/t/count/joined.t @@ -1,10 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; - -use lib qw(t/lib); - use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/count/prefetch.t b/t/count/prefetch.t index eb18236d8..07a5d2825 100644 --- a/t/count/prefetch.t +++ b/t/count/prefetch.t @@ -1,8 +1,8 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib qw(t/lib); - use Test::More; use DBICTest ':DiffSQL'; diff --git a/t/count/search_related.t b/t/count/search_related.t index 11f5796c6..0ebf8e454 100644 --- a/t/count/search_related.t +++ b/t/count/search_related.t @@ -1,10 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; - -use lib qw(t/lib); - use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/delete/cascade_missing.t b/t/delete/cascade_missing.t index 8bd8a769b..54270e8a5 100644 --- a/t/delete/cascade_missing.t +++ b/t/delete/cascade_missing.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -5,7 +7,7 @@ use Test::More; use Test::Warn; use Test::Exception; -use lib 't/lib'; + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/delete/complex.t b/t/delete/complex.t index 149bcf1d2..11ef35b4d 100644 --- a/t/delete/complex.t +++ b/t/delete/complex.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/delete/m2m.t b/t/delete/m2m.t index 7a1628d76..cd2951882 100644 --- a/t/delete/m2m.t +++ b/t/delete/m2m.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/delete/related.t b/t/delete/related.t index d4dc26b5e..f009709ff 100644 --- a/t/delete/related.t +++ b/t/delete/related.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/icdt/core.t b/t/icdt/core.t index 8f0c83c01..5af1ac3f9 100644 --- a/t/icdt/core.t +++ b/t/icdt/core.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( test_rdbms_sqlite ic_dt ); use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/icdt/datetime_missing_deps.t b/t/icdt/datetime_missing_deps.t index 680a3f1b1..f2f864a08 100644 --- a/t/icdt/datetime_missing_deps.t +++ b/t/icdt/datetime_missing_deps.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $no_class = '_DBICTEST_NONEXISTENT_CLASS_'; diff --git a/t/icdt/engine_specific/firebird.t b/t/icdt/engine_specific/firebird.t index 05ef3812d..493b41f92 100644 --- a/t/icdt/engine_specific/firebird.t +++ b/t/icdt/engine_specific/firebird.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt _rdbms_firebird_common ); use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); + use DBICTest; my $env2optdep = { diff --git a/t/icdt/engine_specific/informix.t b/t/icdt/engine_specific/informix.t index 4a6231c05..2ca980c0b 100644 --- a/t/icdt/engine_specific/informix.t +++ b/t/icdt/engine_specific/informix.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt test_rdbms_informix ); use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_INFORMIX_${_}" } qw/DSN USER PASS/}; diff --git a/t/icdt/engine_specific/msaccess.t b/t/icdt/engine_specific/msaccess.t index 9e647fbe9..a3cb63c83 100644 --- a/t/icdt/engine_specific/msaccess.t +++ b/t/icdt/engine_specific/msaccess.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt _rdbms_msaccess_common ); use strict; @@ -6,7 +7,7 @@ use warnings; use Test::More; use Try::Tiny; use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); + use DBICTest; my @tdeps = qw( test_rdbms_msaccess_odbc test_rdbms_msaccess_ado ); diff --git a/t/icdt/engine_specific/mssql.t b/t/icdt/engine_specific/mssql.t index e65a994ea..2756858c8 100644 --- a/t/icdt/engine_specific/mssql.t +++ b/t/icdt/engine_specific/mssql.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt _rdbms_mssql_common ); use strict; @@ -7,7 +8,7 @@ use Test::More; use Test::Exception; use Try::Tiny; use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); + use DBICTest; my @tdeps = qw( test_rdbms_mssql_odbc test_rdbms_mssql_sybase test_rdbms_mssql_ado ); diff --git a/t/icdt/engine_specific/oracle.t b/t/icdt/engine_specific/oracle.t index 4dc94b3d3..778a5785a 100644 --- a/t/icdt/engine_specific/oracle.t +++ b/t/icdt/engine_specific/oracle.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt test_rdbms_oracle ); use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; # DateTime::Format::Oracle needs this set diff --git a/t/icdt/engine_specific/sqlanywhere.t b/t/icdt/engine_specific/sqlanywhere.t index 0bac9dc53..00e9d563d 100644 --- a/t/icdt/engine_specific/sqlanywhere.t +++ b/t/icdt/engine_specific/sqlanywhere.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt _rdbms_sqlanywhere_common ); use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); + use DBICTest; my @tdeps = qw( test_rdbms_sqlanywhere test_rdbms_sqlanywhere_odbc ); diff --git a/t/icdt/engine_specific/sqlite.t b/t/icdt/engine_specific/sqlite.t index f9b321036..297372cdb 100644 --- a/t/icdt/engine_specific/sqlite.t +++ b/t/icdt/engine_specific/sqlite.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt test_rdbms_sqlite ); use strict; @@ -6,7 +7,7 @@ use warnings; use Test::More; use Test::Warn; use Try::Tiny; -use lib qw(t/lib); + use DBICTest; # Test offline parser determination (formerly t/inflate/datetime_determine_parser.t) diff --git a/t/icdt/engine_specific/sybase.t b/t/icdt/engine_specific/sybase.t index c63944e17..72a8bdb9c 100644 --- a/t/icdt/engine_specific/sybase.t +++ b/t/icdt/engine_specific/sybase.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt test_rdbms_ase ); use strict; @@ -6,7 +7,7 @@ use warnings; use Test::More; use Test::Exception; use DBIx::Class::_Util 'scope_guard'; -use lib qw(t/lib); + use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_${_}" } qw/DSN USER PASS/}; diff --git a/t/icdt/offline_mysql.t b/t/icdt/offline_mysql.t index 91bd3f65a..a865ef5a4 100644 --- a/t/icdt/offline_mysql.t +++ b/t/icdt/offline_mysql.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt_mysql ); use strict; @@ -6,7 +7,7 @@ use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest; use DBICTest::Schema; use DBIx::Class::_Util 'sigwarn_silencer'; diff --git a/t/icdt/offline_pg.t b/t/icdt/offline_pg.t index 0c0cb9b41..1a04fce6d 100644 --- a/t/icdt/offline_pg.t +++ b/t/icdt/offline_pg.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_dt_pg ); use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; DBICTest::Schema->load_classes('EventTZPg'); diff --git a/t/inflate/file_column.t b/t/inflate/file_column.t index 1b69e51de..acbf46ba4 100644 --- a/t/inflate/file_column.t +++ b/t/inflate/file_column.t @@ -1,10 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); - - use DBICTest; use DBICTest::Schema; use File::Compare; diff --git a/t/inflate/hri.t b/t/inflate/hri.t index b5e9d2f54..0564cad36 100644 --- a/t/inflate/hri.t +++ b/t/inflate/hri.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -11,7 +13,7 @@ BEGIN { } use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/inflate/hri_torture.t b/t/inflate/hri_torture.t index 92aa2d8af..c0b763eb2 100644 --- a/t/inflate/hri_torture.t +++ b/t/inflate/hri_torture.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Deep; -use lib qw(t/lib); + use DBICTest; # More tests like this in t/prefetch/manual.t diff --git a/t/inflate/serialize.t b/t/inflate/serialize.t index 63c31aaa9..2da03476a 100644 --- a/t/inflate/serialize.t +++ b/t/inflate/serialize.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/lib/ANFANG.pm b/t/lib/ANFANG.pm new file mode 100644 index 000000000..444cf4180 --- /dev/null +++ b/t/lib/ANFANG.pm @@ -0,0 +1,126 @@ +package # hide from pauses + ANFANG; + +# load-time critical +BEGIN { + if ( $ENV{RELEASE_TESTING} ) { + require warnings and warnings->import; + require strict and strict->import; + } + + # allow 'use ANFANG' to work after it's been do()ne + $INC{"ANFANG.pm"} ||= __FILE__; + $INC{"t/lib/ANFANG.pm"} ||= __FILE__; + $INC{"./t/lib/ANFANG.pm"} ||= __FILE__; +} + +BEGIN { + + # load-me-first sanity check + if ( + + # nobody shut us off + ! $ENV{DBICTEST_ANFANG_DEFANG} + + and + + # if this is set - all bets are off + ! $ENV{PERL5OPT} + + and + + # -d:Confess / -d:TraceUse and the like + ! $^P + + and + + # just don't check anything under RELEASE_TESTING + # a naive approach would be to simply whitelist both + # strict and warnings, but pre 5.10 there were even + # more modules loaded by these two: + # + # perlbrew exec perl -Mstrict -Mwarnings -e 'warn join "\n", sort keys %INC' + # + ! $ENV{RELEASE_TESTING} + + and + + my @undesirables = grep { + + ($INC{$_}||'') ne __FILE__ + + and + + # allow direct loads via -M + $_ !~ m{^ DBICTest (?: /Schema )? \.pm $}x + + } keys %INC + + ) { + + my ( $fr, @frame ); + while (@frame = caller(++$fr)) { + last if $frame[1] !~ m{ (?: \A | [\/\\] ) t [\/\\] lib [\/\\] }x; + } + + die __FILE__ . " must be loaded before any other module (i.e. @{[ join ', ', map { qq('$_') } sort @undesirables ]}) at $frame[1] line $frame[2]\n"; + } + + + if ( $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY} ) { + my $ov = UNIVERSAL->can("VERSION"); + + require Carp; + + # not loading warnings.pm + local $^W = 0; + + *UNIVERSAL::VERSION = sub { + Carp::carp( 'Argument "blah bleh bloh" isn\'t numeric in subroutine entry' ); + &$ov; + }; + } + + + if ( + $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} + or + # keep it always on during CI + ( + ($ENV{TRAVIS}||'') eq 'true' + and + ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/dbix-class$| + ) + ) { + require Try::Tiny; + my $orig = \&Try::Tiny::try; + + # not loading warnings.pm + local $^W = 0; + + *Try::Tiny::try = sub (&;@) { + my ($fr, $first_pkg) = 0; + while( $first_pkg = caller($fr++) ) { + last if $first_pkg !~ /^ + __ANON__ + | + \Q(eval)\E + $/x; + } + + if ($first_pkg =~ /DBIx::Class/) { + require Test::Builder; + Test::Builder->new->ok(0, + 'Using try{} within DBIC internals is a mistake - use dbic_internal_try{} instead' + ); + } + + goto $orig; + }; + } + +} + +use lib 't/lib'; + +1; diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index 849caa1d7..ad3bf3c28 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -1,10 +1,12 @@ package # hide from PAUSE DBICTest; +# load early so that `perl -It/lib -MDBICTest` keeps working +use ANFANG; + use strict; use warnings; - # this noop trick initializes the STDOUT, so that the TAP::Harness # issued IO::Select->can_read calls (which are blocking wtf wtf wtf) # keep spinning and scheduling jobs @@ -39,9 +41,12 @@ DBICTest - Library to be used by DBIx::Class test scripts =head1 SYNOPSIS - use lib qw(t/lib); - use DBICTest; + BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + + use warnings; + use strict; use Test::More; + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/lib/DBICTest/Base.pm b/t/lib/DBICTest/Base.pm index 7d2cb5605..9024f8e0e 100644 --- a/t/lib/DBICTest/Base.pm +++ b/t/lib/DBICTest/Base.pm @@ -4,8 +4,7 @@ package #hide from pause use strict; use warnings; -# must load before any DBIx::Class* namespaces -use DBICTest::RunMode; +use DBICTest::Util; sub _skip_namespace_frames { '^DBICTest' } diff --git a/t/lib/DBICTest/RunMode.pm b/t/lib/DBICTest/RunMode.pm index 590abde0e..178378e70 100644 --- a/t/lib/DBICTest/RunMode.pm +++ b/t/lib/DBICTest/RunMode.pm @@ -4,64 +4,6 @@ package # hide from PAUSE use strict; use warnings; -BEGIN { - if ($INC{'DBIx/Class.pm'}) { - my ($fr, @frame) = 1; - while (@frame = caller($fr++)) { - last if $frame[1] !~ m|^t/lib/DBICTest|; - } - - die __PACKAGE__ . " must be loaded before DBIx::Class (or modules using DBIx::Class) at $frame[1] line $frame[2]\n"; - } - - if ( $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY} ) { - my $ov = UNIVERSAL->can("VERSION"); - - require Carp; - - no warnings 'redefine'; - *UNIVERSAL::VERSION = sub { - Carp::carp( 'Argument "blah bleh bloh" isn\'t numeric in subroutine entry' ); - &$ov; - }; - } - - if ( - $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} - or - # keep it always on during CI - ( - ($ENV{TRAVIS}||'') eq 'true' - and - ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/dbix-class$| - ) - ) { - require Try::Tiny; - my $orig = \&Try::Tiny::try; - - no warnings 'redefine'; - *Try::Tiny::try = sub (&;@) { - my ($fr, $first_pkg) = 0; - while( $first_pkg = caller($fr++) ) { - last if $first_pkg !~ /^ - __ANON__ - | - \Q(eval)\E - $/x; - } - - if ($first_pkg =~ /DBIx::Class/) { - require Test::Builder; - Test::Builder->new->ok(0, - 'Using try{} within DBIC internals is a mistake - use dbic_internal_try{} instead' - ); - } - - goto $orig; - }; - } -} - use Path::Class qw/file dir/; use Fcntl ':DEFAULT'; use File::Spec (); diff --git a/t/lib/DBICTest/Schema.pm b/t/lib/DBICTest/Schema.pm index 2e783a759..1b436f633 100644 --- a/t/lib/DBICTest/Schema.pm +++ b/t/lib/DBICTest/Schema.pm @@ -1,6 +1,9 @@ package # hide from PAUSE DBICTest::Schema; +# load early so that `perl -It/lib -MDBICTest::Schema` keeps working +use ANFANG; + use strict; use warnings; no warnings 'qw'; diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 27f7527c3..cbbce3536 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -3,6 +3,8 @@ package DBICTest::Util; use warnings; use strict; +use ANFANG; + use constant DEBUG_TEST_CONCURRENCY_LOCKS => ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0] || diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index b1de109e6..134ca6333 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -3,10 +3,12 @@ package DBICTest::Util::LeakTracer; use warnings; use strict; +use ANFANG; use Carp; use Scalar::Util qw(isweak weaken blessed reftype); use DBIx::Class::_Util qw(refcount hrefaddr refdesc); use DBIx::Class::Optional::Dependencies; +use DBICTest::RunMode; use Data::Dumper::Concise; use DBICTest::Util qw( stacktrace visit_namespaces ); use constant { diff --git a/t/multi_create/cd_single.t b/t/multi_create/cd_single.t index 746eaab32..2549cb7e3 100644 --- a/t/multi_create/cd_single.t +++ b/t/multi_create/cd_single.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/multi_create/diamond.t b/t/multi_create/diamond.t index 499f7a13b..ce0efab42 100644 --- a/t/multi_create/diamond.t +++ b/t/multi_create/diamond.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; sub mc_diag { diag (@_) if $ENV{DBIC_MULTICREATE_DEBUG} }; diff --git a/t/multi_create/existing_in_chain.t b/t/multi_create/existing_in_chain.t index 292dd6b7c..e7a7d4732 100644 --- a/t/multi_create/existing_in_chain.t +++ b/t/multi_create/existing_in_chain.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/multi_create/find_or_multicreate.t b/t/multi_create/find_or_multicreate.t index 762b96275..6efc97448 100644 --- a/t/multi_create/find_or_multicreate.t +++ b/t/multi_create/find_or_multicreate.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema( no_populate => 1 ); diff --git a/t/multi_create/has_many.t b/t/multi_create/has_many.t index 2878ff77c..2e40d7b79 100644 --- a/t/multi_create/has_many.t +++ b/t/multi_create/has_many.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/multi_create/in_memory.t b/t/multi_create/in_memory.t index 9533af506..c96db6892 100644 --- a/t/multi_create/in_memory.t +++ b/t/multi_create/in_memory.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/multi_create/insert_defaults.t b/t/multi_create/insert_defaults.t index 3425b8ac5..d7839c113 100644 --- a/t/multi_create/insert_defaults.t +++ b/t/multi_create/insert_defaults.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; diff --git a/t/multi_create/m2m.t b/t/multi_create/m2m.t index 26934c9fe..879453f29 100644 --- a/t/multi_create/m2m.t +++ b/t/multi_create/m2m.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; plan tests => 4; diff --git a/t/multi_create/multilev_single_PKeqFK.t b/t/multi_create/multilev_single_PKeqFK.t index 9a5adbe92..301e80b6b 100644 --- a/t/multi_create/multilev_single_PKeqFK.t +++ b/t/multi_create/multilev_single_PKeqFK.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; sub mc_diag { diag (@_) if $ENV{DBIC_MULTICREATE_DEBUG} }; diff --git a/t/multi_create/standard.t b/t/multi_create/standard.t index 54cf04ee3..784a40962 100644 --- a/t/multi_create/standard.t +++ b/t/multi_create/standard.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/multi_create/torture.t b/t/multi_create/torture.t index 79338d7f6..269a0621d 100644 --- a/t/multi_create/torture.t +++ b/t/multi_create/torture.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; plan tests => 23; diff --git a/t/ordered/cascade_delete.t b/t/ordered/cascade_delete.t index b6633c70c..62463fa7f 100644 --- a/t/ordered/cascade_delete.t +++ b/t/ordered/cascade_delete.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/ordered/unordered_movement.t b/t/ordered/unordered_movement.t index dc083068a..1684b2f2b 100644 --- a/t/ordered/unordered_movement.t +++ b/t/ordered/unordered_movement.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/attrs_untouched.t b/t/prefetch/attrs_untouched.t index b2f25c38c..ce99b4259 100644 --- a/t/prefetch/attrs_untouched.t +++ b/t/prefetch/attrs_untouched.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; -use lib qw(t/lib); + use DBICTest; use Data::Dumper; diff --git a/t/prefetch/correlated.t b/t/prefetch/correlated.t index 5196620db..e941b12a9 100644 --- a/t/prefetch/correlated.t +++ b/t/prefetch/correlated.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Deep; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/count.t b/t/prefetch/count.t index f973575f1..8a32b4108 100644 --- a/t/prefetch/count.t +++ b/t/prefetch/count.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/diamond.t b/t/prefetch/diamond.t index f7a21e037..dc3e22c20 100644 --- a/t/prefetch/diamond.t +++ b/t/prefetch/diamond.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + # Test if prefetch and join in diamond relationship fetching the correct rows use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/double_prefetch.t b/t/prefetch/double_prefetch.t index fa0b79f51..2942d2395 100644 --- a/t/prefetch/double_prefetch.t +++ b/t/prefetch/double_prefetch.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/empty_cache.t b/t/prefetch/empty_cache.t index 9f42d5a11..c7cda22c4 100644 --- a/t/prefetch/empty_cache.t +++ b/t/prefetch/empty_cache.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/false_colvalues.t b/t/prefetch/false_colvalues.t index 468a27a85..a87de706a 100644 --- a/t/prefetch/false_colvalues.t +++ b/t/prefetch/false_colvalues.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; use Test::Deep; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema( no_populate => 1 ); diff --git a/t/prefetch/grouped.t b/t/prefetch/grouped.t index 0f6f59a29..4aad6b197 100644 --- a/t/prefetch/grouped.t +++ b/t/prefetch/grouped.t @@ -1,9 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/prefetch/incomplete.t b/t/prefetch/incomplete.t index 63e431aa9..114ccfb29 100644 --- a/t/prefetch/incomplete.t +++ b/t/prefetch/incomplete.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Deep; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/join_type.t b/t/prefetch/join_type.t index f2980e788..5165e09b6 100644 --- a/t/prefetch/join_type.t +++ b/t/prefetch/join_type.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/lazy_cursor.t b/t/prefetch/lazy_cursor.t index de6e9361e..3ed3c7c01 100644 --- a/t/prefetch/lazy_cursor.t +++ b/t/prefetch/lazy_cursor.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/manual.t b/t/prefetch/manual.t index e051ce37c..83870ae93 100644 --- a/t/prefetch/manual.t +++ b/t/prefetch/manual.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -5,7 +7,7 @@ use Test::More; use Test::Deep; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; delete $ENV{DBIC_COLUMNS_INCLUDE_FILTER_RELS}; diff --git a/t/prefetch/multiple_hasmany.t b/t/prefetch/multiple_hasmany.t index 665005b75..7af0888a3 100644 --- a/t/prefetch/multiple_hasmany.t +++ b/t/prefetch/multiple_hasmany.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/multiple_hasmany_torture.t b/t/prefetch/multiple_hasmany_torture.t index d3998e098..cd503ddd2 100644 --- a/t/prefetch/multiple_hasmany_torture.t +++ b/t/prefetch/multiple_hasmany_torture.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Deep; use Test::Exception; -use lib qw(t/lib); + use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; diff --git a/t/prefetch/o2m_o2m_order_by_with_limit.t b/t/prefetch/o2m_o2m_order_by_with_limit.t index 65a2c3986..fc447a217 100644 --- a/t/prefetch/o2m_o2m_order_by_with_limit.t +++ b/t/prefetch/o2m_o2m_order_by_with_limit.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/prefetch/one_to_many_to_one.t b/t/prefetch/one_to_many_to_one.t index f79b38e2c..f8a4fcdae 100644 --- a/t/prefetch/one_to_many_to_one.t +++ b/t/prefetch/one_to_many_to_one.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/refined_search_on_relation.t b/t/prefetch/refined_search_on_relation.t index 729dbdebd..e27687c01 100644 --- a/t/prefetch/refined_search_on_relation.t +++ b/t/prefetch/refined_search_on_relation.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/restricted_children_set.t b/t/prefetch/restricted_children_set.t index 9b0f3ee0d..5ad56bf8b 100644 --- a/t/prefetch/restricted_children_set.t +++ b/t/prefetch/restricted_children_set.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/standard.t b/t/prefetch/standard.t index 75107c706..bf863157c 100644 --- a/t/prefetch/standard.t +++ b/t/prefetch/standard.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/via_search_related.t b/t/prefetch/via_search_related.t index 316035d4b..846b3338f 100644 --- a/t/prefetch/via_search_related.t +++ b/t/prefetch/via_search_related.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/prefetch/with_limit.t b/t/prefetch/with_limit.t index 28b3b8a89..5b1bb83ce 100644 --- a/t/prefetch/with_limit.t +++ b/t/prefetch/with_limit.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + # Test to ensure we get a consistent result set wether or not we use the # prefetch option in combination rows (LIMIT). use strict; @@ -5,7 +7,7 @@ use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/relationship/after_update.t b/t/relationship/after_update.t index 7ec8d005a..cc4e4be2a 100644 --- a/t/relationship/after_update.t +++ b/t/relationship/after_update.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/relationship/core.t b/t/relationship/core.t index 87f635e6a..9955ce637 100644 --- a/t/relationship/core.t +++ b/t/relationship/core.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/relationship/custom.t b/t/relationship/custom.t index b9bf5fa13..32c8cf8f2 100644 --- a/t/relationship/custom.t +++ b/t/relationship/custom.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/relationship/custom_opaque.t b/t/relationship/custom_opaque.t index 1139c6aa2..6e701c437 100644 --- a/t/relationship/custom_opaque.t +++ b/t/relationship/custom_opaque.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib 't/lib'; + use DBICTest; my $schema = DBICTest->init_schema( no_populate => 1, quote_names => 1 ); diff --git a/t/relationship/custom_with_null_in_cond.t b/t/relationship/custom_with_null_in_cond.t index e7a7acb25..b396014e8 100644 --- a/t/relationship/custom_with_null_in_cond.t +++ b/t/relationship/custom_with_null_in_cond.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib 't/lib'; + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/relationship/doesnt_exist.t b/t/relationship/doesnt_exist.t index 7575122eb..9133deeff 100644 --- a/t/relationship/doesnt_exist.t +++ b/t/relationship/doesnt_exist.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/relationship/dynamic_foreign_columns.t b/t/relationship/dynamic_foreign_columns.t index a9fc25451..ecc24c50a 100644 --- a/t/relationship/dynamic_foreign_columns.t +++ b/t/relationship/dynamic_foreign_columns.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; require DBICTest::DynamicForeignCols::TestComputer; diff --git a/t/relationship/info.t b/t/relationship/info.t index 4f349d45e..fd1bfa8f6 100644 --- a/t/relationship/info.t +++ b/t/relationship/info.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; # diff --git a/t/relationship/proxy.t b/t/relationship/proxy.t index ec9847db9..93a0a6699 100644 --- a/t/relationship/proxy.t +++ b/t/relationship/proxy.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/relationship/resolve_relationship_condition.t b/t/relationship/resolve_relationship_condition.t index 1d4cb6271..a999dc6c2 100644 --- a/t/relationship/resolve_relationship_condition.t +++ b/t/relationship/resolve_relationship_condition.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib 't/lib'; + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/relationship/set_column_on_fk.t b/t/relationship/set_column_on_fk.t index 9f49427d5..df2adc914 100644 --- a/t/relationship/set_column_on_fk.t +++ b/t/relationship/set_column_on_fk.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/relationship/update_or_create_multi.t b/t/relationship/update_or_create_multi.t index 5dde83db1..59861268f 100644 --- a/t/relationship/update_or_create_multi.t +++ b/t/relationship/update_or_create_multi.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/relationship/update_or_create_single.t b/t/relationship/update_or_create_single.t index a0e31fbb3..bb4f80857 100644 --- a/t/relationship/update_or_create_single.t +++ b/t/relationship/update_or_create_single.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/resultset/as_query.t b/t/resultset/as_query.t index 3b43e9c2f..09b51864c 100644 --- a/t/resultset/as_query.t +++ b/t/resultset/as_query.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/resultset/as_subselect_rs.t b/t/resultset/as_subselect_rs.t index 6d7597756..edfcae767 100644 --- a/t/resultset/as_subselect_rs.t +++ b/t/resultset/as_subselect_rs.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/resultset/bind_attr.t b/t/resultset/bind_attr.t index 7f25d99b1..a636cfc15 100644 --- a/t/resultset/bind_attr.t +++ b/t/resultset/bind_attr.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema; diff --git a/t/resultset/create_with_rs_inherited_values.t b/t/resultset/create_with_rs_inherited_values.t index 8a0acd377..bc4795094 100644 --- a/t/resultset/create_with_rs_inherited_values.t +++ b/t/resultset/create_with_rs_inherited_values.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -5,7 +7,7 @@ use Test::More; use Test::Exception; use Math::BigInt; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/resultset/find_on_subquery_cond.t b/t/resultset/find_on_subquery_cond.t index af2ca51aa..ec02d6b0a 100644 --- a/t/resultset/find_on_subquery_cond.t +++ b/t/resultset/find_on_subquery_cond.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/resultset/inflate_result_api.t b/t/resultset/inflate_result_api.t index e6bedc2b1..6f5b0a8aa 100644 --- a/t/resultset/inflate_result_api.t +++ b/t/resultset/inflate_result_api.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; no warnings 'exiting'; use Test::More; use Test::Deep; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(no_populate => 1); diff --git a/t/resultset/inflatemap_abuse.t b/t/resultset/inflatemap_abuse.t index 9c60765d2..0289891e7 100644 --- a/t/resultset/inflatemap_abuse.t +++ b/t/resultset/inflatemap_abuse.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; # From http://lists.scsys.co.uk/pipermail/dbix-class/2013-February/011119.html diff --git a/t/resultset/is_ordered.t b/t/resultset/is_ordered.t index 39595a4d3..a18345844 100644 --- a/t/resultset/is_ordered.t +++ b/t/resultset/is_ordered.t @@ -1,7 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib qw(t/lib); + use Test::More; use DBICTest; diff --git a/t/resultset/is_paged.t b/t/resultset/is_paged.t index 4f6af63fc..020afa076 100644 --- a/t/resultset/is_paged.t +++ b/t/resultset/is_paged.t @@ -1,7 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib qw(t/lib); + use Test::More; use DBICTest; diff --git a/t/resultset/nulls_only.t b/t/resultset/nulls_only.t index 7f53d6d1f..a8d965c37 100644 --- a/t/resultset/nulls_only.t +++ b/t/resultset/nulls_only.t @@ -1,7 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib qw(t/lib); + use Test::More; use DBICTest; diff --git a/t/resultset/plus_select.t b/t/resultset/plus_select.t index db55ac48e..d63adad51 100644 --- a/t/resultset/plus_select.t +++ b/t/resultset/plus_select.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Math::BigInt; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/resultset/rowparser_internals.t b/t/resultset/rowparser_internals.t index e89369fb2..251168499 100644 --- a/t/resultset/rowparser_internals.t +++ b/t/resultset/rowparser_internals.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; use B::Deparse; use DBIx::Class::_Util 'perlstring'; diff --git a/t/resultset/update_delete.t b/t/resultset/update_delete.t index 30e379743..46f690af7 100644 --- a/t/resultset/update_delete.t +++ b/t/resultset/update_delete.t @@ -1,7 +1,8 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib qw(t/lib); use Test::More; use Test::Exception; diff --git a/t/resultset_class.t b/t/resultset_class.t index 607c1f254..43054a58f 100644 --- a/t/resultset_class.t +++ b/t/resultset_class.t @@ -1,11 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Class::Inspector (); -unshift(@INC, './t/lib'); -use lib 't/lib'; - use DBICTest; is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICTest::BaseResultSet', 'default resultset class'); diff --git a/t/resultset_overload.t b/t/resultset_overload.t index 164d2ee66..8fb22e3d4 100644 --- a/t/resultset_overload.t +++ b/t/resultset_overload.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/resultsource/bare_resultclass_exception.t b/t/resultsource/bare_resultclass_exception.t index 6b8d72c58..0db9efd04 100644 --- a/t/resultsource/bare_resultclass_exception.t +++ b/t/resultsource/bare_resultclass_exception.t @@ -1,10 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib 't/lib'; use DBICTest; { diff --git a/t/resultsource/set_primary_key.t b/t/resultsource/set_primary_key.t index 1f9de7df3..e46ad642d 100644 --- a/t/resultsource/set_primary_key.t +++ b/t/resultsource/set_primary_key.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib 't/lib'; + use DBICTest; throws_ok { diff --git a/t/row/copy_with_extra_selection.t b/t/row/copy_with_extra_selection.t index c1e3df4d2..86c49b672 100644 --- a/t/row/copy_with_extra_selection.t +++ b/t/row/copy_with_extra_selection.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/row/filter_column.t b/t/row/filter_column.t index 7823fa53e..af7a951f2 100644 --- a/t/row/filter_column.t +++ b/t/row/filter_column.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $from_storage_ran = 0; diff --git a/t/row/find_one_has_many.t b/t/row/find_one_has_many.t index ea7767f73..51d8db4ff 100644 --- a/t/row/find_one_has_many.t +++ b/t/row/find_one_has_many.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/row/inflate_result.t b/t/row/inflate_result.t index 3327b706f..f2f6b8078 100644 --- a/t/row/inflate_result.t +++ b/t/row/inflate_result.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; -use lib qw(t/lib); + use DBICTest; package My::Schema::Result::User; diff --git a/t/row/pkless.t b/t/row/pkless.t index ac090deb4..f11f31cc4 100644 --- a/t/row/pkless.t +++ b/t/row/pkless.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/row/set_extra_column.t b/t/row/set_extra_column.t index 0debaaf5b..cd953057a 100644 --- a/t/row/set_extra_column.t +++ b/t/row/set_extra_column.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/row/sourceless.t b/t/row/sourceless.t index 85ae3eeae..4da089966 100644 --- a/t/row/sourceless.t +++ b/t/row/sourceless.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $row = DBICTest::Schema::CD->new({ title => 'foo' }); diff --git a/t/schema/anon.t b/t/schema/anon.t index 4d74aceb2..18b04b58b 100644 --- a/t/schema/anon.t +++ b/t/schema/anon.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; lives_ok (sub { diff --git a/t/schema/clone.t b/t/schema/clone.t index 86b7a47d8..877da18e5 100644 --- a/t/schema/clone.t +++ b/t/schema/clone.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/search/distinct.t b/t/search/distinct.t index 4a8026769..08c67172e 100644 --- a/t/search/distinct.t +++ b/t/search/distinct.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/search/empty_attrs.t b/t/search/empty_attrs.t index 3b5248736..cb4cff738 100644 --- a/t/search/empty_attrs.t +++ b/t/search/empty_attrs.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/search/preserve_original_rs.t b/t/search/preserve_original_rs.t index 9f6704f35..9a087e720 100644 --- a/t/search/preserve_original_rs.t +++ b/t/search/preserve_original_rs.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::_Util 'serialize'; diff --git a/t/search/reentrancy.t b/t/search/reentrancy.t index 879060322..ad4b4e5d6 100644 --- a/t/search/reentrancy.t +++ b/t/search/reentrancy.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/search/related_has_many.t b/t/search/related_has_many.t index 91b1fb7da..572aebfa7 100644 --- a/t/search/related_has_many.t +++ b/t/search/related_has_many.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/search/related_strip_prefetch.t b/t/search/related_strip_prefetch.t index 5e34fe980..cf80061bc 100644 --- a/t/search/related_strip_prefetch.t +++ b/t/search/related_strip_prefetch.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/search/select_chains.t b/t/search/select_chains.t index ed8f23b45..31692d3d0 100644 --- a/t/search/select_chains.t +++ b/t/search/select_chains.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/search/select_chains_unbalanced.t b/t/search/select_chains_unbalanced.t index 63de73cf9..471cae2ae 100644 --- a/t/search/select_chains_unbalanced.t +++ b/t/search/select_chains_unbalanced.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/search/stack_cond.t b/t/search/stack_cond.t index 9a0e8062b..4c06a5db5 100644 --- a/t/search/stack_cond.t +++ b/t/search/stack_cond.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use SQL::Abstract qw(is_plain_value is_literal_value); use List::Util 'shuffle'; diff --git a/t/search/subquery.t b/t/search/subquery.t index 8c3fcf777..8b785e4f0 100644 --- a/t/search/subquery.t +++ b/t/search/subquery.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; use DBIx::Class::_Util 'sigwarn_silencer'; diff --git a/t/sqlmaker/bind_transport.t b/t/sqlmaker/bind_transport.t index 30971914d..aacd59c79 100644 --- a/t/sqlmaker/bind_transport.t +++ b/t/sqlmaker/bind_transport.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -5,7 +7,7 @@ use Test::More; use Test::Exception; use Math::BigInt; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/sqlmaker/core.t b/t/sqlmaker/core.t index 1c2a1c35c..4e19ed783 100644 --- a/t/sqlmaker/core.t +++ b/t/sqlmaker/core.t @@ -1,10 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(no_deploy => 1); diff --git a/t/sqlmaker/core_quoted.t b/t/sqlmaker/core_quoted.t index 8e455660d..d483a4033 100644 --- a/t/sqlmaker/core_quoted.t +++ b/t/sqlmaker/core_quoted.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/sqlmaker/dbihacks_internals.t b/t/sqlmaker/dbihacks_internals.t index ca8173784..cf75a2644 100644 --- a/t/sqlmaker/dbihacks_internals.t +++ b/t/sqlmaker/dbihacks_internals.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION'; diff --git a/t/sqlmaker/hierarchical/oracle.t b/t/sqlmaker/hierarchical/oracle.t index 3495e85a4..62e6776cb 100644 --- a/t/sqlmaker/hierarchical/oracle.t +++ b/t/sqlmaker/hierarchical/oracle.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'id_shortener'; use strict; @@ -5,7 +6,6 @@ use warnings; use Test::More; -use lib qw(t/lib); use DBICTest::Schema::Artist; BEGIN { DBICTest::Schema::Artist->add_column('parentid'); diff --git a/t/sqlmaker/legacy_joins.t b/t/sqlmaker/legacy_joins.t index 1c93c3596..2ecc0effd 100644 --- a/t/sqlmaker/legacy_joins.t +++ b/t/sqlmaker/legacy_joins.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::_Util 'sigwarn_silencer'; diff --git a/t/sqlmaker/limit_dialects/basic.t b/t/sqlmaker/limit_dialects/basic.t index 7098f1d06..85872bbe7 100644 --- a/t/sqlmaker/limit_dialects/basic.t +++ b/t/sqlmaker/limit_dialects/basic.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/sqlmaker/limit_dialects/custom.t b/t/sqlmaker/limit_dialects/custom.t index 89c4788bc..da6da39f4 100644 --- a/t/sqlmaker/limit_dialects/custom.t +++ b/t/sqlmaker/limit_dialects/custom.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; # This is legacy stuff from SQL::Absract::Limit diff --git a/t/sqlmaker/limit_dialects/fetch_first.t b/t/sqlmaker/limit_dialects/fetch_first.t index ab3e17034..625a46470 100644 --- a/t/sqlmaker/limit_dialects/fetch_first.t +++ b/t/sqlmaker/limit_dialects/fetch_first.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema; diff --git a/t/sqlmaker/limit_dialects/first_skip.t b/t/sqlmaker/limit_dialects/first_skip.t index acaf770ef..5eff5858e 100644 --- a/t/sqlmaker/limit_dialects/first_skip.t +++ b/t/sqlmaker/limit_dialects/first_skip.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/sqlmaker/limit_dialects/generic_subq.t b/t/sqlmaker/limit_dialects/generic_subq.t index 2d4bedad2..916ef35af 100644 --- a/t/sqlmaker/limit_dialects/generic_subq.t +++ b/t/sqlmaker/limit_dialects/generic_subq.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use List::Util 'min'; use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/sqlmaker/limit_dialects/mssql_torture.t b/t/sqlmaker/limit_dialects/mssql_torture.t index e45295344..67cdbcd40 100644 --- a/t/sqlmaker/limit_dialects/mssql_torture.t +++ b/t/sqlmaker/limit_dialects/mssql_torture.t @@ -1,7 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; my $OFFSET = DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype; diff --git a/t/sqlmaker/limit_dialects/rno.t b/t/sqlmaker/limit_dialects/rno.t index b3177926e..4cbe91f3d 100644 --- a/t/sqlmaker/limit_dialects/rno.t +++ b/t/sqlmaker/limit_dialects/rno.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/sqlmaker/limit_dialects/rownum.t b/t/sqlmaker/limit_dialects/rownum.t index 806bba493..b7bb9df5c 100644 --- a/t/sqlmaker/limit_dialects/rownum.t +++ b/t/sqlmaker/limit_dialects/rownum.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/sqlmaker/limit_dialects/skip_first.t b/t/sqlmaker/limit_dialects/skip_first.t index a87b95e43..91f1f9898 100644 --- a/t/sqlmaker/limit_dialects/skip_first.t +++ b/t/sqlmaker/limit_dialects/skip_first.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; diff --git a/t/sqlmaker/limit_dialects/toplimit.t b/t/sqlmaker/limit_dialects/toplimit.t index 3fb03d9eb..e1c40b853 100644 --- a/t/sqlmaker/limit_dialects/toplimit.t +++ b/t/sqlmaker/limit_dialects/toplimit.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema; diff --git a/t/sqlmaker/limit_dialects/torture.t b/t/sqlmaker/limit_dialects/torture.t index 4dac672e9..03c8822a1 100644 --- a/t/sqlmaker/limit_dialects/torture.t +++ b/t/sqlmaker/limit_dialects/torture.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::_Util 'deep_clone'; diff --git a/t/sqlmaker/literal_with_bind.t b/t/sqlmaker/literal_with_bind.t index 1024a62b9..a3dbcc716 100644 --- a/t/sqlmaker/literal_with_bind.t +++ b/t/sqlmaker/literal_with_bind.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(no_populate => 1); diff --git a/t/sqlmaker/msaccess.t b/t/sqlmaker/msaccess.t index 179b3f31e..8797b1e62 100644 --- a/t/sqlmaker/msaccess.t +++ b/t/sqlmaker/msaccess.t @@ -1,7 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; # the entire point of the subclass is that parenthesis have to be diff --git a/t/sqlmaker/mysql.t b/t/sqlmaker/mysql.t index 0e2ad2961..f1e3bfb23 100644 --- a/t/sqlmaker/mysql.t +++ b/t/sqlmaker/mysql.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest::Schema->connect (DBICTest->_database, { quote_char => '`' }); diff --git a/t/sqlmaker/nest_deprec.t b/t/sqlmaker/nest_deprec.t index a6edeeec3..232274e54 100644 --- a/t/sqlmaker/nest_deprec.t +++ b/t/sqlmaker/nest_deprec.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/sqlmaker/oracle.t b/t/sqlmaker/oracle.t index cd3e629c6..31fc4961c 100644 --- a/t/sqlmaker/oracle.t +++ b/t/sqlmaker/oracle.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'id_shortener'; use strict; @@ -6,7 +7,7 @@ use warnings; use Test::More; use Test::Exception; use Data::Dumper::Concise; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::Oracle; diff --git a/t/sqlmaker/oraclejoin.t b/t/sqlmaker/oraclejoin.t index 11298b026..de49bbfbb 100644 --- a/t/sqlmaker/oraclejoin.t +++ b/t/sqlmaker/oraclejoin.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'id_shortener'; use strict; @@ -5,7 +6,6 @@ use warnings; use Test::More; -use lib qw(t/lib); use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::OracleJoins; diff --git a/t/sqlmaker/order_by_bindtransport.t b/t/sqlmaker/order_by_bindtransport.t index 24da80ed9..f99a19182 100644 --- a/t/sqlmaker/order_by_bindtransport.t +++ b/t/sqlmaker/order_by_bindtransport.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; use Data::Dumper::Concise; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; sub test_order { diff --git a/t/sqlmaker/order_by_func.t b/t/sqlmaker/order_by_func.t index 96092195b..3ba4a17b5 100644 --- a/t/sqlmaker/order_by_func.t +++ b/t/sqlmaker/order_by_func.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema(); diff --git a/t/sqlmaker/quotes.t b/t/sqlmaker/quotes.t index 4a5357b7d..f76ffb9ad 100644 --- a/t/sqlmaker/quotes.t +++ b/t/sqlmaker/quotes.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema( no_deploy => 1 ); diff --git a/t/sqlmaker/sqlite.t b/t/sqlmaker/sqlite.t index 9c0b904d4..1c948c5f5 100644 --- a/t/sqlmaker/sqlite.t +++ b/t/sqlmaker/sqlite.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest ':DiffSQL'; my $schema = DBICTest->init_schema; diff --git a/t/storage/base.t b/t/storage/base.t index b7650a875..e40745a65 100644 --- a/t/storage/base.t +++ b/t/storage/base.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; use Data::Dumper; diff --git a/t/storage/cursor.t b/t/storage/cursor.t index ce0be84a0..93a316163 100644 --- a/t/storage/cursor.t +++ b/t/storage/cursor.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(cursor_class => 'DBICTest::Cursor'); diff --git a/t/storage/dbh_do.t b/t/storage/dbh_do.t index 727c245ef..1511f82e6 100644 --- a/t/storage/dbh_do.t +++ b/t/storage/dbh_do.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; diff --git a/t/storage/dbi_coderef.t b/t/storage/dbi_coderef.t index b5b7961a2..4bbae78e0 100644 --- a/t/storage/dbi_coderef.t +++ b/t/storage/dbi_coderef.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; plan tests => 1; diff --git a/t/storage/dbi_env.t b/t/storage/dbi_env.t index 462da111f..4e71ce59f 100644 --- a/t/storage/dbi_env.t +++ b/t/storage/dbi_env.t @@ -1,6 +1,8 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; -use lib qw(t/lib); + use DBICTest; use Test::More; use Test::Exception; diff --git a/t/storage/dbic_pretty.t b/t/storage/dbic_pretty.t index 1a1c32ef3..89f12dd39 100644 --- a/t/storage/dbic_pretty.t +++ b/t/storage/dbic_pretty.t @@ -1,9 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_prettydebug'; use strict; use warnings; -use lib qw(t/lib); + use DBICTest; use Test::More; diff --git a/t/storage/debug.t b/t/storage/debug.t index 3f5d39972..e3cef381e 100644 --- a/t/storage/debug.t +++ b/t/storage/debug.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; no warnings 'once'; @@ -15,7 +17,7 @@ use Test::More; use Test::Exception; use Try::Tiny; use File::Spec; -use lib qw(t/lib); + use DBICTest; use Path::Class qw/file/; diff --git a/t/storage/deploy.t b/t/storage/deploy.t index 3a1f66f85..64c2438e1 100644 --- a/t/storage/deploy.t +++ b/t/storage/deploy.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'deploy'; use strict; @@ -7,7 +8,7 @@ use Test::More; use Test::Exception; use Path::Class qw/dir/; -use lib qw(t/lib); + use DBICTest; local $ENV{DBI_DSN}; diff --git a/t/storage/deprecated_exception_source_bind_attrs.t b/t/storage/deprecated_exception_source_bind_attrs.t index f6dca5a39..3a6c2dd98 100644 --- a/t/storage/deprecated_exception_source_bind_attrs.t +++ b/t/storage/deprecated_exception_source_bind_attrs.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; { diff --git a/t/storage/disable_sth_caching.t b/t/storage/disable_sth_caching.t index 494780d63..5fc8e188e 100644 --- a/t/storage/disable_sth_caching.t +++ b/t/storage/disable_sth_caching.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; BEGIN { $ENV{DBICTEST_VIA_REPLICATED} = 0 } use Test::More; -use lib qw(t/lib); + use DBICTest; ##!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/t/storage/error.t b/t/storage/error.t index e01da7047..3cb7a2853 100644 --- a/t/storage/error.t +++ b/t/storage/error.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -5,7 +7,7 @@ use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; for my $conn_args ( diff --git a/t/storage/exception.t b/t/storage/exception.t index d96e336cf..3de6aa95f 100644 --- a/t/storage/exception.t +++ b/t/storage/exception.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; use DBICTest::Schema; diff --git a/t/storage/global_destruction.t b/t/storage/global_destruction.t index 6bddfd75a..674c116a7 100644 --- a/t/storage/global_destruction.t +++ b/t/storage/global_destruction.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -8,7 +10,7 @@ BEGIN { $ENV{DBIC_STORAGE_RETRY_DEBUG} = 1 } use DBIx::Class::Optional::Dependencies (); -use lib qw(t/lib); + use DBICTest; for my $type (qw/PG MYSQL SQLite/) { diff --git a/t/storage/nobindvars.t b/t/storage/nobindvars.t index b22975638..61eb3d22d 100644 --- a/t/storage/nobindvars.t +++ b/t/storage/nobindvars.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; { # Fake storage driver for SQLite + no bind variables diff --git a/t/storage/on_connect_call.t b/t/storage/on_connect_call.t index 265835cc2..c88105539 100644 --- a/t/storage/on_connect_call.t +++ b/t/storage/on_connect_call.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; no warnings qw/once redefine/; -use lib qw(t/lib); + use DBI; use DBICTest; use DBICTest::Schema; diff --git a/t/storage/on_connect_do.t b/t/storage/on_connect_do.t index 6fccbb1ae..28a7e3ab8 100644 --- a/t/storage/on_connect_do.t +++ b/t/storage/on_connect_do.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -10,7 +12,7 @@ use Test::More tests => 13; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; require DBI; diff --git a/t/storage/ping_count.t b/t/storage/ping_count.t index 28af647fb..4d472e7b4 100644 --- a/t/storage/ping_count.t +++ b/t/storage/ping_count.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $ping_count = 0; diff --git a/t/storage/prefer_stringification.t b/t/storage/prefer_stringification.t index ffb292a05..e1d3aa05b 100644 --- a/t/storage/prefer_stringification.t +++ b/t/storage/prefer_stringification.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; -use lib qw(t/lib); + use DBICTest; { diff --git a/t/storage/quote_names.t b/t/storage/quote_names.t index ac65fa07b..08fcd005f 100644 --- a/t/storage/quote_names.t +++ b/t/storage/quote_names.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Data::Dumper::Concise; use Try::Tiny; -use lib qw(t/lib); + use DBICTest; my %expected = ( diff --git a/t/storage/reconnect.t b/t/storage/reconnect.t index fc97ebd40..199213b92 100644 --- a/t/storage/reconnect.t +++ b/t/storage/reconnect.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -7,7 +9,7 @@ use File::Copy 'move'; use Scalar::Util 'weaken'; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $db_orig = DBICTest->_sqlite_dbfilename; diff --git a/t/storage/replicated.t b/t/storage/replicated.t index 82c809d30..8696ba2a0 100644 --- a/t/storage/replicated.t +++ b/t/storage/replicated.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_replicated'; use strict; @@ -5,7 +6,7 @@ use warnings; use Test::More; use DBIx::Class::_Util 'modver_gt_or_eq_and_lt'; -use lib qw(t/lib); + use DBICTest; BEGIN { diff --git a/t/storage/savepoints.t b/t/storage/savepoints.t index b0f3858c0..f99c9d5da 100644 --- a/t/storage/savepoints.t +++ b/t/storage/savepoints.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -5,7 +7,7 @@ use Test::More; use Test::Exception; use DBIx::Class::_Util qw(modver_gt_or_eq sigwarn_silencer scope_guard); -use lib qw(t/lib); + use DBICTest; { diff --git a/t/storage/stats.t b/t/storage/stats.t index c1643995c..58fbde05d 100644 --- a/t/storage/stats.t +++ b/t/storage/stats.t @@ -1,11 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; plan tests => 12; -use lib qw(t/lib); - use_ok('DBICTest'); my $schema = DBICTest->init_schema(); diff --git a/t/storage/txn.t b/t/storage/txn.t index f8e1b356d..9a462bffc 100644 --- a/t/storage/txn.t +++ b/t/storage/txn.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $code = sub { diff --git a/t/storage/txn_scope_guard.t b/t/storage/txn_scope_guard.t index 6c6d1df0e..56d602dac 100644 --- a/t/storage/txn_scope_guard.t +++ b/t/storage/txn_scope_guard.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -8,7 +10,7 @@ use Test::Exception; use List::Util 'shuffle'; use DBIx::Class::_Util 'sigwarn_silencer'; -use lib qw(t/lib); + use DBICTest; # Test txn_scope_guard diff --git a/t/update/all.t b/t/update/all.t index acc83878e..920e17c3e 100644 --- a/t/update/all.t +++ b/t/update/all.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/update/ident_cond.t b/t/update/ident_cond.t index d7d4cf00f..697925598 100644 --- a/t/update/ident_cond.t +++ b/t/update/ident_cond.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/update/type_aware.t b/t/update/type_aware.t index fd58319d6..eb8ac26c3 100644 --- a/t/update/type_aware.t +++ b/t/update/type_aware.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/t/zzzzzzz_authors.t b/t/zzzzzzz_authors.t index a46a247a8..18b771f85 100644 --- a/t/zzzzzzz_authors.t +++ b/t/zzzzzzz_authors.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More 'no_plan'; -use lib 't/lib'; + use DBICTest::RunMode; my $authorcount = scalar do { diff --git a/t/zzzzzzz_perl_perf_bug.t b/t/zzzzzzz_perl_perf_bug.t index 4434e1c74..85dd77c1e 100644 --- a/t/zzzzzzz_perl_perf_bug.t +++ b/t/zzzzzzz_perl_perf_bug.t @@ -1,7 +1,9 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + BEGIN { plan skip_all => diff --git a/xt/dist/authors.t b/xt/dist/authors.t index 8ee1bf37f..ff7d5e27c 100644 --- a/xt/dist/authors.t +++ b/xt/dist/authors.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; diff --git a/xt/dist/loadable_standalone_testschema_resultclasses.t b/xt/dist/loadable_standalone_testschema_resultclasses.t index f0dd2acb4..27629a71a 100644 --- a/xt/dist/loadable_standalone_testschema_resultclasses.t +++ b/xt/dist/loadable_standalone_testschema_resultclasses.t @@ -1,8 +1,11 @@ +BEGIN { + delete $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY}; + do "./t/lib/ANFANG.pm" or die ( $@ || $! ) +} + use warnings; use strict; -BEGIN { delete $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY} } - use DBIx::Class::_Util 'sigwarn_silencer'; use if DBIx::Class::_ENV_::BROKEN_FORK, 'threads'; @@ -10,9 +13,6 @@ use Test::More; use File::Find; use Time::HiRes 'sleep'; - -use lib 't/lib'; - my $worker = sub { my $fn = shift; diff --git a/xt/dist/pod_coverage.t b/xt/dist/pod_coverage.t index 1f3195a4a..a3acbe407 100644 --- a/xt/dist/pod_coverage.t +++ b/xt/dist/pod_coverage.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_podcoverage'; use warnings; @@ -6,7 +7,7 @@ use strict; use Test::More; use List::Util 'first'; use Module::Runtime 'require_module'; -use lib qw(t/lib maint/.Generated_Pod/lib); +use lib 'maint/.Generated_Pod/lib'; use DBICTest; use namespace::clean; diff --git a/xt/dist/postdistdir/pod_validity.t b/xt/dist/postdistdir/pod_validity.t index 773e5acfd..49291adac 100644 --- a/xt/dist/postdistdir/pod_validity.t +++ b/xt/dist/postdistdir/pod_validity.t @@ -1,10 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_pod'; use warnings; use strict; use Test::More; -use lib qw(t/lib); + use DBICTest; # this has already been required but leave it here for CPANTS static analysis diff --git a/xt/dist/postdistdir/whitespace.t b/xt/dist/postdistdir/whitespace.t index 3576da6e5..9b2ba87b4 100644 --- a/xt/dist/postdistdir/whitespace.t +++ b/xt/dist/postdistdir/whitespace.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_whitespace'; use warnings; @@ -5,7 +6,7 @@ use strict; use Test::More; use File::Glob 'bsd_glob'; -use lib 't/lib'; + use DBICTest ':GlobalLock'; # FIXME - temporary workaround for RT#82032, RT#82033 diff --git a/xt/dist/strictures.t b/xt/dist/strictures.t index 70efc7cfd..c896c955a 100644 --- a/xt/dist/strictures.t +++ b/xt/dist/strictures.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_strictures'; use warnings; @@ -7,7 +8,7 @@ use Test::More; use File::Find; use File::Spec; use Config; -use lib 't/lib'; + use DBICTest; # The rationale is - if we can load all our optdeps @@ -42,7 +43,9 @@ find({ | t/lib/DBICTest/Util/OverrideRequire.pm # no stictures by design (load order sensitive) | - lib/DBIx/Class/Optional/Dependencies.pm # no stictures by design (load spee sensitive) + t/lib/ANFANG.pm # no stictures by design (load speed sensitive) + | + lib/DBIx/Class/Optional/Dependencies.pm # no stictures by design (load speed sensitive) )$}x; my $f = $_; diff --git a/xt/extra/c3_mro.t b/xt/extra/c3_mro.t index 55effb5a9..ae404043c 100644 --- a/xt/extra/c3_mro.t +++ b/xt/extra/c3_mro.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; -use lib qw(t/lib); + use DBICTest; # do not remove even though it is not used (pulls in MRO::Compat if needed) { diff --git a/xt/extra/dbicadmin.t b/xt/extra/dbicadmin.t index cc79190f8..3f05ac202 100644 --- a/xt/extra/dbicadmin.t +++ b/xt/extra/dbicadmin.t @@ -1,18 +1,20 @@ -use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_admin_script'; - -use strict; -use warnings; - BEGIN { # just in case the user env has stuff in it delete $ENV{JSON_ANY_ORDER}; delete $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY}; + + do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } +use strict; +use warnings; + +use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_admin_script'; + use Test::More; use Config; use File::Spec; -use lib qw(t/lib); + use DBICTest; $ENV{PATH} = ''; @@ -71,7 +73,7 @@ sub test_dbicadmin { my ($perl) = $^X =~ /(.*)/; - open(my $fh, "-|", ( $perl, '-MDBICTest::RunMode', 'script/dbicadmin', default_args(), qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!; + open(my $fh, "-|", ( $perl, '-MANFANG', 'script/dbicadmin', default_args(), qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!; my $data = do { local $/; <$fh> }; close($fh); if (!ok( ($data=~/Aran.*Trout/s), "$ENV{JSON_ANY_ORDER}: select with attrs" )) { @@ -101,7 +103,7 @@ sub default_args { sub test_exec { my ($perl) = $^X =~ /(.*)/; - my @args = ($perl, '-MDBICTest::RunMode', File::Spec->catfile(qw(script dbicadmin)), @_); + my @args = ($perl, '-MANFANG', File::Spec->catfile(qw(script dbicadmin)), @_); if ($^O eq 'MSWin32') { require Win32::ShellQuote; # included in test optdeps diff --git a/xt/extra/diagnostics/deprecated_rs_attributes.t b/xt/extra/diagnostics/deprecated_rs_attributes.t index 8eed20bf2..2f458c064 100644 --- a/xt/extra/diagnostics/deprecated_rs_attributes.t +++ b/xt/extra/diagnostics/deprecated_rs_attributes.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/xt/extra/diagnostics/malformed_rel_declaration.t b/xt/extra/diagnostics/malformed_rel_declaration.t index a1abdb7c0..70a803e34 100644 --- a/xt/extra/diagnostics/malformed_rel_declaration.t +++ b/xt/extra/diagnostics/malformed_rel_declaration.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest::Schema::Artist; my $pkg = 'DBICTest::Schema::Artist'; diff --git a/xt/extra/diagnostics/many_to_many_warning.t b/xt/extra/diagnostics/many_to_many_warning.t index 2c42091bf..c416e4141 100644 --- a/xt/extra/diagnostics/many_to_many_warning.t +++ b/xt/extra/diagnostics/many_to_many_warning.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $exp_warn = qr/The many-to-many relationship 'bars' is trying to create/; diff --git a/xt/extra/diagnostics/resultset_manager.t b/xt/extra/diagnostics/resultset_manager.t index fad560d11..28c2d9d62 100644 --- a/xt/extra/diagnostics/resultset_manager.t +++ b/xt/extra/diagnostics/resultset_manager.t @@ -1,9 +1,11 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Warn; -use lib qw(t/lib); + use DBICTest; warnings_exist { require DBICTest::ResultSetManager } diff --git a/xt/extra/diagnostics/search_in_void_ctx.t b/xt/extra/diagnostics/search_in_void_ctx.t index 95a040f8d..d63ee1c98 100644 --- a/xt/extra/diagnostics/search_in_void_ctx.t +++ b/xt/extra/diagnostics/search_in_void_ctx.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(no_deploy => 1); diff --git a/xt/extra/diagnostics/unresolvable_relationship.t b/xt/extra/diagnostics/unresolvable_relationship.t index 5a53cd9d3..23a4d887e 100644 --- a/xt/extra/diagnostics/unresolvable_relationship.t +++ b/xt/extra/diagnostics/unresolvable_relationship.t @@ -1,10 +1,12 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/xt/extra/internals/dbictest_unlink_guard.t b/xt/extra/internals/dbictest_unlink_guard.t index 83a38e9de..9ab5c1bcd 100644 --- a/xt/extra/internals/dbictest_unlink_guard.t +++ b/xt/extra/internals/dbictest_unlink_guard.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; use Test::More; -use lib 't/lib'; + use DBICTest; # Once upon a time there was a problem with a leaking $sth diff --git a/xt/extra/internals/discard_changes_in_DESTROY.t b/xt/extra/internals/discard_changes_in_DESTROY.t index 736664d54..a5fa8e038 100644 --- a/xt/extra/internals/discard_changes_in_DESTROY.t +++ b/xt/extra/internals/discard_changes_in_DESTROY.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/xt/extra/internals/ensure_class_loaded.t b/xt/extra/internals/ensure_class_loaded.t index e933c00a3..3dba83dbc 100644 --- a/xt/extra/internals/ensure_class_loaded.t +++ b/xt/extra/internals/ensure_class_loaded.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; use Class::Inspector; diff --git a/xt/extra/internals/merge_joinpref_attr.t b/xt/extra/internals/merge_joinpref_attr.t index bb7735800..7a242bd74 100644 --- a/xt/extra/internals/merge_joinpref_attr.t +++ b/xt/extra/internals/merge_joinpref_attr.t @@ -1,8 +1,10 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; -use lib qw(t/lib); + use DBICTest; use Test::More; diff --git a/xt/extra/internals/namespaces_cleaned.t b/xt/extra/internals/namespaces_cleaned.t index 552a81ecf..b8b42b7d7 100644 --- a/xt/extra/internals/namespaces_cleaned.t +++ b/xt/extra/internals/namespaces_cleaned.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + BEGIN { if ( "$]" < 5.010) { @@ -16,7 +18,7 @@ BEGIN { # we want to do this here, in the very beginning, before even # warnings/strict are loaded - unshift @INC, 't/lib'; + require DBICTest::Util::OverrideRequire; DBICTest::Util::OverrideRequire::override_global_require( sub { @@ -35,8 +37,6 @@ use warnings; use Test::More; -use lib 't/lib'; - use DBICTest; use File::Find; use File::Spec; diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index 2a5c8d5ea..af1f3e8e2 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -1,3 +1,5 @@ +BEGIN { $ENV{DBICTEST_ANFANG_DEFANG} = 1 } + # Use a require override instead of @INC munging (less common) # Do the override as early as possible so that CORE::require doesn't get compiled away diff --git a/xt/extra/multicreate_opcount.t b/xt/extra/multicreate_opcount.t index 4184f06e0..06369d928 100644 --- a/xt/extra/multicreate_opcount.t +++ b/xt/extra/multicreate_opcount.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -7,7 +9,7 @@ BEGIN { } use Test::Exception; -use lib qw(t/lib); + use DBICTest; my $schema = DBICTest->init_schema(); diff --git a/xt/extra/sqlite_deadlock.t b/xt/extra/sqlite_deadlock.t index a9fdca95f..f50175e1c 100644 --- a/xt/extra/sqlite_deadlock.t +++ b/xt/extra/sqlite_deadlock.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; @@ -5,7 +7,7 @@ use Test::More; use Test::Exception; use File::Temp (); -use lib 't/lib'; + use DBICTest; plan tests => 2; diff --git a/xt/extra/sqlite_view_deps.t b/xt/extra/sqlite_view_deps.t index 39bb63252..3aabe1594 100644 --- a/xt/extra/sqlite_view_deps.t +++ b/xt/extra/sqlite_view_deps.t @@ -1,3 +1,4 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use DBIx::Class::Optional::Dependencies -skip_all_without => 'deploy'; use strict; @@ -6,7 +7,7 @@ use warnings; use Test::More; use Test::Exception; use Test::Warn; -use lib qw(t/lib); + use DBICTest; use ViewDeps; use ViewDepsBad; From 7b87b77c04e07cfea1103dba8ecbd3f219e949d2 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 15 Feb 2016 12:42:13 +0100 Subject: [PATCH 013/262] Revert ab340f7f - it no longer makes sense given the excellent CI setup There should be no functional changes / difference in behavior (the config option is named differently, and is inverted in meaning) Verified no change in behavior (at least on CI) via: ( not checking all 20+ jobs as the log-counter jumps towards the end ) for n in $(seq 18) ; do x=$((112787688 + $n)) && \ y=$((112787738 + $n)) && \ echo "$x => $y" && \ diff -U0 \ <(wget -qO- https://s3.amazonaws.com/archive.travis-ci.org/jobs/$x/log.txt | \ perl -0777 -n -E 'say ( ($_ =~ /List of loadable modules within both the core and(.+?)List of loadable modules within both the core and/s )[0] )') \ <(wget -qO- https://s3.amazonaws.com/archive.travis-ci.org/jobs/$y/log.txt | \ perl -0777 -n -E 'say ( ($_ =~ /List of loadable modules within both the core and(.+?)List of loadable modules within both the core and/s )[0] )') done | less This also happened to find https://rt.cpan.org/Ticket/Display.html?id=112601 --- Makefile.PL | 10 +- maint/Makefile.PL.inc/11_authortests.pl | 4 +- maint/Makefile.PL.inc/12_authordeps.pl | 14 ++- maint/travis-ci_scripts/30_before_script.bash | 12 ++- maint/travis-ci_scripts/50_after_success.bash | 2 +- t/lib/ANFANG.pm | 6 ++ t/lib/DBICTest/RunMode.pm | 102 +----------------- 7 files changed, 30 insertions(+), 120 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index f4ac1b863..0be14e881 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -99,7 +99,7 @@ my $test_requires = { # tests will fail # Note - these are added as test_requires *directly*, so they get properly # excluded on META.yml cleansing (even though no dist can be created from this) -# we force these reqs regarless of author_deps, worst case scenario they will +# we force these reqs regarless of --with-optdeps, worst case scenario they will # be specified twice # # also note that we *do* set dynamic_config => 0, as these are the only things @@ -205,10 +205,10 @@ sub invoke_author_mode { config => [qw/gnu_getopt bundling_override no_ignore_case pass_through/] ); my $args = { - skip_author_deps => undef, + with_optdeps => undef, }; $getopt->getoptions($args, qw/ - skip_author_deps|skip-author-deps + with_optdeps|with-optdeps /); if (@ARGV) { warn "\nIgnoring unrecognized option(s): @ARGV\n\n"; @@ -236,10 +236,6 @@ sub invoke_author_mode { "\t" . $mm_proto->oneliner( qq(\$ENV{PERLIO}='unix' and system( \$^X, qw( -MExtUtils::Command -e dos2unix -- ), $targets ) ) ); }; - # we are in the process of (re)writing the makefile - some things we - # call below very well may fail - local $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION} = 1; - require File::Spec; # string-eval, not do(), because we need to provide the # $mm_proto, $reqs and $*_requires lexicals to the included file diff --git a/maint/Makefile.PL.inc/11_authortests.pl b/maint/Makefile.PL.inc/11_authortests.pl index 7760de2ef..77bb071bb 100644 --- a/maint/Makefile.PL.inc/11_authortests.pl +++ b/maint/Makefile.PL.inc/11_authortests.pl @@ -31,7 +31,7 @@ # perl cmd join( ' ', '$(ABSPERLRUN)', - map { $mm_proto->quote_literal($_) } qw(-e $ENV{RELEASE_TESTING}=1;$ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}=1;) + map { $mm_proto->quote_literal($_) } qw(-e $ENV{RELEASE_TESTING}=1;$ENV{HARNESS_OPTIONS}=j4;) ), # test list join( ' ', @@ -50,7 +50,7 @@ # perl cmd join( ' ', '$(ABSPERLRUN)', - map { $mm_proto->quote_literal($_) } qw(-Ilib -e $ENV{RELEASE_TESTING}=1;$ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}=1;) + map { $mm_proto->quote_literal($_) } qw(-Ilib -e $ENV{RELEASE_TESTING}=1;$ENV{HARNESS_OPTIONS}=j4;) ), 'xt/dist/postdistdir/*.t', ) diff --git a/maint/Makefile.PL.inc/12_authordeps.pl b/maint/Makefile.PL.inc/12_authordeps.pl index e83e03db5..e6d7f3432 100644 --- a/maint/Makefile.PL.inc/12_authordeps.pl +++ b/maint/Makefile.PL.inc/12_authordeps.pl @@ -1,6 +1,6 @@ my ($optdep_msg, $opt_testdeps); -if ($args->{skip_author_deps}) { +unless ($args->{with_optdeps}) { $optdep_msg = <<'EOW'; ****************************************************************************** @@ -9,8 +9,12 @@ *** IGNORING AUTHOR MODE: no optional test dependencies will be forced. *** *** *** *** If you are using this checkout with the intention of submitting a DBIC *** -*** patch, you are *STRONGLY ENCOURAGED* to install all dependencies, so *** -*** that every possible unit-test will run. *** +*** patch you may want to aim at running more tests by re-configuring via: *** +*** *** +*** perl Makefile.PL --with-optdeps *** +*** *** +*** which will install all optional dependencies. This is not a mandatory *** +*** step - the extensive CI setup will likely catch your mistakes anyway. *** *** *** ****************************************************************************** ****************************************************************************** @@ -23,8 +27,8 @@ ****************************************************************************** ****************************************************************************** *** *** -*** AUTHOR MODE: all optional test dependencies converted to hard requires *** -*** ( to disable re-run Makefile.PL with --skip-author-deps ) *** +*** --with-optdeps specified: converting all optional test dependencies to *** +*** hard requires ( to disable re-run Makefile.PL without options ) *** *** *** ****************************************************************************** ****************************************************************************** diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 603344050..3da762ac2 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -114,13 +114,12 @@ else fi fi -# generate the makefile which will have different deps depending on -# the runmode and envvars set above -run_or_err "Configure on current branch" "perl Makefile.PL" # install (remaining) dependencies, sometimes with a gentle push if [[ "$CLEANTEST" = "true" ]]; then + run_or_err "Configure on current branch" "perl Makefile.PL" + # we are doing a devrel pass - try to upgrade *everything* (we will be using cpanm so safe-ish) if [[ "$DEVREL_DEPS" == "true" ]] ; then @@ -143,16 +142,19 @@ if [[ "$CLEANTEST" = "true" ]]; then installdeps $HARD_DEPS + run_or_err "Re-configure" "perl Makefile.PL" + else + run_or_err "Configure on current branch with --with-optdeps" "perl Makefile.PL --with-optdeps" + parallel_installdeps_notest "$(make listdeps | sort -R)" + run_or_err "Re-configure with --with-optdeps" "perl Makefile.PL --with-optdeps" fi echo_err "$(tstamp) Dependency installation finished" -run_or_err "Re-configure" "perl Makefile.PL" - # make sure we got everything we need if [[ -n "$(make listdeps)" ]] ; then echo_err "$(tstamp) Not all deps installed - something went wrong :(" diff --git a/maint/travis-ci_scripts/50_after_success.bash b/maint/travis-ci_scripts/50_after_success.bash index 9642c3e84..a6dfecc96 100755 --- a/maint/travis-ci_scripts/50_after_success.bash +++ b/maint/travis-ci_scripts/50_after_success.bash @@ -27,7 +27,7 @@ if [[ "$DEVREL_DEPS" == "true" ]] && perl -M5.008003 -e1 &>/dev/null ; then # FIXME Change when Moose goes away installdeps Moose $(perl -Ilib -MDBIx::Class::Optional::Dependencies=-list_missing,dist_dir) - run_or_err "Attempt to build a dist" "rm -rf inc/ && perl Makefile.PL --skip-author-deps && make dist" + run_or_err "Attempt to build a dist" "rm -rf inc/ && perl Makefile.PL && make dist" tarball_assembled=1 elif [[ "$CLEANTEST" != "true" ]] ; then diff --git a/t/lib/ANFANG.pm b/t/lib/ANFANG.pm index 444cf4180..d66322af3 100644 --- a/t/lib/ANFANG.pm +++ b/t/lib/ANFANG.pm @@ -123,4 +123,10 @@ BEGIN { use lib 't/lib'; +# Back in ab340f7f ribasushi stupidly introduced a "did you check your deps" +# verification tied very tightly to Module::Install. The check went away, and +# so eventually will M::I, but bisecting can bring all of this back from the +# dead. In order to reduce hair-pulling make sure that ./inc/ is always there +-f 'Makefile.PL' and mkdir 'inc' and mkdir 'inc/.author'; + 1; diff --git a/t/lib/DBICTest/RunMode.pm b/t/lib/DBICTest/RunMode.pm index 178378e70..b15139202 100644 --- a/t/lib/DBICTest/RunMode.pm +++ b/t/lib/DBICTest/RunMode.pm @@ -14,8 +14,6 @@ use DBICTest::Util qw( local_umask find_co_root ); # return a Path::Class::Dir object or undef sub _find_co_root { eval { dir( find_co_root() ) } } -_check_author_makefile() unless $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}; - # PathTools has a bug where on MSWin32 it will often return / as a tmpdir. # This is *really* stupid and the result of having our lockfiles all over # the place is also rather obnoxious. So we use our own heuristics instead @@ -83,109 +81,13 @@ EOE } -# Die if the author did not update his makefile -# -# This is pretty heavy handed, so the check is pretty solid: -# -# 1) Assume that this particular module is loaded from -I <$root>/t/lib -# 2) Make sure <$root>/Makefile.PL exists -# 3) Make sure we can stat() <$root>/Makefile.PL -# -# If all of the above is satisfied -# -# *) die if <$root>/inc does not exist -# *) die if no stat() results for <$root>/Makefile (covers no Makefile) -# *) die if Makefile.PL mtime > Makefile mtime -# -sub _check_author_makefile { - - my $root = _find_co_root() - or return; - - my $optdeps = file('lib/DBIx/Class/Optional/Dependencies.pm'); - - # not using file->stat as it invokes File::stat which in turn breaks stat(_) - my ($mf_pl_mtime, $mf_mtime, $optdeps_mtime) = ( map - { (stat ($root->file ($_)) )[9] || undef } # stat returns () on nonexistent files - (qw|Makefile.PL Makefile|, $optdeps) - ); - - return unless $mf_pl_mtime; # something went wrong during co_root detection ? - - my @fail_reasons; - - if(not -d $root->subdir ('inc')) { - push @fail_reasons, "Missing ./inc directory"; - } - - if(not $mf_mtime) { - push @fail_reasons, "Missing ./Makefile"; - } - else { - if($mf_mtime < $mf_pl_mtime) { - push @fail_reasons, "./Makefile.PL is newer than ./Makefile"; - } - if($mf_mtime < $optdeps_mtime) { - push @fail_reasons, "./$optdeps is newer than ./Makefile"; - } - } - - if (@fail_reasons) { - print STDERR <<'EOE'; - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -======================== FATAL ERROR =========================== -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -We have a number of reasons to believe that this is a development -checkout and that you, the user, did not run `perl Makefile.PL` -before using this code. You absolutely _must_ perform this step, -to ensure you have all required dependencies present. Not doing -so often results in a lot of wasted time for other contributors -trying to assist you with spurious "its broken!" problems. - -By default DBICs Makefile.PL turns all optional dependencies into -*HARD REQUIREMENTS*, in order to make sure that the entire test -suite is executed, and no tests are skipped due to missing modules. -If you for some reason need to disable this behavior - supply the ---skip_author_deps option when running perl Makefile.PL - -If you are seeing this message unexpectedly (i.e. you are in fact -attempting a regular installation be it through CPAN or manually), -please report the situation to either the mailing list or to the -irc channel as described in - -http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT - -The DBIC team - - -Reasons you received this message: - -EOE - - foreach my $r (@fail_reasons) { - print STDERR " * $r\n"; - } - print STDERR "\n\n\n"; - - require Time::HiRes; - Time::HiRes::sleep(0.005); - print STDOUT "\nBail out!\n"; - exit 1; - } -} - # Mimic $Module::Install::AUTHOR sub is_author { - my $root = _find_co_root() - or return undef; - return ( - ( not -d $root->subdir ('inc') ) + ! -d 'inc/Module' or - ( -e $root->subdir ('inc')->subdir ($^O eq 'VMS' ? '_author' : '.author') ) + -e 'inc/.author' ); } From 439a7283a981f27a56e745d99e456fc50a5a018f Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 17 Feb 2016 11:01:20 +0100 Subject: [PATCH 014/262] Move tmpdir() to DBICTest::Util where it belongs This detangles things even more. Add some extra logic fixes to the hideous routine while we are at it... Some notes on the actual test pefrormed: there have been cases on smokers where a returned directory was not in fact writable [1]. Thus work harder making sure everything works. The check is expensive but not terribly so: about 14ms on cold caches ( echo 3 > /proc/sys/vm/drop_caches ) and ~6ms thereafter. This adds up to 2 seconds over the current 320 tests. Timed via: ~$ perl -It/lib -Ilib -MANFANG -MDBICTest::Util=tmpdir -MTime::HiRes=time -e ' my $t0 = time; sub delta_t { my $t = time; printf "%.06f\n", $t - $t0; $t0 = $t } delta_t(); print tmpdir . "\n"; delta_t(); print tmpdir . "\n"; delta_t(); print tmpdir . "\n"; delta_t(); ' [1] http://www.cpantesters.org/cpan/report/36d4436d-7888-1014-a278-e5322b825c07 --- lib/DBIx/Class/_Util.pm | 8 ++- t/35exception_inaction.t | 3 +- t/52leaks.t | 4 ++ t/inflate/file_column.t | 6 +-- t/lib/DBICTest.pm | 5 +- t/lib/DBICTest/BaseSchema.pm | 4 +- t/lib/DBICTest/RunMode.pm | 78 --------------------------- t/lib/DBICTest/Util.pm | 101 +++++++++++++++++++++++++++++++++-- 8 files changed, 117 insertions(+), 92 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 846920df4..b5991fb50 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -82,7 +82,7 @@ our @EXPORT_OK = qw( scope_guard detected_reinvoked_destructor is_exception dbic_internal_try quote_sub qsub perlstring serialize deep_clone - parent_dir + parent_dir mkdir_p UNRESOLVABLE_CONDITION ); @@ -451,6 +451,12 @@ sub parent_dir ($) { ; } +sub mkdir_p ($) { + require File::Path; + # do not ask for a recent version, use 1.x API calls + File::Path::mkpath([ "$_[0]" ]); # File::Path does not like objects +} + { my $list_ctx_ok_stack_marker; diff --git a/t/35exception_inaction.t b/t/35exception_inaction.t index ffbabc543..2a3023b62 100644 --- a/t/35exception_inaction.t +++ b/t/35exception_inaction.t @@ -12,6 +12,7 @@ BEGIN { } } +use DBICTest::Util 'tmpdir'; use File::Temp (); use DBIx::Class::_Util 'scope_guard'; use DBIx::Class::Schema; @@ -49,7 +50,7 @@ $schema->connection('dbi:SQLite::memory:'); # demonstrate utter breakage of the reconnection/retry logic # open(my $stderr_copy, '>&', *STDERR) or die "Unable to dup STDERR: $!"; -my $tf = File::Temp->new( UNLINK => 1 ); +my $tf = File::Temp->new( UNLINK => 1, DIR => tmpdir() ); my $output; diff --git a/t/52leaks.t b/t/52leaks.t index b61856d67..c7af7013b 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -443,6 +443,10 @@ for my $addr (keys %$weak_registry) { # T::B 2.0 has result objects and other fancyness delete $weak_registry->{$addr}; } + elsif ($names =~ /^Class::Struct/m) { + # remove this when Path::Class is gone, what a crock of shit + delete $weak_registry->{$addr}; + } elsif ($names =~ /^Hash::Merge/m) { # only clear one object of a specific behavior - more would indicate trouble delete $weak_registry->{$addr} diff --git a/t/inflate/file_column.t b/t/inflate/file_column.t index acbf46ba4..9c5203dcc 100644 --- a/t/inflate/file_column.t +++ b/t/inflate/file_column.t @@ -4,8 +4,10 @@ use strict; use warnings; use Test::More; + use DBICTest; use DBICTest::Schema; +use File::Temp (); use File::Compare; use Path::Class qw/file/; @@ -18,8 +20,6 @@ use Path::Class qw/file/; use warnings; use base qw/DBICTest::BaseResult/; - use File::Temp qw/tempdir/; - __PACKAGE__->load_components (qw/InflateColumn::File/); __PACKAGE__->table('file_columns'); @@ -28,7 +28,7 @@ use Path::Class qw/file/; file => { data_type => 'varchar', is_file_column => 1, - file_column_path => tempdir(CLEANUP => 1), + file_column_path => File::Temp->newdir( CLEANUP => 1, DIR => DBICTest::Util::tmpdir() ), size => 255 } ); diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index ad3bf3c28..91a0c7929 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -25,13 +25,12 @@ BEGIN { } -use DBICTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); +use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); use DBICTest::Schema; use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard ); use Carp; use Path::Class::File (); -use File::Spec; use Fcntl qw/:DEFAULT :flock/; use Config; @@ -104,7 +103,7 @@ our ($global_lock_fh, $global_exclusive_lock); sub import { my $self = shift; - my $lockpath = DBICTest::RunMode->tmpdir->file('_dbictest_global.lock'); + my $lockpath = tmpdir . '_dbictest_global.lock'; { my $u = local_umask(0); # so that the file opens as 666, and any user can lock diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index f210c2d65..328b950f7 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -9,7 +9,7 @@ use Fcntl qw(:DEFAULT :seek :flock); use Time::HiRes 'sleep'; use DBIx::Class::_Util 'scope_guard'; use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry); -use DBICTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); +use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); use namespace::clean; if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { @@ -243,7 +243,7 @@ sub connection { undef $locker; - my $lockpath = DBICTest::RunMode->tmpdir->file("_dbictest_$locktype.lock"); + my $lockpath = tmpdir . "_dbictest_$locktype.lock"; DEBUG_TEST_CONCURRENCY_LOCKS and dbg "Waiting for $locktype LOCK: $lockpath..."; diff --git a/t/lib/DBICTest/RunMode.pm b/t/lib/DBICTest/RunMode.pm index b15139202..82da4df23 100644 --- a/t/lib/DBICTest/RunMode.pm +++ b/t/lib/DBICTest/RunMode.pm @@ -4,86 +4,8 @@ package # hide from PAUSE use strict; use warnings; -use Path::Class qw/file dir/; -use Fcntl ':DEFAULT'; -use File::Spec (); -use File::Temp (); -use DBICTest::Util qw( local_umask find_co_root ); - -# Try to determine the root of a checkout/untar if possible -# return a Path::Class::Dir object or undef -sub _find_co_root { eval { dir( find_co_root() ) } } - -# PathTools has a bug where on MSWin32 it will often return / as a tmpdir. -# This is *really* stupid and the result of having our lockfiles all over -# the place is also rather obnoxious. So we use our own heuristics instead -# https://rt.cpan.org/Ticket/Display.html?id=76663 -my $tmpdir; -sub tmpdir { - dir ($tmpdir ||= do { - - # works but not always - my $dir = dir(File::Spec->tmpdir); - my $reason_dir_unusable; - - my @parts = File::Spec->splitdir($dir); - if (@parts == 2 and $parts[1] =~ /^ [\/\\]? $/x ) { - $reason_dir_unusable = - 'File::Spec->tmpdir returned a root directory instead of a designated ' - . 'tempdir (possibly https://rt.cpan.org/Ticket/Display.html?id=76663)'; - } - else { - # make sure we can actually create and sysopen a file in this dir - local $@; - my $u = local_umask(0); # match the umask we use in DBICTest(::Schema) - my $tempfile = ''; - eval { - $tempfile = File::Temp->new( - TEMPLATE => '_dbictest_writability_test_XXXXXX', - DIR => "$dir", - UNLINK => 1, - ); - close $tempfile or die "closing $tempfile failed: $!\n"; - - sysopen (my $tempfh2, "$tempfile", O_RDWR) or die "reopening $tempfile failed: $!\n"; - print $tempfh2 'deadbeef' x 1024 or die "printing to $tempfile failed: $!\n"; - close $tempfh2 or die "closing $tempfile failed: $!\n"; - 1; - } or do { - chomp( my $err = $@ ); - my @x_tests = map { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' } map {(-e, -d, -f, -r, -w, -x, -o)} ("$dir", "$tempfile"); - $reason_dir_unusable = sprintf <<"EOE", "$tempfile"||'', $err, scalar $>, scalar $), umask(), (stat($dir))[4,5,2], @x_tests; -File::Spec->tmpdir returned a directory which appears to be non-writeable: -Error encountered while testing '%s': %s -Process EUID/EGID: %s / %s -Effective umask: %o -TmpDir UID/GID: %s / %s -TmpDir StatMode: %o -TmpDir X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s -TmpFile X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s -EOE - }; - } - - if ($reason_dir_unusable) { - # Replace with our local project tmpdir. This will make multiple runs - # from different runs conflict with each other, but is much better than - # polluting the root dir with random crap or failing outright - my $local_dir = _find_co_root()->subdir('t')->subdir('var'); - $local_dir->mkpath; - - warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n"; - $dir = $local_dir; - } - - $dir->stringify; - }); -} - - # Mimic $Module::Install::AUTHOR sub is_author { - return ( ! -d 'inc/Module' or diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index cbbce3536..c8893c8f2 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -13,14 +13,14 @@ use constant DEBUG_TEST_CONCURRENCY_LOCKS => use Config; use Carp qw(cluck confess croak); -use Fcntl ':flock'; +use Fcntl qw( :DEFAULT :flock ); use Scalar::Util qw(blessed refaddr); -use DBIx::Class::_Util qw( scope_guard parent_dir ); +use DBIx::Class::_Util qw( scope_guard parent_dir mkdir_p ); use base 'Exporter'; our @EXPORT_OK = qw( dbg stacktrace - local_umask find_co_root + local_umask tmpdir find_co_root visit_namespaces check_customcond_args await_flock DEBUG_TEST_CONCURRENCY_LOCKS @@ -132,10 +132,103 @@ sub find_co_root () { unless -f "${root}Makefile.PL"; } - $root; + # at this point we are pretty sure this is the right thing - detaint + ($root =~ /(.+)/)[0]; } } +my $tempdir; +sub tmpdir () { + $tempdir ||= do { + + require File::Spec; + my $dir = File::Spec->tmpdir; + $dir .= '/' unless $dir =~ / [\/\\] $ /x; + + # the above works but not always, test it to bits + my $reason_dir_unusable; + + # PathTools has a bug where on MSWin32 it will often return / as a tmpdir. + # This is *really* stupid and the result of having our lockfiles all over + # the place is also rather obnoxious. So we use our own heuristics instead + # https://rt.cpan.org/Ticket/Display.html?id=76663 + my @parts = File::Spec->splitdir($dir); + + # deal with how 'C:\\\\\\\\\\\\\\' decomposes + pop @parts while @parts and ! length $parts[-1]; + + if ( + @parts < 2 + or + ( @parts == 2 and $parts[1] =~ /^ [\/\\] $/x ) + ) { + $reason_dir_unusable = + 'File::Spec->tmpdir returned a root directory instead of a designated ' + . 'tempdir (possibly https://rt.cpan.org/Ticket/Display.html?id=76663)'; + } + else { + # make sure we can actually create and sysopen a file in this dir + + my $fn = $dir . "_dbictest_writability_test_$$"; + + my $u = local_umask(0); # match the umask we use in DBICTest(::Schema) + my $g = scope_guard { unlink $fn }; + + eval { + + if (-e $fn) { + unlink $fn or die "Unable to unlink pre-existing $fn: $!\n"; + } + + sysopen (my $tmpfh, $fn, O_RDWR|O_CREAT) or die "Opening $fn failed: $!\n"; + + print $tmpfh 'deadbeef' x 1024 or die "Writing to $fn failed: $!\n"; + + close $tmpfh or die "Closing $fn failed: $!\n"; + + 1; + } + or + do { + chomp( my $err = $@ ); + + my @x_tests = map + { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' } + map + { (-e, -d, -f, -r, -w, -x, -o)} + ($dir, $fn) + ; + + $reason_dir_unusable = sprintf <<"EOE", $fn, $err, scalar $>, scalar $), umask(), (stat($dir))[4,5,2], @x_tests; +File::Spec->tmpdir returned a directory which appears to be non-writeable: + +Error encountered while testing '%s': %s +Process EUID/EGID: %s / %s +Effective umask: %o +TmpDir UID/GID: %s / %s +TmpDir StatMode: %o +TmpDir X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s +TmpFile X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s +EOE + }; + } + + if ($reason_dir_unusable) { + # Replace with our local project tmpdir. This will make multiple tests + # from different runs conflict with each other, but is much better than + # polluting the root dir with random crap or failing outright + my $local_dir = find_co_root . 't/var/'; + + mkdir_p $local_dir; + + warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n\n"; + $dir = $local_dir; + } + + $dir; + }; +} + sub stacktrace { my $frame = shift; From 08a8d8f1b8a69ea29bcceb9f399214943a34905c Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 14 Feb 2016 11:39:14 +0100 Subject: [PATCH 015/262] Untangle strictly-DBICTest constant from the main constant set Not sure what I was thinking when I wrote this --- lib/DBIx/Class/Storage/DBI/Replicated.pm | 3 ++- lib/DBIx/Class/_Util.pm | 6 ----- t/52leaks.t | 10 ++++----- t/71mysql.t | 6 ++--- t/lib/DBICTest.pm | 10 ++++++--- t/lib/DBICTest/Util.pm | 28 +++++++++++++++++++----- t/storage/error.t | 7 +++--- xt/extra/lean_startup.t | 1 - 8 files changed, 42 insertions(+), 29 deletions(-) diff --git a/lib/DBIx/Class/Storage/DBI/Replicated.pm b/lib/DBIx/Class/Storage/DBI/Replicated.pm index 7d6111890..73998d2e7 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated.pm @@ -376,7 +376,8 @@ my $method_dispatch = { )], }; -if (DBIx::Class::_ENV_::DBICTEST) { +# this only happens during DBIC-internal testing +if ( $INC{"t/lib/ANFANG.pm"} ) { my $seen; for my $type (keys %$method_dispatch) { diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index b5991fb50..358a3aa7e 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -23,12 +23,6 @@ BEGIN { UNSTABLE_DOLLARAT => ( "$]" < 5.013002 ) ? 1 : 0, - DBICTEST => $INC{"DBICTest/Util.pm"} ? 1 : 0, - - # During 5.13 dev cycle HELEMs started to leak on copy - # add an escape for these perls ON SMOKERS - a user will still get death - PEEPEENESS => ( eval { DBICTest::RunMode->is_smoker } && ( "$]" >= 5.013005 and "$]" <= 5.013006) ), - ( map # # the "DBIC_" prefix below is crucial - this is what makes CI pick up diff --git a/t/52leaks.t b/t/52leaks.t index c7af7013b..cfeaadc4c 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -23,16 +23,16 @@ use strict; use warnings; use Test::More; +BEGIN { + require DBICTest::Util; + plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test" + if DBICTest::Util::PEEPEENESS(); +} use DBICTest::RunMode; use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs); use Scalar::Util qw(weaken blessed reftype); use DBIx::Class::_Util qw(hrefaddr sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt); -BEGIN { - plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test" - if DBIx::Class::_ENV_::PEEPEENESS; -} - my $TB = Test::More->builder; if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) { diff --git a/t/71mysql.t b/t/71mysql.t index 9d2c5d0f8..4ea9aa2e9 100644 --- a/t/71mysql.t +++ b/t/71mysql.t @@ -12,7 +12,7 @@ use B::Deparse; use DBI::Const::GetInfoType; use Scalar::Util qw/weaken/; - +use DBICTest::Util 'PEEPEENESS'; use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}; @@ -411,7 +411,7 @@ ZEROINSEARCH: { { local $TODO = "Perl $] is known to leak like a sieve" - if DBIx::Class::_ENV_::PEEPEENESS; + if PEEPEENESS; ok (! defined $orig_dbh, 'Parent $dbh handle is gone'); } @@ -435,7 +435,7 @@ ZEROINSEARCH: { { local $TODO = "Perl $] is known to leak like a sieve" - if DBIx::Class::_ENV_::PEEPEENESS; + if PEEPEENESS; ok (! defined $orig_dbh, 'DBIC operation triggered reconnect - old $dbh is gone'); } diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index 91a0c7929..762abacdb 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -7,6 +7,7 @@ use ANFANG; use strict; use warnings; + # this noop trick initializes the STDOUT, so that the TAP::Harness # issued IO::Select->can_read calls (which are blocking wtf wtf wtf) # keep spinning and scheduling jobs @@ -25,9 +26,12 @@ BEGIN { } -use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); -use DBICTest::Schema; +use DBICTest::Util qw( + local_umask tmpdir await_flock + dbg DEBUG_TEST_CONCURRENCY_LOCKS PEEPEENESS +); use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; +use DBICTest::Schema; use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard ); use Carp; use Path::Class::File (); @@ -276,7 +280,7 @@ sub __mk_disconnect_guard { return if ( # this perl leaks handles, delaying DESTROY, can't work right - DBIx::Class::_ENV_::PEEPEENESS + PEEPEENESS or ! -f $db_file ); diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index c8893c8f2..5911f9abc 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -5,11 +5,27 @@ use strict; use ANFANG; -use constant DEBUG_TEST_CONCURRENCY_LOCKS => - ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0] - || - 0 -; +use DBICTest::RunMode; + +use constant { + + DEBUG_TEST_CONCURRENCY_LOCKS => ( + ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0] + || + 0 + ), + + # During 5.13 dev cycle HELEMs started to leak on copy + # add an escape for these perls ON SMOKERS - a user/CI will still get death + # constname a homage to http://theoatmeal.com/comics/working_home + PEEPEENESS => ( + DBICTest::RunMode->is_smoker + and + ! DBICTest::RunMode->is_ci + and + ( "$]" >= 5.013005 and "$]" <= 5.013006) + ), +}; use Config; use Carp qw(cluck confess croak); @@ -21,7 +37,7 @@ use base 'Exporter'; our @EXPORT_OK = qw( dbg stacktrace local_umask tmpdir find_co_root - visit_namespaces + visit_namespaces PEEPEENESS check_customcond_args await_flock DEBUG_TEST_CONCURRENCY_LOCKS ); diff --git a/t/storage/error.t b/t/storage/error.t index 3cb7a2853..e8996fa87 100644 --- a/t/storage/error.t +++ b/t/storage/error.t @@ -7,7 +7,7 @@ use Test::More; use Test::Warn; use Test::Exception; - +use DBICTest::Util 'PEEPEENESS'; use DBICTest; for my $conn_args ( @@ -95,9 +95,8 @@ throws_ok ( # exception fallback: SKIP: { - if ( !!DBIx::Class::_ENV_::PEEPEENESS ) { - skip "Your perl version $] appears to leak like a sieve - skipping garbage collected \$schema test", 1; - } + skip "Your perl version $] appears to leak like a sieve - skipping garbage collected \$schema test", 1 + if PEEPEENESS; undef ($schema); throws_ok ( diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index af1f3e8e2..e699ee5dc 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -112,7 +112,6 @@ BEGIN { Sub::Defer Sub::Quote - File::Spec Scalar::Util List::Util Storable From 5a8d5308a40f3958a17335fdc35afddce7d4ae31 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 15 Feb 2016 12:40:34 +0100 Subject: [PATCH 016/262] Stop loading Time::HiRes in the base test schema - there is no need Switch all spots to a select()-based sleep instead --- lib/DBIx/Class/Schema/Versioned.pm | 4 ++-- t/39load_namespaces_stress.t | 5 ----- t/lib/DBICTest/BaseSchema.pm | 3 +-- xt/dist/loadable_standalone_testschema_resultclasses.t | 3 +-- 4 files changed, 4 insertions(+), 11 deletions(-) diff --git a/lib/DBIx/Class/Schema/Versioned.pm b/lib/DBIx/Class/Schema/Versioned.pm index d59961fec..2f130f618 100644 --- a/lib/DBIx/Class/Schema/Versioned.pm +++ b/lib/DBIx/Class/Schema/Versioned.pm @@ -203,7 +203,6 @@ use base 'DBIx::Class::Schema'; use DBIx::Class::Carp; use DBIx::Class::_Util 'dbic_internal_try'; -use Time::HiRes qw/gettimeofday/; use Scalar::Util 'weaken'; use namespace::clean; @@ -710,7 +709,8 @@ sub _set_db_version { # not possible to format the string sanely, as the column is a varchar(20). # The 'v' character is added to the front of the string, so that any version # formatted by this new function will sort _after_ any existing 200... strings. - my @tm = gettimeofday(); + require Time::HiRes; + my @tm = Time::HiRes::gettimeofday(); my @dt = gmtime ($tm[0]); my $o = $vtable->new_result({ version => $version, diff --git a/t/39load_namespaces_stress.t b/t/39load_namespaces_stress.t index b688669c8..ff64dbfa0 100644 --- a/t/39load_namespaces_stress.t +++ b/t/39load_namespaces_stress.t @@ -3,8 +3,6 @@ BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use strict; use warnings; use Test::More; -use Time::HiRes qw/gettimeofday/; - use DBICTest; # do not remove even though it is not used @@ -41,10 +39,7 @@ EOM is (DBICTest::NS::Stress::Schema->sources, 0, 'Start with no sources'); - -note gettimeofday . ":\tload_namespaces start"; DBICTest::NS::Stress::Schema->load_namespaces; -note gettimeofday . ":\tload_namespaces finished"; is (DBICTest::NS::Stress::Schema->sources, $src_count, 'All sources attached'); diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index 328b950f7..ac3cf8c70 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -6,7 +6,6 @@ use warnings; use base qw(DBICTest::Base DBIx::Class::Schema); use Fcntl qw(:DEFAULT :seek :flock); -use Time::HiRes 'sleep'; use DBIx::Class::_Util 'scope_guard'; use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry); use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); @@ -273,7 +272,7 @@ sub connection { for (1..50) { kill (0, $old_pid) or last; - sleep 0.1; + select( undef, undef, undef, 0.1 ); } DEBUG_TEST_CONCURRENCY_LOCKS diff --git a/xt/dist/loadable_standalone_testschema_resultclasses.t b/xt/dist/loadable_standalone_testschema_resultclasses.t index 27629a71a..5416df832 100644 --- a/xt/dist/loadable_standalone_testschema_resultclasses.t +++ b/xt/dist/loadable_standalone_testschema_resultclasses.t @@ -11,7 +11,6 @@ use if DBIx::Class::_ENV_::BROKEN_FORK, 'threads'; use Test::More; use File::Find; -use Time::HiRes 'sleep'; my $worker = sub { my $fn = shift; @@ -35,7 +34,7 @@ find({ if (DBIx::Class::_ENV_::BROKEN_FORK) { # older perls crash if threads are spawned way too quickly, sleep for 100 msecs my $t = threads->create(sub { $worker->($_) }); - sleep 0.1; + select( undef, undef, undef, 0.1); is ($t->join, 42, "Thread loading $_ did not finish successfully") || diag ($t->can('error') ? $t->error : 'threads.pm too old to retrieve the error :(' ); } From aff5e9c14f7ad7453a4a2a7d04dc4e85fa0d661c Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 1 Mar 2016 21:49:56 +0100 Subject: [PATCH 017/262] Several cosmetic fixups, making next commit easier to read No notable functional changes, mostly de-File::Spec-ing spots that do not need it ( '/' works on Win32 just fine, and VMS is a looooong way off ) --- Makefile.PL | 3 +-- lib/DBIx/Class/Admin.pm | 8 +++++++- lib/DBIx/Class/InflateColumn/File.pm | 6 ++---- lib/DBIx/Class/Schema.pm | 4 +--- maint/Makefile.PL.inc/11_authortests.pl | 3 +-- maint/Makefile.PL.inc/12_authordeps.pl | 2 +- maint/Makefile.PL.inc/53_autogen_pod.pl | 8 ++++---- .../54_autogen_legalese_and_README.pl | 7 +++---- maint/Makefile.PL.inc/56_autogen_schema_files.pl | 8 ++++---- t/52leaks.t | 2 ++ t/admin/02ddl.t | 12 ++++++------ t/storage/reconnect.t | 6 ++---- t/storage/replicated.t | 14 ++++++-------- xt/extra/dbicadmin.t | 3 +-- 14 files changed, 41 insertions(+), 45 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index 0be14e881..c6b527355 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -236,11 +236,10 @@ sub invoke_author_mode { "\t" . $mm_proto->oneliner( qq(\$ENV{PERLIO}='unix' and system( \$^X, qw( -MExtUtils::Command -e dos2unix -- ), $targets ) ) ); }; - require File::Spec; # string-eval, not do(), because we need to provide the # $mm_proto, $reqs and $*_requires lexicals to the included file # (some includes *do* modify $reqs above) - for my $inc (sort glob ( File::Spec->catfile('maint', 'Makefile.PL.inc', '*') ) ) { + for my $inc (sort glob ( 'maint/Makefile.PL.inc/*' ) ) { my $src = do { local (@ARGV, $/) = $inc; <> } or die $!; eval "use warnings; use strict; $src" or die sprintf "Failed execution of %s: %s\n", diff --git a/lib/DBIx/Class/Admin.pm b/lib/DBIx/Class/Admin.pm index 60d8c9e73..f3e6b5876 100644 --- a/lib/DBIx/Class/Admin.pm +++ b/lib/DBIx/Class/Admin.pm @@ -340,7 +340,13 @@ sub create { my $schema = $self->schema(); - $schema->create_ddl_dir( $sqlt_type, (defined $schema->schema_version ? $schema->schema_version : ""), $self->sql_dir->stringify, $preversion, $sqlt_args ); + $schema->create_ddl_dir( + $sqlt_type, + (defined $schema->schema_version ? $schema->schema_version : ""), + $self->sql_dir, + $preversion, + $sqlt_args, + ); } diff --git a/lib/DBIx/Class/InflateColumn/File.pm b/lib/DBIx/Class/InflateColumn/File.pm index 3a515a8f6..b98398578 100644 --- a/lib/DBIx/Class/InflateColumn/File.pm +++ b/lib/DBIx/Class/InflateColumn/File.pm @@ -3,7 +3,6 @@ package DBIx::Class::InflateColumn::File; use strict; use warnings; use base 'DBIx::Class'; -use File::Path; use File::Copy; use Path::Class; use DBIx::Class::Carp; @@ -20,7 +19,6 @@ carp 'InflateColumn::File has entered a deprecation cycle. This component ' unless $ENV{DBIC_IC_FILE_NOWARN}; - __PACKAGE__->load_components(qw/InflateColumn/); sub register_column { @@ -68,7 +66,7 @@ sub delete { for ( keys %$colinfos ) { if ( $colinfos->{$_}{is_file_column} ) { - rmtree( [$self->_file_column_file($_)->dir], 0, 0 ); + $self->_file_column_file($_)->dir->rmtree; last; # if we've deleted one, we've deleted them all } } @@ -116,7 +114,7 @@ sub _save_file_column { return unless ref $value; my $fs_file = $self->_file_column_file($column, $value->{filename}); - mkpath [$fs_file->dir]; + $fs_file->dir->mkpath; # File::Copy doesn't like Path::Class (or any for that matter) objects, # thus ->stringify (http://rt.perl.org/rt3/Public/Bug/Display.html?id=59650) diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 0be8919f9..17427054b 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -1240,14 +1240,12 @@ format. sub ddl_filename { my ($self, $type, $version, $dir, $preversion) = @_; - require File::Spec; - $version = "$preversion-$version" if $preversion; my $class = blessed($self) || $self; $class =~ s/::/-/g; - return File::Spec->catfile($dir, "$class-$version-$type.sql"); + return "$dir/$class-$version-$type.sql"; } =head2 thaw diff --git a/maint/Makefile.PL.inc/11_authortests.pl b/maint/Makefile.PL.inc/11_authortests.pl index 77bb071bb..0643ca95a 100644 --- a/maint/Makefile.PL.inc/11_authortests.pl +++ b/maint/Makefile.PL.inc/11_authortests.pl @@ -1,4 +1,3 @@ -require File::Spec; require File::Find; my $xt_dist_dirs; @@ -9,7 +8,7 @@ ); }, 'xt/dist'); -my @xt_dist_tests = map { File::Spec->catfile($_, '*.t') } sort keys %$xt_dist_dirs; +my @xt_dist_tests = map { "$_/*.t" } sort keys %$xt_dist_dirs; # inject an explicit xt test run, mainly to check the contents of # lib and the generated POD's *before* anything is copied around diff --git a/maint/Makefile.PL.inc/12_authordeps.pl b/maint/Makefile.PL.inc/12_authordeps.pl index e6d7f3432..405bc1e09 100644 --- a/maint/Makefile.PL.inc/12_authordeps.pl +++ b/maint/Makefile.PL.inc/12_authordeps.pl @@ -120,7 +120,7 @@ END unlink 'Makefile'; exit 1; } - my $meta = do { local @ARGV = 'META.yml'; local $/; <> }; + my $meta = do { local (@ARGV, $/) = 'META.yml'; <> }; $meta =~ /^\Qname: DBIx-Class\E$/m or do { warn "Seemingly malformed META.yml...?\n"; diff --git a/maint/Makefile.PL.inc/53_autogen_pod.pl b/maint/Makefile.PL.inc/53_autogen_pod.pl index ff72fd9b0..c35073403 100644 --- a/maint/Makefile.PL.inc/53_autogen_pod.pl +++ b/maint/Makefile.PL.inc/53_autogen_pod.pl @@ -4,7 +4,7 @@ # leftovers in old checkouts unlink 'lib/DBIx/Class/Optional/Dependencies.pod' if -f 'lib/DBIx/Class/Optional/Dependencies.pod'; -File::Path::rmtree( File::Glob::bsd_glob('.generated_pod'), { verbose => 0 } ) +File::Path::rmtree([ '.generated_pod' ]) if -d '.generated_pod'; my $pod_dir = 'maint/.Generated_Pod'; @@ -12,7 +12,7 @@ # cleanup the generated pod dir (again - kill leftovers from old checkouts) if (-d $pod_dir) { - File::Path::rmtree( File::Glob::bsd_glob("$pod_dir/*"), { verbose => 0 } ); + File::Path::rmtree([ File::Glob::bsd_glob("$pod_dir/*") ]); } else { mkdir $pod_dir or die "Unable to create $pod_dir: $!"; @@ -95,7 +95,7 @@ # generate the DBIx/Class.pod only during distdir { - my $dist_pod_fn = File::Spec->catfile($pod_dir, qw(lib DBIx Class.pod)); + my $dist_pod_fn = "$pod_dir/lib/DBIx/Class.pod"; postamble <<"EOP"; @@ -146,7 +146,7 @@ dbic_clonedir_copy_generated_pod : \t\$(RM_F) $pod_dir.packlist \t@{[ - $mm_proto->oneliner("install([ from_to => {q($pod_dir) => File::Spec->curdir(), write => q($pod_dir.packlist)}, verbose => 0, uninstall_shadows => 0, skip => [] ])", ['-MExtUtils::Install']) + $mm_proto->oneliner("install([ from_to => {q($pod_dir) => './', write => q($pod_dir.packlist)}, verbose => 0, uninstall_shadows => 0, skip => [] ])", ['-MExtUtils::Install']) ]} EOP diff --git a/maint/Makefile.PL.inc/54_autogen_legalese_and_README.pl b/maint/Makefile.PL.inc/54_autogen_legalese_and_README.pl index 8b96f508b..16259af3e 100644 --- a/maint/Makefile.PL.inc/54_autogen_legalese_and_README.pl +++ b/maint/Makefile.PL.inc/54_autogen_legalese_and_README.pl @@ -5,9 +5,8 @@ # and simply appends them on *LAST*-come *FIRST*-serve basis. # This allows us to inject extra depenencies for standard EUMM targets -require File::Spec; -my $dir = File::Spec->catdir(qw(maint .Generated_Pod)); -my $r_fn = File::Spec->catfile($dir, 'README'); +my $dir = 'maint/.Generated_Pod'; +my $r_fn = "$dir/README"; my $start_file = sub { my $fn = $mm_proto->quote_literal(shift); @@ -32,7 +31,7 @@ create_distdir : dbic_distdir_regen_license dbic_distdir_regen_license : -@{[ $start_file->( File::Spec->catfile( Meta->name . '-' . Meta->version, 'LICENSE') ) ]} +@{[ $start_file->( Meta->name . '-' . Meta->version . '/LICENSE' ) ]} \t@{[ $mm_proto->oneliner('cat', ['-MExtUtils::Command']) ]} LICENSE >> \$(DISTVNAME)/LICENSE EOP diff --git a/maint/Makefile.PL.inc/56_autogen_schema_files.pl b/maint/Makefile.PL.inc/56_autogen_schema_files.pl index 0cd34a035..2e1efb92f 100644 --- a/maint/Makefile.PL.inc/56_autogen_schema_files.pl +++ b/maint/Makefile.PL.inc/56_autogen_schema_files.pl @@ -1,9 +1,8 @@ -require File::Spec; -my $test_ddl_fn = File::Spec->catfile(qw( t lib sqlite.sql )); +my $test_ddl_fn = 't/lib/sqlite.sql'; my @test_ddl_cmd = qw( -I lib -Mt::lib::ANFANG -- maint/gen_sqlite_schema_files --schema-class DBICTest::Schema ); -my $example_ddl_fn = File::Spec->catfile(qw( examples Schema db example.sql )); -my $example_db_fn = File::Spec->catfile(qw( examples Schema db example.db )); +my $example_ddl_fn = 'examples/Schema/db/example.sql'; +my $example_db_fn = 'examples/Schema/db/example.db'; my @example_ddl_cmd = qw( -I lib -I examples/Schema -- maint/gen_sqlite_schema_files --schema-class MyApp::Schema ); my @example_pop_cmd = qw( -I lib -I examples/Schema -- examples/Schema/insertdb.pl ); @@ -23,6 +22,7 @@ # if we don't do it some git tools (e.g. gitk) get confused that the # ddl file is modified, when it clearly isn't + require File::Spec; system('git status --porcelain >' . File::Spec->devnull); } diff --git a/t/52leaks.t b/t/52leaks.t index cfeaadc4c..6298c985d 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -538,6 +538,8 @@ SKIP: { local $ENV{DBICTEST_IN_PERSISTENT_ENV} = 1; + require File::Spec; + $persistence_tests = { PPerl => { cmd => [qw/pperl --prefork=1/, __FILE__], diff --git a/t/admin/02ddl.t b/t/admin/02ddl.t index 9b6d9e53c..84a73818e 100644 --- a/t/admin/02ddl.t +++ b/t/admin/02ddl.t @@ -31,7 +31,7 @@ my $ddl_dir = dir(qw/t var/, "admin_ddl-$$"); { # create the schema # make sure we are clean -clean_dir($ddl_dir); +cleanup(); my $admin = DBIx::Class::Admin->new( @@ -50,7 +50,7 @@ lives_ok { { # upgrade schema -clean_dir($ddl_dir); +cleanup(); require DBICVersion_v1; my $admin = DBIx::Class::Admin->new( @@ -92,7 +92,7 @@ is($schema->get_db_version, $DBICVersion::Schema::VERSION, 'Schema and db versio { # install -clean_dir($ddl_dir); +cleanup(); my $admin = DBIx::Class::Admin->new( schema_class => 'DBICVersion::Schema', @@ -115,14 +115,14 @@ warnings_exist ( sub { is($admin->schema->get_db_version, "4.0", 'db thinks its version 4.0'); } -sub clean_dir { +sub cleanup { my ($dir) = @_; - $dir->rmtree if -d $dir; + $ddl_dir->rmtree if -d $ddl_dir; unlink $db_fn; } END { - clean_dir($ddl_dir); + cleanup(); } done_testing; diff --git a/t/storage/reconnect.t b/t/storage/reconnect.t index 199213b92..c19f44f81 100644 --- a/t/storage/reconnect.t +++ b/t/storage/reconnect.t @@ -3,9 +3,7 @@ BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use strict; use warnings; -use FindBin; use B::Deparse; -use File::Copy 'move'; use Scalar::Util 'weaken'; use Test::More; use Test::Exception; @@ -48,7 +46,7 @@ cmp_ok(@art_two, '==', 3, "Three artists returned"); ### Now, disconnect the dbh, and move the db file; # create a new one full of garbage, prevent SQLite from connecting. $schema->storage->_dbh->disconnect; -move( $db_orig, $db_tmp ) +rename( $db_orig, $db_tmp ) or die "failed to move $db_orig to $db_tmp: $!"; open my $db_file, '>', $db_orig; print $db_file 'THIS IS NOT A REAL DATABASE'; @@ -67,7 +65,7 @@ ok (! $schema->storage->connected, 'We are not connected' ); ### Now, move the db file back to the correct name unlink($db_orig) or die "could not delete $db_orig: $!"; -move( $db_tmp, $db_orig ) +rename( $db_tmp, $db_orig ) or die "could not move $db_tmp to $db_orig: $!"; ### Try the operation again... this time, it should succeed diff --git a/t/storage/replicated.t b/t/storage/replicated.t index 8696ba2a0..9ecc7e826 100644 --- a/t/storage/replicated.t +++ b/t/storage/replicated.t @@ -19,14 +19,12 @@ BEGIN { use Test::Moose; use Test::Exception; -use List::Util 'first'; use Scalar::Util 'reftype'; -use File::Spec; use Moose(); use MooseX::Types(); note "Using Moose version $Moose::VERSION and MooseX::Types version $MooseX::Types::VERSION"; -my $var_dir = quotemeta ( File::Spec->catdir(qw/t var/) ); +my $var_dir_re = qr{ t [\/\\] var [\/\\] }x; ## Add a connect_info option to test option merging. use DBIx::Class::Storage::DBI::Replicated; @@ -157,8 +155,8 @@ TESTSCHEMACLASSES: { $self->master_path( DBICTest->_sqlite_dbfilename ); $self->slave_paths([ - File::Spec->catfile(qw/t var DBIxClass_slave1.db/), - File::Spec->catfile(qw/t var DBIxClass_slave2.db/), + 't/var/DBIxClass_slave1.db', + 't/var/DBIxClass_slave2.db', ]); return $self; @@ -376,7 +374,7 @@ ok @replicant_names, "found replicant names @replicant_names"; ## Silence warning about not supporting the is_replicating method if using the ## sqlite dbs. $replicated->schema->storage->debugobj->silence(1) - if first { $_ =~ /$var_dir/ } @replicant_names; + if grep { $_ =~ $var_dir_re } @replicant_names; isa_ok $replicated->schema->storage->balancer->current_replicant => 'DBIx::Class::Storage::DBI'; @@ -424,7 +422,7 @@ $replicated->schema->storage->replicants->{$replicant_names[1]}->active(1); ## Silence warning about not supporting the is_replicating method if using the ## sqlite dbs. $replicated->schema->storage->debugobj->silence(1) - if first { $_ =~ /$var_dir/ } @replicant_names; + if grep { $_ =~ $var_dir_re } @replicant_names; $replicated->schema->storage->pool->validate_replicants; @@ -607,7 +605,7 @@ $replicated->schema->storage->replicants->{$replicant_names[1]}->active(1); ## Silence warning about not supporting the is_replicating method if using the ## sqlite dbs. $replicated->schema->storage->debugobj->silence(1) - if first { $_ =~ /$var_dir/ } @replicant_names; + if grep { $_ =~ $var_dir_re } @replicant_names; $replicated->schema->storage->pool->validate_replicants; diff --git a/xt/extra/dbicadmin.t b/xt/extra/dbicadmin.t index 3f05ac202..db254f82c 100644 --- a/xt/extra/dbicadmin.t +++ b/xt/extra/dbicadmin.t @@ -13,7 +13,6 @@ use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_admin_script' use Test::More; use Config; -use File::Spec; use DBICTest; @@ -103,7 +102,7 @@ sub default_args { sub test_exec { my ($perl) = $^X =~ /(.*)/; - my @args = ($perl, '-MANFANG', File::Spec->catfile(qw(script dbicadmin)), @_); + my @args = ($perl, '-MANFANG', 'script/dbicadmin', @_); if ($^O eq 'MSWin32') { require Win32::ShellQuote; # included in test optdeps From e48635f7178f8527ec3cc230f1cf869e8876dc39 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 11 May 2015 12:39:39 +0200 Subject: [PATCH 018/262] Get rid of Path::Class ( that *does* feel good ) This was a rather long journey (I've been meaning to do this since ~2013). As everything else it turned out more complex than I anticipated. Notably due to having to implement from semi-scratch things that a dev should usually never worry about >:( Just look at the amount of stuff one can't reasonably trust these days (pay attention to the comments): git show 5d54c117 | perl -ne 'print if 155..304' | less git show 358a3aa7 | perl -ne 'print if 407..453' | less There is a tangible difference in the smoke times due to a leaner set of deps (though not as big as one would hope... yet). Sample timings as follows: for n in $(seq 26); do dbic_trv_diffable() { perl -0777 -n -E ' print ( map { "$ENV{cur}: $_\n" } map { split /\r?\n/, $_ } $_ =~ /(^TRAVIS_PERL_VERSION.+)/m, $_ =~ / \QSetting environment variables\E .+? (?:\r?\n)+ (.+?) (?: \r?\n){2} /xms, $_ =~ /(^.*Configuration phase seems to have taken.*)/m, ); say ( $_ =~ /(^[^\n]*?List of loadable modules .+?)^[^\n]*?List of loadable modules/ms ); ' } x=$((112987257 + $n)) &&\ y=$((113113497 + $n)) &&\ echo -e "$x => $y\n========\n" &&\ diff -U0 \ <( wget -qO- s3.amazonaws.com/archive.travis-ci.org/jobs/$x/log.txt | \ cur=$x dbic_trv_diffable )\ <( wget -qO- s3.amazonaws.com/archive.travis-ci.org/jobs/$y/log.txt | \ cur=$y dbic_trv_diffable ) done | less P.S. The above is hideous, yes, but you can run it in your terminal *directly* --- Makefile.PL | 1 - examples/Schema/insertdb.pl | 4 +- examples/Schema/testdb.pl | 4 +- lib/DBIx/Class/InflateColumn/File.pm | 10 ++- lib/DBIx/Class/Optional/Dependencies.pm | 18 ++++-- lib/DBIx/Class/Storage/DBI.pm | 16 ++--- maint/gen_sqlite_schema_files | 11 ++-- maint/travis-ci_scripts/30_before_script.bash | 10 +-- script/dbicadmin | 22 +++---- t/51threadnodb.t | 1 + t/52leaks.t | 6 +- t/94versioning.t | 24 +++---- t/admin/02ddl.t | 9 +-- t/inflate/file_column.t | 1 + t/lib/ANFANG.pm | 7 +++ t/lib/DBICTest.pm | 46 +++++--------- t/lib/DBICTest/BaseSchema.pm | 1 + t/lib/DBICTest/Util.pm | 62 ++++++++++++++++++- t/storage/debug.t | 28 +++++---- t/storage/deploy.t | 30 +++++---- t/storage/txn.t | 2 +- xt/dist/postdistdir/pod_footers.t | 8 ++- 22 files changed, 188 insertions(+), 133 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index c6b527355..0bf82f3f4 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -65,7 +65,6 @@ my $runtime_requires = { 'MRO::Compat' => '0.12', 'Module::Find' => '0.07', 'namespace::clean' => '0.24', - 'Path::Class' => '0.18', 'Scope::Guard' => '0.03', 'SQL::Abstract' => '1.81', 'Try::Tiny' => '0.07', diff --git a/examples/Schema/insertdb.pl b/examples/Schema/insertdb.pl index ae919b372..4fb22fa59 100755 --- a/examples/Schema/insertdb.pl +++ b/examples/Schema/insertdb.pl @@ -4,9 +4,9 @@ use warnings; use MyApp::Schema; +use DBIx::Class::_Util 'parent_dir'; -use Path::Class 'file'; -my $db_fn = file($INC{'MyApp/Schema.pm'})->dir->parent->file('db/example.db'); +my $db_fn = parent_dir( $INC{'MyApp/Schema.pm'} ) . '../db/example.db'; my $schema = MyApp::Schema->connect("dbi:SQLite:$db_fn"); diff --git a/examples/Schema/testdb.pl b/examples/Schema/testdb.pl index 32cbd6daf..0149bc2ab 100755 --- a/examples/Schema/testdb.pl +++ b/examples/Schema/testdb.pl @@ -4,9 +4,9 @@ use strict; use MyApp::Schema; +use DBIx::Class::_Util 'parent_dir'; -use Path::Class 'file'; -my $db_fn = file($INC{'MyApp/Schema.pm'})->dir->parent->file('db/example.db'); +my $db_fn = parent_dir( $INC{'MyApp/Schema.pm'} ) . '../db/example.db'; # for other DSNs, e.g. MySql, see the perldoc for the relevant dbd # driver, e.g perldoc L. diff --git a/lib/DBIx/Class/InflateColumn/File.pm b/lib/DBIx/Class/InflateColumn/File.pm index b98398578..08a1a3180 100644 --- a/lib/DBIx/Class/InflateColumn/File.pm +++ b/lib/DBIx/Class/InflateColumn/File.pm @@ -2,9 +2,17 @@ package DBIx::Class::InflateColumn::File; use strict; use warnings; + +# check deps +BEGIN { + require DBIx::Class::Optional::Dependencies; + if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('ic_file') ) { + die "The following extra modules are required for DBIx::Class::InflateColumn::File: $missing\n"; + } +} + use base 'DBIx::Class'; use File::Copy; -use Path::Class; use DBIx::Class::Carp; use namespace::clean; diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm index 786828a7d..7b447ef9e 100644 --- a/lib/DBIx/Class/Optional/Dependencies.pm +++ b/lib/DBIx/Class/Optional/Dependencies.pm @@ -144,6 +144,16 @@ my $dbic_reqs = { }, }, + ic_file => { + req => { + 'Path::Class' => '0.18', + }, + pod => { + title => 'DBIx::Class::InflateColumn::File (Deprecated)', + desc => 'Modules required for the deprecated L', + }, + }, + ic_dt => { req => { 'DateTime' => '0.55', @@ -1206,16 +1216,12 @@ sub _gen_pod { "\n\n---------------------------------------------------------------------\n" ; - # do not ask for a recent version, use 1.x API calls - # this *may* execute on a smoker with old perl or whatnot - require File::Path; - (my $modfn = __PACKAGE__ . '.pm') =~ s|::|/|g; (my $podfn = "$pod_dir/$modfn") =~ s/\.pm$/\.pod/; - (my $dir = $podfn) =~ s|/[^/]+$||; - File::Path::mkpath([$dir]); + require DBIx::Class::_Util; + DBIx::Class::_Util::mkdir_p( DBIx::Class::_Util::parent_dir( $podfn ) ); my $sqltver = $class->req_list_for('deploy')->{'SQL::Translator'} or die "Hrmm? No sqlt dep?"; diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 54dff8165..25ed0b5e1 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -17,6 +17,7 @@ use DBIx::Class::_Util qw( quote_sub perlstring serialize dbic_internal_try detected_reinvoked_destructor scope_guard + mkdir_p ); use namespace::clean; @@ -2937,20 +2938,13 @@ them. sub create_ddl_dir { my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_; - unless ($dir) { + if (!$dir) { carp "No directory given, using ./\n"; $dir = './'; - } else { - -d $dir - or - (require File::Path and File::Path::mkpath (["$dir"])) # mkpath does not like objects (i.e. Path::Class::Dir) - or - $self->throw_exception( - "Failed to create '$dir': " . ($! || $@ || 'error unknown') - ); } - - $self->throw_exception ("Directory '$dir' does not exist\n") unless(-d $dir); + else { + mkdir_p( $dir ) unless -d $dir; + } $databases ||= ['MySQL', 'SQLite', 'PostgreSQL']; $databases = [ $databases ] if(ref($databases) ne 'ARRAY'); diff --git a/maint/gen_sqlite_schema_files b/maint/gen_sqlite_schema_files index a3793d33e..0ac70ec2b 100755 --- a/maint/gen_sqlite_schema_files +++ b/maint/gen_sqlite_schema_files @@ -4,8 +4,8 @@ use strict; use warnings; use Module::Runtime 'use_module'; +use DBIx::Class::_Util qw(mkdir_p parent_dir); use SQL::Translator; -use Path::Class 'file'; use Getopt::Long; my $getopt = Getopt::Long::Parser->new( config => [qw/gnu_getopt bundling_override no_ignore_case/] @@ -34,7 +34,7 @@ my $schema = use_module( $args->{'schema-class'}[0] )->connect( ); if ($args->{'deploy-to'}) { - file($args->{'deploy-to'}[0])->dir->mkpath; + mkdir_p parent_dir $args->{'deploy-to'}[0]; $schema->deploy({ add_drop_table => 1 }); } @@ -43,10 +43,9 @@ if ($args->{'ddl-out'}[0] eq '-') { $ddl_fh = *STDOUT; } else { - my $fn = file($args->{'ddl-out'}[0]); - $fn->dir->mkpath; - open $ddl_fh, '>', $fn - or die "Unable to open $fn: $!\n"; + mkdir_p parent_dir $args->{'ddl-out'}[0]; + open $ddl_fh, '>', $args->{'ddl-out'}[0] + or die "Unable to open $args->{'ddl-out'}[0]: $!\n"; } binmode $ddl_fh; # avoid win32 \n crapfest diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 3da762ac2..d5f3cd0c0 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -37,12 +37,9 @@ if [[ "$POISON_ENV" = "true" ]] ; then if [[ "$CLEANTEST" = "true" ]]; then # Clone and P::S::XS are both bugs - # File::Spec can go away as soon as I dump Path::Class - # File::Path is there because of RT#107392 (sigh) # List::Util can be excised after that as well (need to make my own max() routine for older perls) installdeps Sub::Name Clone Package::Stash::XS \ - $( perl -MFile::Spec\ 3.26 -e1 &>/dev/null || echo "File::Path File::Spec" ) \ $( perl -MList::Util\ 1.16 -e1 &>/dev/null || echo "List::Util" ) mkdir -p "$HOME/bin" # this is already in $PATH, just doesn't exist @@ -86,14 +83,11 @@ else # do the preinstall in several passes to minimize amount of cross-deps installing # multiple times, and to avoid module re-architecture breaking another install - # (e.g. once Carp is upgraded there's no more Carp::Heavy, - # while a File::Path upgrade may cause a parallel EUMM run to fail) + # (e.g. once Carp is upgraded there's no more Carp::Heavy) # - parallel_installdeps_notest File::Path parallel_installdeps_notest Carp parallel_installdeps_notest Module::Build - parallel_installdeps_notest File::Spec Module::Runtime - parallel_installdeps_notest Test::Exception Encode::Locale Test::Fatal + parallel_installdeps_notest Test::Exception Encode::Locale Test::Fatal Module::Runtime parallel_installdeps_notest Test::Warn B::Hooks::EndOfScope Test::Differences HTTP::Status parallel_installdeps_notest Test::Pod::Coverage Test::EOL Devel::GlobalDestruction Sub::Name MRO::Compat Class::XSAccessor URI::Escape HTML::Entities parallel_installdeps_notest YAML LWP Class::Trigger DateTime::Format::Builder Class::Accessor::Grouped Package::Variant diff --git a/script/dbicadmin b/script/dbicadmin index bdd618c2d..414b58297 100755 --- a/script/dbicadmin +++ b/script/dbicadmin @@ -71,21 +71,21 @@ if(defined (my $fn = $opts->{documentation_as_pod}) ) { $usage->synopsis($synopsis_text); $usage->short_description($short_description); + my $fh; if ($fn) { - require File::Spec; - require File::Path; - my $dir = File::Spec->catpath( (File::Spec->splitpath($fn))[0,1] ); - File::Path::mkpath([$dir]); + require DBIx::Class::_Util; + DBIx::Class::_Util::mkdir_p( DBIx::Class::_Util::parent_dir( $fn ) ); + open( $fh, '>', $fn ) or die "Unable to open $fn: $!\n"; + } + else { + $fh = \*STDOUT; } - local *STDOUT if $fn; - open (STDOUT, '>', $fn) or die "Unable to open $fn: $!\n" if $fn; - - print STDOUT "\n"; - print STDOUT $usage->pod; - print STDOUT "\n"; + print $fh "\n"; + print $fh $usage->pod; + print $fh "\n"; - close STDOUT if $fn; + close $fh if $fn; exit 0; } diff --git a/t/51threadnodb.t b/t/51threadnodb.t index 4e242f555..30e8aec65 100644 --- a/t/51threadnodb.t +++ b/t/51threadnodb.t @@ -17,6 +17,7 @@ use threads; use strict; use warnings; use Test::More; +use Errno (); use DBIx::Class::_Util 'sigwarn_silencer'; use DBICTest; diff --git a/t/52leaks.t b/t/52leaks.t index 6298c985d..ca588ce70 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -103,10 +103,8 @@ if ( !$ENV{DBICTEST_VIA_REPLICATED} and !DBICTest::RunMode->is_plain ) { # this loads the DT armada $has_dt = DBIx::Class::Optional::Dependencies->req_ok_for([qw( test_rdbms_sqlite ic_dt )]); - require Errno; require DBI; require DBD::SQLite; - require FileHandle; require Moo; %$weak_registry = (); @@ -443,8 +441,8 @@ for my $addr (keys %$weak_registry) { # T::B 2.0 has result objects and other fancyness delete $weak_registry->{$addr}; } - elsif ($names =~ /^Class::Struct/m) { - # remove this when Path::Class is gone, what a crock of shit + # remove this when IO::Dir is gone from SQLT + elsif ($INC{"IO/Dir.pm"} and $names =~ /^Class::Struct::Tie_ISA/m) { delete $weak_registry->{$addr}; } elsif ($names =~ /^Hash::Merge/m) { diff --git a/t/94versioning.t b/t/94versioning.t index c3751b205..ab9d2613e 100644 --- a/t/94versioning.t +++ b/t/94versioning.t @@ -8,13 +8,11 @@ use Test::More; use Test::Warn; use Test::Exception; -use Path::Class; -use File::Copy; use Time::HiRes qw/time sleep/; - use DBICTest; -use DBIx::Class::_Util 'sigwarn_silencer'; +use DBIx::Class::_Util qw( sigwarn_silencer mkdir_p ); +use DBICTest::Util 'rm_rf'; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}; @@ -31,15 +29,15 @@ use_ok('DBICVersion_v1'); my $version_table_name = 'dbix_class_schema_versions'; my $old_table_name = 'SchemaVersions'; -my $ddl_dir = dir(qw/t var/, "versioning_ddl-$$"); -$ddl_dir->mkpath unless -d $ddl_dir; +my $ddl_dir = "t/var/versioning_ddl-$$"; +mkdir_p $ddl_dir unless -d $ddl_dir; my $fn = { - v1 => $ddl_dir->file ('DBICVersion-Schema-1.0-MySQL.sql'), - v2 => $ddl_dir->file ('DBICVersion-Schema-2.0-MySQL.sql'), - v3 => $ddl_dir->file ('DBICVersion-Schema-3.0-MySQL.sql'), - trans_v12 => $ddl_dir->file ('DBICVersion-Schema-1.0-2.0-MySQL.sql'), - trans_v23 => $ddl_dir->file ('DBICVersion-Schema-2.0-3.0-MySQL.sql'), + v1 => "$ddl_dir/DBICVersion-Schema-1.0-MySQL.sql", + v2 => "$ddl_dir/DBICVersion-Schema-2.0-MySQL.sql", + v3 => "$ddl_dir/DBICVersion-Schema-3.0-MySQL.sql", + trans_v12 => "$ddl_dir/DBICVersion-Schema-1.0-2.0-MySQL.sql", + trans_v23 => "$ddl_dir/DBICVersion-Schema-2.0-3.0-MySQL.sql", }; my $schema_v1 = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 }); @@ -284,9 +282,7 @@ is ; END { - unless ($ENV{DBICTEST_KEEP_VERSIONING_DDL}) { - $ddl_dir->rmtree; - } + rm_rf $ddl_dir unless $ENV{DBICTEST_KEEP_VERSIONING_DDL}; } done_testing; diff --git a/t/admin/02ddl.t b/t/admin/02ddl.t index 84a73818e..bb354ac42 100644 --- a/t/admin/02ddl.t +++ b/t/admin/02ddl.t @@ -8,11 +8,9 @@ use Test::More; use Test::Exception; use Test::Warn; -use Path::Class; - - use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; +use DBICTest::Util 'rm_rf'; use DBIx::Class::Admin; @@ -26,7 +24,7 @@ my @connect_info = ( undef, { on_connect_do => 'PRAGMA synchronous = OFF' }, ); -my $ddl_dir = dir(qw/t var/, "admin_ddl-$$"); +my $ddl_dir = "t/var/admin_ddl-$$"; { # create the schema @@ -116,8 +114,7 @@ is($admin->schema->get_db_version, "4.0", 'db thinks its version 4.0'); } sub cleanup { - my ($dir) = @_; - $ddl_dir->rmtree if -d $ddl_dir; + rm_rf $ddl_dir if -d $ddl_dir; unlink $db_fn; } diff --git a/t/inflate/file_column.t b/t/inflate/file_column.t index 9c5203dcc..453adeefe 100644 --- a/t/inflate/file_column.t +++ b/t/inflate/file_column.t @@ -1,4 +1,5 @@ BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } +use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_file ); use strict; use warnings; diff --git a/t/lib/ANFANG.pm b/t/lib/ANFANG.pm index d66322af3..70106d19d 100644 --- a/t/lib/ANFANG.pm +++ b/t/lib/ANFANG.pm @@ -123,6 +123,13 @@ BEGIN { use lib 't/lib'; +# everything expects this to be there +! -d 't/var' and ( + mkdir 't/var' + or + die "Unable to create 't/var': $!\n" +); + # Back in ab340f7f ribasushi stupidly introduced a "did you check your deps" # verification tied very tightly to Module::Install. The check went away, and # so eventually will M::I, but bisecting can bring all of this back from the diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index 762abacdb..d09a9dc32 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -27,14 +27,13 @@ BEGIN { use DBICTest::Util qw( - local_umask tmpdir await_flock + local_umask slurp_bytes tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS PEEPEENESS ); use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; use DBICTest::Schema; use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard ); use Carp; -use Path::Class::File (); use Fcntl qw/:DEFAULT :flock/; use Config; @@ -152,36 +151,21 @@ sub import { } END { - # referencing here delays destruction even more - if ($global_lock_fh) { - DEBUG_TEST_CONCURRENCY_LOCKS > 1 - and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)"; - 1; - } -} - -{ - my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var'); - $dir->mkpath unless -d "$dir"; - $dir = "$dir"; - - sub _sqlite_dbfilename { - my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$; - $holder = $$ if $holder == -1; + # referencing here delays destruction even more + if ($global_lock_fh) { + DEBUG_TEST_CONCURRENCY_LOCKS > 1 + and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)"; + 1; + } - # useful for missing cleanup debugging - #if ( $holder == $$) { - # my $x = $0; - # $x =~ s/\//#/g; - # $holder .= "-$x"; - #} + _cleanup_dbfile(); +} - return "$dir/DBIxClass-$holder.db"; - } +sub _sqlite_dbfilename { + my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$; + $holder = $$ if $holder == -1; - END { - _cleanup_dbfile(); - } + return "t/var/DBIxClass-$holder.db"; } $SIG{INT} = sub { _cleanup_dbfile(); exit 1 }; @@ -439,9 +423,7 @@ sub deploy_schema { if ($ENV{"DBICTEST_SQLT_DEPLOY"}) { $schema->deploy($args); } else { - my $filename = Path::Class::File->new(__FILE__)->dir - ->file('sqlite.sql')->stringify; - my $sql = do { local (@ARGV, $/) = $filename ; <> }; + my $sql = slurp_bytes( 't/lib/sqlite.sql' ); for my $chunk ( split (/;\s*\n+/, $sql) ) { if ( $chunk =~ / ^ (?! --\s* ) \S /xm ) { # there is some real sql in the chunk - a non-space at the start of the string which is not a comment $schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n"; diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index ac3cf8c70..0214933cd 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -6,6 +6,7 @@ use warnings; use base qw(DBICTest::Base DBIx::Class::Schema); use Fcntl qw(:DEFAULT :seek :flock); +use IO::Handle (); use DBIx::Class::_Util 'scope_guard'; use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry); use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 5911f9abc..5d54c1170 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -30,13 +30,13 @@ use constant { use Config; use Carp qw(cluck confess croak); use Fcntl qw( :DEFAULT :flock ); -use Scalar::Util qw(blessed refaddr); +use Scalar::Util qw( blessed refaddr openhandle ); use DBIx::Class::_Util qw( scope_guard parent_dir mkdir_p ); use base 'Exporter'; our @EXPORT_OK = qw( dbg stacktrace - local_umask tmpdir find_co_root + local_umask slurp_bytes tmpdir find_co_root rm_rf visit_namespaces PEEPEENESS check_customcond_args await_flock DEBUG_TEST_CONCURRENCY_LOCKS @@ -102,7 +102,7 @@ sub local_umask ($) { if ! defined wantarray; my $old_umask = umask($_[0]); - die "Setting umask failed: $!" unless defined $old_umask; + croak "Setting umask failed: $!" unless defined $old_umask; scope_guard(sub { local ($@, $!, $?); @@ -246,6 +246,62 @@ EOE } +sub slurp_bytes ($) { + croak "Expecting a file name, not a filehandle" if openhandle $_[0]; + croak "'$_[0]' is not a readable filename" unless -f $_[0] && -r $_[0]; + open my $fh, '<:raw', $_[0] or croak "Unable to open '$_[0]': $!"; + local $/ unless wantarray; + <$fh>; +} + + +sub rm_rf ($) { + croak "No valid argument supplied to rm_rf()" unless length "$_[0]"; + + return unless -e $_[0]; + +### I do not trust myself - check for subsuming ( the right way ) +### Avoid things like https://rt.cpan.org/Ticket/Display.html?id=111637 + require Cwd; + + my ($target, $tmp, $co_tmp) = map { + + my $abs_fn = Cwd::abs_path("$_"); + + if ( $^O eq 'MSWin32' and length $abs_fn ) { + + # sometimes we can get a short/longname mix, normalize everything to longnames + $abs_fn = Win32::GetLongPathName($abs_fn); + + # Fixup for unixy (as opposed to native) slashes + $abs_fn =~ s|\\|/|g; + } + + $abs_fn =~ s| (?init_schema(); -my $lfn = file("t/var/sql-$$.log"); -unlink $lfn or die $! - if -e $lfn; +my $log_fn = "t/var/sql-$$.log"; +unlink $log_fn or die $! if -e $log_fn; # make sure we are testing the vanilla debugger and not ::PrettyPrint require DBIx::Class::Storage::Statistics; $schema->storage->debugobj(DBIx::Class::Storage::Statistics->new); ok ( $schema->storage->debug(1), 'debug' ); -$schema->storage->debugfh($lfn->openw); -$schema->storage->debugfh->autoflush(1); -$schema->resultset('CD')->count; +{ + open my $dbgfh, '>', $log_fn or die $!; + $schema->storage->debugfh($dbgfh); + $schema->storage->debugfh->autoflush(1); + $schema->resultset('CD')->count; + $schema->storage->debugfh(undef); +} -my @loglines = $lfn->slurp; +my @loglines = slurp_bytes $log_fn; is (@loglines, 1, 'one line of log'); like($loglines[0], qr/^SELECT COUNT/, 'File log via debugfh success'); -$schema->storage->debugfh(undef); { - local $ENV{DBIC_TRACE} = "=$lfn"; - unlink $lfn; + local $ENV{DBIC_TRACE} = "=$log_fn"; + unlink $log_fn; $schema->resultset('CD')->count; my $schema2 = DBICTest->init_schema(no_deploy => 1); $schema2->storage->_do_query('SELECT 1'); # _do_query() logs via standard mechanisms - my @loglines = $lfn->slurp; + my @loglines = slurp_bytes $log_fn; is(@loglines, 2, '2 lines of log'); like($loglines[0], qr/^SELECT COUNT/, 'Env log from schema1 success'); like($loglines[1], qr/^SELECT 1:/, 'Env log from schema2 success'); @@ -60,7 +62,7 @@ $schema->storage->debugfh(undef); } END { - unlink $lfn; + unlink $log_fn if $log_fn; } open(STDERRCOPY, '>&STDERR'); diff --git a/t/storage/deploy.t b/t/storage/deploy.t index 64c2438e1..eb317758c 100644 --- a/t/storage/deploy.t +++ b/t/storage/deploy.t @@ -6,10 +6,10 @@ use warnings; use Test::More; use Test::Exception; -use Path::Class qw/dir/; - use DBICTest; +use DBICTest::Util qw( slurp_bytes rm_rf ); +use DBIx::Class::_Util 'mkdir_p'; local $ENV{DBI_DSN}; @@ -29,11 +29,11 @@ lives_ok( sub { my $schema = DBICTest->init_schema( quote_names => 1 ); -my $var = dir ("t/var/ddl_dir-$$"); -$var->mkpath unless -d $var; +my $var_dir = "t/var/ddl_dir-$$/"; +mkdir_p $var_dir unless -d $var_dir; -my $test_dir_1 = $var->subdir ('test1', 'foo', 'bar' ); -$test_dir_1->rmtree if -d $test_dir_1; +my $test_dir_1 = $var_dir . 'test1/foo/bar'; +rm_rf $test_dir_1 if -d $test_dir_1; $schema->create_ddl_dir( [qw(SQLite MySQL)], 1, $test_dir_1 ); ok( -d $test_dir_1, 'create_ddl_dir did a make_path on its target dir' ); @@ -50,16 +50,24 @@ for ( my $type = $_->[0]; my $q = quotemeta($_->[1]); - for my $f (map { $test_dir_1->file("DBICTest-Schema-${_}-$type.sql") } qw(1 2) ) { - like scalar $f->slurp, qr/CREATE TABLE ${q}track${q}/, "Proper quoting in $f"; + for my $f (map { $test_dir_1 . "/DBICTest-Schema-${_}-$type.sql" } qw(1 2) ) { + like ( + scalar slurp_bytes $f, + qr/CREATE TABLE ${q}track${q}/, + "Proper quoting in $f" + ); } { local $TODO = 'SQLT::Producer::MySQL has no knowledge of the mythical beast of quoting...' if $type eq 'MySQL'; - my $f = $test_dir_1->file("DBICTest-Schema-1-2-$type.sql"); - like scalar $f->slurp, qr/DROP TABLE ${q}bindtype_test${q}/, "Proper quoting in diff $f"; + my $f = $test_dir_1 . "/DBICTest-Schema-1-2-$type.sql"; + like ( + scalar slurp_bytes $f, + qr/DROP TABLE ${q}bindtype_test${q}/, + "Proper quoting in diff $f" + ); } } @@ -69,7 +77,7 @@ for ( } END { - $var->rmtree; + rm_rf $var_dir; } done_testing; diff --git a/t/storage/txn.t b/t/storage/txn.t index 9a462bffc..382727c62 100644 --- a/t/storage/txn.t +++ b/t/storage/txn.t @@ -6,6 +6,7 @@ use warnings; use Test::More; use Test::Warn; use Test::Exception; +use Errno (); use DBICTest; @@ -215,7 +216,6 @@ sub _test_forking_action { my $pid = fork(); if( ! defined $pid ) { - skip "EAGAIN encountered, your system is likely bogged down: skipping forking test", 1 if $! == Errno::EAGAIN(); diff --git a/xt/dist/postdistdir/pod_footers.t b/xt/dist/postdistdir/pod_footers.t index 9882b52a5..4b14dedf4 100644 --- a/xt/dist/postdistdir/pod_footers.t +++ b/xt/dist/postdistdir/pod_footers.t @@ -1,9 +1,15 @@ +BEGIN { $ENV{DBICTEST_ANFANG_DEFANG} = 1 } + use warnings; use strict; use Test::More; use File::Find; +use lib 't/lib'; +use DBICTest; # for the lock +use DBICTest::Util 'slurp_bytes'; + my $boilerplate_headings = q{ =head1 FURTHER QUESTIONS? @@ -24,7 +30,7 @@ find({ return unless -f $fn; return unless $fn =~ / \. (?: pm | pod ) $ /ix; - my $data = do { local (@ARGV, $/) = $fn; <> }; + my $data = slurp_bytes $fn; if ($data !~ /^=head1 NAME/m) { From 3cff955a7163e263490edecd0a1922aa5ee6c6db Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 10 Jan 2016 15:26:40 +0100 Subject: [PATCH 019/262] (optdeps) One last pass through tests, streamline skip messages --- t/73oracle.t | 2 +- t/746db2_400.t | 1 - t/747mssql_ado.t | 1 - t/750firebird.t | 6 +----- t/84serialize.t | 18 +++--------------- t/99dbic_sqlt_parser.t | 1 - t/icdt/engine_specific/firebird.t | 7 ++----- t/resultset/rowparser_internals.t | 2 +- t/storage/base.t | 3 ++- t/storage/global_destruction.t | 20 +++++--------------- t/storage/quote_names.t | 7 +++++-- t/storage/savepoints.t | 9 +++------ t/storage/txn.t | 2 +- 13 files changed, 24 insertions(+), 55 deletions(-) diff --git a/t/73oracle.t b/t/73oracle.t index efbb9961d..7d6c79016 100644 --- a/t/73oracle.t +++ b/t/73oracle.t @@ -473,7 +473,7 @@ sub _run_tests { # http://download.oracle.com/docs/cd/A87860_01/doc/server.817/a76961/ch294.htm#993 # Oracle Database Reference 10g Release 2 (10.2) # http://download.oracle.com/docs/cd/B19306_01/server.102/b14237/statviews_2107.htm#sthref1297 - todo_skip "On Oracle8i all_triggers view is empty, i don't yet know why...", 1 + todo_skip "FIXME: On Oracle8i all_triggers view is empty, i don't yet know why...", 1 if $schema->storage->_server_info->{normalized_dbms_version} < 9; my $schema2 = $schema->connect($dsn2, $user2, $pass2, $opt); diff --git a/t/746db2_400.t b/t/746db2_400.t index c06d4e4a8..1ce3b99f9 100644 --- a/t/746db2_400.t +++ b/t/746db2_400.t @@ -5,7 +5,6 @@ use strict; use warnings; use Test::More; -use DBIx::Class::Optional::Dependencies (); use DBICTest; diff --git a/t/747mssql_ado.t b/t/747mssql_ado.t index 6fdb8cce4..d40cd17b0 100644 --- a/t/747mssql_ado.t +++ b/t/747mssql_ado.t @@ -7,7 +7,6 @@ use warnings; use Test::More; use Test::Exception; use Try::Tiny; -use DBIx::Class::Optional::Dependencies (); use DBICTest; diff --git a/t/750firebird.t b/t/750firebird.t index b0a2749c0..fac50d560 100644 --- a/t/750firebird.t +++ b/t/750firebird.t @@ -28,8 +28,6 @@ plan skip_all => join (' ', 'and "nonpkid_seq" and the trigger "artist_bi".', ) unless grep { $ENV{"${_}_DSN"} } keys %$env2optdep; -# tests stolen from 749sybase_asa.t - # Example DSNs: # dbi:Firebird:db=/var/lib/firebird/2.5/data/hlaghdb.fdb # dbi:InterBase:db=/var/lib/firebird/2.5/data/hlaghdb.fdb @@ -41,11 +39,9 @@ my $schema; for my $prefix (shuffle keys %$env2optdep) { SKIP: { - skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1) - unless DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix}); + DBIx::Class::Optional::Dependencies->skip_without( $env2optdep->{$prefix} ); my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; - note "Testing with ${prefix}_DSN"; $schema = DBICTest::Schema->connect($dsn, $user, $pass, { diff --git a/t/84serialize.t b/t/84serialize.t index 0cacfc10c..bbb5f4ea0 100644 --- a/t/84serialize.t +++ b/t/84serialize.t @@ -60,8 +60,9 @@ my %stores = ( ); -if ($ENV{DBICTEST_MEMCACHED}) { - if (DBIx::Class::Optional::Dependencies->req_ok_for ('test_memcached')) { +SKIP: { + DBIx::Class::Optional::Dependencies->skip_without('test_memcached'); + my $memcached = Cache::Memcached->new( { servers => [ $ENV{DBICTEST_MEMCACHED} ] } ); @@ -74,21 +75,8 @@ if ($ENV{DBICTEST_MEMCACHED}) { local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema; return $memcached->get($key); }; - } - else { - SKIP: { - skip 'Memcached tests need ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_memcached'), 1; - } - } -} -else { - SKIP: { - skip 'Set $ENV{DBICTEST_MEMCACHED} to run the memcached serialization tests', 1; - } } - - for my $name (keys %stores) { my $store = $stores{$name}; diff --git a/t/99dbic_sqlt_parser.t b/t/99dbic_sqlt_parser.t index 555183310..51e25215e 100644 --- a/t/99dbic_sqlt_parser.t +++ b/t/99dbic_sqlt_parser.t @@ -11,7 +11,6 @@ use Test::Warn; use Test::Exception; use Scalar::Util (); - use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; diff --git a/t/icdt/engine_specific/firebird.t b/t/icdt/engine_specific/firebird.t index 493b41f92..5ce1d8f59 100644 --- a/t/icdt/engine_specific/firebird.t +++ b/t/icdt/engine_specific/firebird.t @@ -28,14 +28,11 @@ my $schema; for my $prefix (keys %$env2optdep) { SKIP: { - my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; - - next unless $dsn; + DBIx::Class::Optional::Dependencies->skip_without( $env2optdep->{$prefix} ); note "Testing with ${prefix}_DSN"; - skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1) - unless DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix}); + my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; $schema = DBICTest::Schema->connect($dsn, $user, $pass, { quote_char => '"', diff --git a/t/resultset/rowparser_internals.t b/t/resultset/rowparser_internals.t index 251168499..235e5d4df 100644 --- a/t/resultset/rowparser_internals.t +++ b/t/resultset/rowparser_internals.t @@ -890,7 +890,7 @@ done_testing; my $deparser; sub is_same_src { SKIP: { - skip "Skipping comparison of unicode-posioned source", 1 + skip "Skipping comparison of unicode-poisoned source", 1 if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE; $deparser ||= B::Deparse->new; diff --git a/t/storage/base.t b/t/storage/base.t index e40745a65..b4fd7892c 100644 --- a/t/storage/base.t +++ b/t/storage/base.t @@ -181,7 +181,8 @@ for my $type (keys %$invocations) { # make sure connection-less storages do not throw on _determine_driver # but work with ENV at the same time SKIP: for my $env_dsn (undef, (DBICTest->_database)[0] ) { - skip 'Subtest relies on being connected to SQLite', 1 + + skip 'This set of tests relies on being connected to SQLite', 1 if $env_dsn and $env_dsn !~ /\:SQLite\:/; local $ENV{DBI_DSN} = $env_dsn || ''; diff --git a/t/storage/global_destruction.t b/t/storage/global_destruction.t index 674c116a7..5b7fc8559 100644 --- a/t/storage/global_destruction.t +++ b/t/storage/global_destruction.t @@ -16,24 +16,14 @@ use DBICTest; for my $type (qw/PG MYSQL SQLite/) { SKIP: { + + DBIx::Class::Optional::Dependencies->skip_without( 'test_rdbms_' . lc $type ); + my @dsn = $type eq 'SQLite' - ? DBICTest->_database(sqlite_use_file => 1) - : do { - skip "Skipping $type tests without DBICTEST_${type}_DSN", 1 - unless $ENV{"DBICTEST_${type}_DSN"}; - @ENV{map { "DBICTEST_${type}_${_}" } qw/DSN USER PASS/} - } + ? ( DBICTest->_database(sqlite_use_file => 1) ) + : ( @ENV{map { "DBICTEST_${type}_${_}" } qw/DSN USER PASS/} ) ; - if ($type eq 'PG') { - skip "skipping Pg tests without dependencies installed", 1 - unless DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_pg'); - } - elsif ($type eq 'MYSQL') { - skip "skipping MySQL tests without dependencies installed", 1 - unless DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_mysql'); - } - my $schema = DBICTest::Schema->connect (@dsn); # emulate a singleton-factory, just cache the object *somewhere in a different package* diff --git a/t/storage/quote_names.t b/t/storage/quote_names.t index 08fcd005f..ff82d9f0a 100644 --- a/t/storage/quote_names.t +++ b/t/storage/quote_names.t @@ -52,8 +52,11 @@ my %expected = ( ); for my $class (keys %expected) { SKIP: { - eval "require ${class}" - or skip "Skipping test of quotes for $class due to missing dependencies", 1; + + eval "require ${class}" or do { + note "Failed load of $class:\n\n$@\n\n"; + skip "Skipping test of quotes for $class due to missing compile-time dependencies", 1; + }; my $mapping = $expected{$class}; my ($quote_char, $name_sep) = @$mapping{qw/quote_char name_sep/}; diff --git a/t/storage/savepoints.t b/t/storage/savepoints.t index f99c9d5da..624ee9c56 100644 --- a/t/storage/savepoints.t +++ b/t/storage/savepoints.t @@ -37,13 +37,10 @@ for ('', keys %$env2optdep) { SKIP: { my $prefix; if ($prefix = $_) { - my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; - skip ("Skipping tests with $prefix: set \$ENV{${prefix}_DSN} _USER and _PASS", 1) - unless $dsn; + DBIx::Class::Optional::Dependencies->skip_without($env2optdep->{$prefix}); - skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1) - unless DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix}); + my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; $schema = DBICTest::Schema->connect ($dsn,$user,$pass,{ auto_savepoint => 1 }); @@ -231,7 +228,7 @@ for ('', keys %$env2optdep) { SKIP: { is_deeply( $schema->storage->savepoints, [], 'All savepoints forgotten' ); SKIP: { - skip "Reading inexplicably fails on very old replicated DBD::SQLite<1.33", 1 if ( + skip "FIXME: Reading inexplicably fails on very old replicated DBD::SQLite<1.33", 1 if ( $ENV{DBICTEST_VIA_REPLICATED} and $prefix eq 'SQLite Internal DB' diff --git a/t/storage/txn.t b/t/storage/txn.t index 382727c62..9af004043 100644 --- a/t/storage/txn.t +++ b/t/storage/txn.t @@ -211,7 +211,7 @@ sub _test_forking_action { SKIP: for my $count (1 .. 5) { - skip 'Weird DBI General Protection Faults, skip forking tests (RT#63104)', 5 + skip 'FIXME: Weird DBI General Protection Faults, skip forking tests (RT#63104)', 5 if $^O eq 'MSWin32'; my $pid = fork(); From 18a2903b824e3d3159836c99c1ab88058537169f Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 3 Mar 2016 12:24:55 +0100 Subject: [PATCH 020/262] Do not load DBIC::Optional::Dependencies at runtime unless we need to --- lib/DBIx/Class.pm | 2 -- lib/DBIx/Class/Schema/Versioned.pm | 1 + lib/DBIx/Class/Storage.pm | 1 + lib/DBIx/Class/Storage/DBI.pm | 10 ++++++---- lib/DBIx/Class/Storage/DBI/Pg.pm | 2 ++ t/52leaks.t | 1 + t/84serialize.t | 1 + t/lib/DBICTest/Util/LeakTracer.pm | 9 +++++++-- t/storage/cursor.t | 2 +- t/storage/savepoints.t | 1 + 10 files changed, 21 insertions(+), 9 deletions(-) diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index 1adbe6424..cec52f755 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -18,8 +18,6 @@ $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev relea use DBIx::Class::_Util; use mro 'c3'; -use DBIx::Class::Optional::Dependencies; - use base qw/DBIx::Class::Componentised DBIx::Class::AccessorGroup/; use DBIx::Class::StartupCheck; use DBIx::Class::Exception; diff --git a/lib/DBIx/Class/Schema/Versioned.pm b/lib/DBIx/Class/Schema/Versioned.pm index 2f130f618..c1553601d 100644 --- a/lib/DBIx/Class/Schema/Versioned.pm +++ b/lib/DBIx/Class/Schema/Versioned.pm @@ -641,6 +641,7 @@ sub _create_db_to_schema_diff { return; } + require DBIx::Class::Optional::Dependencies; if ( my $missing = DBIx::Class::Optional::Dependencies->req_missing_for('deploy') ) { $self->throw_exception("Unable to proceed without $missing"); } diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm index 47aef3699..45839e105 100644 --- a/lib/DBIx/Class/Storage.pm +++ b/lib/DBIx/Class/Storage.pm @@ -577,6 +577,7 @@ sub debugobj { if ($profile =~ /^\.?\//) { + require DBIx::Class::Optional::Dependencies; if ( my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('config_file_reader') ) { $self->throw_exception("Unable to parse TRACE_PROFILE config file '$profile' without $missing"); } diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 25ed0b5e1..cafdf1939 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -2938,6 +2938,11 @@ them. sub create_ddl_dir { my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_; + require DBIx::Class::Optional::Dependencies; + if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')) { + $self->throw_exception("Can't create a ddl file without $missing"); + } + if (!$dir) { carp "No directory given, using ./\n"; $dir = './'; @@ -2960,10 +2965,6 @@ sub create_ddl_dir { %{$sqltargs || {}} }; - if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')) { - $self->throw_exception("Can't create a ddl file without $missing"); - } - my $sqlt = SQL::Translator->new( $sqltargs ); $sqlt->parser('SQL::Translator::Parser::DBIx::Class'); @@ -3117,6 +3118,7 @@ sub deployment_statements { return join('', @rows); } + require DBIx::Class::Optional::Dependencies; if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') ) { $self->throw_exception("Can't deploy without a pregenerated 'ddl_dir' directory or $missing"); } diff --git a/lib/DBIx/Class/Storage/DBI/Pg.pm b/lib/DBIx/Class/Storage/DBI/Pg.pm index ded6d0698..87a237d66 100644 --- a/lib/DBIx/Class/Storage/DBI/Pg.pm +++ b/lib/DBIx/Class/Storage/DBI/Pg.pm @@ -181,6 +181,8 @@ sub bind_attribute_by_data_type { ); } elsif ( + require DBIx::Class::Optional::Dependencies + and my $missing = DBIx::Class::Optional::Dependencies->req_missing_for([qw( rdbms_pg binary_data )]) ) { # FIXME - perhaps this needs to be an exception too...? diff --git a/t/52leaks.t b/t/52leaks.t index ca588ce70..e54df310e 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -33,6 +33,7 @@ use DBICTest::RunMode; use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs); use Scalar::Util qw(weaken blessed reftype); use DBIx::Class::_Util qw(hrefaddr sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt); +use DBIx::Class::Optional::Dependencies; my $TB = Test::More->builder; if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) { diff --git a/t/84serialize.t b/t/84serialize.t index bbb5f4ea0..021c44e70 100644 --- a/t/84serialize.t +++ b/t/84serialize.t @@ -61,6 +61,7 @@ my %stores = ( ); SKIP: { + require DBIx::Class::Optional::Dependencies; DBIx::Class::Optional::Dependencies->skip_without('test_memcached'); my $memcached = Cache::Memcached->new( diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index 134ca6333..82ff01065 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -7,12 +7,17 @@ use ANFANG; use Carp; use Scalar::Util qw(isweak weaken blessed reftype); use DBIx::Class::_Util qw(refcount hrefaddr refdesc); -use DBIx::Class::Optional::Dependencies; use DBICTest::RunMode; use Data::Dumper::Concise; use DBICTest::Util qw( stacktrace visit_namespaces ); use constant { - CV_TRACING => !DBICTest::RunMode->is_plain && DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'), + CV_TRACING => !!( + !DBICTest::RunMode->is_plain + && + require DBIx::Class::Optional::Dependencies + && + DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy') + ), }; use base 'Exporter'; diff --git a/t/storage/cursor.t b/t/storage/cursor.t index 93a316163..96f917e1a 100644 --- a/t/storage/cursor.t +++ b/t/storage/cursor.t @@ -6,7 +6,7 @@ use warnings; use Test::More; use Test::Exception; - +use DBIx::Class::Optional::Dependencies; use DBICTest; my $schema = DBICTest->init_schema(cursor_class => 'DBICTest::Cursor'); diff --git a/t/storage/savepoints.t b/t/storage/savepoints.t index 624ee9c56..66b7d71a4 100644 --- a/t/storage/savepoints.t +++ b/t/storage/savepoints.t @@ -5,6 +5,7 @@ use warnings; use Test::More; use Test::Exception; +use DBIx::Class::Optional::Dependencies; use DBIx::Class::_Util qw(modver_gt_or_eq sigwarn_silencer scope_guard); From 26710bc9ccfc5ffd506c50aff7d7e7a10efe6620 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 4 Mar 2016 16:24:27 +0100 Subject: [PATCH 021/262] More robust behavior of ANFANG.pm, also guard against sitecustomize.pl --- t/52leaks.t | 1 + t/lib/ANFANG.pm | 39 +++++++++++++++++++++--------- xt/extra/internals/optional_deps.t | 11 +++++++-- xt/extra/lean_startup.t | 30 ++++++++++++----------- 4 files changed, 54 insertions(+), 27 deletions(-) diff --git a/t/52leaks.t b/t/52leaks.t index e54df310e..76fc8e6cd 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -536,6 +536,7 @@ SKIP: { if modver_gt_or_eq_and_lt( 'Test::More', '1.200', '1.301001_099' ); local $ENV{DBICTEST_IN_PERSISTENT_ENV} = 1; + local $ENV{DBICTEST_ANFANG_DEFANG} = 1; require File::Spec; diff --git a/t/lib/ANFANG.pm b/t/lib/ANFANG.pm index 70106d19d..354bc0138 100644 --- a/t/lib/ANFANG.pm +++ b/t/lib/ANFANG.pm @@ -7,15 +7,23 @@ BEGIN { require warnings and warnings->import; require strict and strict->import; } - - # allow 'use ANFANG' to work after it's been do()ne - $INC{"ANFANG.pm"} ||= __FILE__; - $INC{"t/lib/ANFANG.pm"} ||= __FILE__; - $INC{"./t/lib/ANFANG.pm"} ||= __FILE__; } -BEGIN { +# +# FROM THIS POINT ONWARD EVERYTHING HAPPENS LINEARLY AT RUNTIME +# +our $anfang_loaded; + +# this allows the obscure but possible call case to behave correctly: +# +# perl -Mt::lib::ANFANG -e 'do "./t/lib/ANFANG.pm" or die ( $@ || $! )' +# +return 1 if $anfang_loaded; +# cover even more bases +$INC{$_} ||= __FILE__ for (qw( ANFANG.pm t/lib/ANFANG.pm ./t/lib/ANFANG.pm )); + +{ # load-me-first sanity check if ( @@ -24,8 +32,12 @@ BEGIN { and - # if this is set - all bets are off - ! $ENV{PERL5OPT} + # if these are set - all bets are off + ! ( + $ENV{PERL5OPT} + or + scalar grep { $_ =~ m| \/ sitecustomize\.pl $ |x } keys %INC + ) and @@ -118,10 +130,12 @@ BEGIN { goto $orig; }; } - } -use lib 't/lib'; + +require lib; +lib->import('t/lib'); + # everything expects this to be there ! -d 't/var' and ( @@ -130,10 +144,13 @@ use lib 't/lib'; die "Unable to create 't/var': $!\n" ); + # Back in ab340f7f ribasushi stupidly introduced a "did you check your deps" # verification tied very tightly to Module::Install. The check went away, and # so eventually will M::I, but bisecting can bring all of this back from the # dead. In order to reduce hair-pulling make sure that ./inc/ is always there -f 'Makefile.PL' and mkdir 'inc' and mkdir 'inc/.author'; -1; + +# make absolutely sure this is last +$anfang_loaded = 1; diff --git a/xt/extra/internals/optional_deps.t b/xt/extra/internals/optional_deps.t index 7da1cc43e..f2feb4e13 100644 --- a/xt/extra/internals/optional_deps.t +++ b/xt/extra/internals/optional_deps.t @@ -19,8 +19,15 @@ use Carp 'confess'; use List::Util 'shuffle'; SKIP: { - skip 'Lean load pattern testing unsafe with $ENV{PERL5OPT}', 1 if $ENV{PERL5OPT}; - skip 'Lean load pattern testing useless with $ENV{RELEASE_TESTING}', 1 if $ENV{RELEASE_TESTING}; + skip 'Lean load pattern testing unsafe with $ENV{PERL5OPT}', 1 + if $ENV{PERL5OPT}; + + skip 'Lean load pattern testing unsafe with sitecustomize.pl', 1 + if grep { $_ =~ m| \/ sitecustomize\.pl $ |x } keys %INC; + + skip 'Lean load pattern testing useless with $ENV{RELEASE_TESTING}', 1 + if $ENV{RELEASE_TESTING}; + is_deeply $inc_before, [], diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index e699ee5dc..d107bb889 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -1,16 +1,8 @@ -BEGIN { $ENV{DBICTEST_ANFANG_DEFANG} = 1 } - # Use a require override instead of @INC munging (less common) # Do the override as early as possible so that CORE::require doesn't get compiled away my ($initial_inc_contents, $expected_dbic_deps, $require_sites); BEGIN { - # these envvars *will* bring in more stuff than the baseline - delete @ENV{qw(DBICTEST_SQLT_DEPLOY DBIC_TRACE)}; - - # make sure extras do not load even when this is set - $ENV{PERL_STRICTURES_EXTRA} = 1; - unshift @INC, 't/lib'; require DBICTest::Util::OverrideRequire; @@ -71,9 +63,25 @@ BEGIN { plan skip_all => 'A defined PERL5OPT may inject extra deps crashing this test' if $ENV{PERL5OPT}; + plan skip_all => 'Presence of sitecustomize.pl may inject extra deps crashing this test' + if grep { $_ =~ m| \/ sitecustomize\.pl $ |x } keys %INC; + plan skip_all => 'Dependency load patterns are radically different before perl 5.10' if "$]" < 5.010; + # these envvars *will* bring in more stuff than the baseline + delete @ENV{qw( + DBIC_TRACE + DBICTEST_SQLT_DEPLOY + DBICTEST_VIA_REPLICATED + DBICTEST_DEBUG_CONCURRENCY_LOCKS + )}; + + $ENV{DBICTEST_ANFANG_DEFANG} = 1; + + # make sure extras do not load even when this is set + $ENV{PERL_STRICTURES_EXTRA} = 1; + # add what we loaded so far for (keys %INC) { my $mod = $_; @@ -83,12 +91,6 @@ BEGIN { } } -BEGIN { - delete $ENV{$_} for qw( - DBICTEST_VIA_REPLICATED - DBICTEST_DEBUG_CONCURRENCY_LOCKS - ); -} ####### ### This is where the test starts From 1fb834df6d7a98d9d9c245a59f76b4602158451f Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 4 Mar 2016 19:55:39 +0100 Subject: [PATCH 022/262] Apparently -i and -jN do not work on win32, what the hell These fixes together with RT#112706 make distbuilding on SighOS possible again Also adjust a number of whitespace checks to work properly, ensuring the distdir built on a normal OS and on Win32 match. Read under diff -w -C --- .../Makefile.PL.inc/51_autohandle_MANIFEST.pl | 1 + maint/Makefile.PL.inc/53_autogen_pod.pl | 9 ++++-- .../54_autogen_legalese_and_README.pl | 1 + .../{11_authortests.pl => 92_authortests.pl} | 16 ++++++++-- xt/dist/postdistdir/whitespace.t | 29 ++++++++++++------- 5 files changed, 41 insertions(+), 15 deletions(-) rename maint/Makefile.PL.inc/{11_authortests.pl => 92_authortests.pl} (76%) diff --git a/maint/Makefile.PL.inc/51_autohandle_MANIFEST.pl b/maint/Makefile.PL.inc/51_autohandle_MANIFEST.pl index 938cab5d6..32745cbd4 100644 --- a/maint/Makefile.PL.inc/51_autohandle_MANIFEST.pl +++ b/maint/Makefile.PL.inc/51_autohandle_MANIFEST.pl @@ -4,6 +4,7 @@ postamble <<"EOM"; fresh_manifest : remove_manifest manifest +@{[ $crlf_fixup->('MANIFEST') ]} remove_manifest : \t\$(RM_F) MANIFEST diff --git a/maint/Makefile.PL.inc/53_autogen_pod.pl b/maint/Makefile.PL.inc/53_autogen_pod.pl index c35073403..f595f0d74 100644 --- a/maint/Makefile.PL.inc/53_autogen_pod.pl +++ b/maint/Makefile.PL.inc/53_autogen_pod.pl @@ -105,15 +105,18 @@ \tperldoc -u lib/DBIx/Class.pm > $dist_pod_fn \t@{[ $mm_proto->oneliner( - "s!^.*?this line is replaced with the author list.*! qq{List of the awesome contributors who made DBIC v$ver possible\n\n} . qx(\$^X -Ilib maint/gen_pod_authors)!me", - [qw( -0777 -p -i )] + "s!^.*?this line is replaced with the author list.*! qq{List of the awesome contributors who made DBIC v$ver possible\\n\\n} . qx(\$^X -Ilib maint/gen_pod_authors)!me", + [qw( -0777 -p -i.arghwin32 )] ) ]} $dist_pod_fn +\t\$(RM_F) $dist_pod_fn.arghwin32 create_distdir : dbic_distdir_defang_authors # Remove the maintainer-only warning (be nice ;) dbic_distdir_defang_authors : -\t@{[ $mm_proto->oneliner('s/ ^ \s* \# \s* \*\*\* .+ \n ( ^ \s* \# \s*? \n )? //xmg', [qw( -0777 -p -i )] ) ]} \$(DISTVNAME)/AUTHORS +\t@{[ $mm_proto->oneliner('s/ ^ \s* \# \s* \*\*\* .+ \n ( ^ \s* \# \s*? \n )? //xmg', [qw( -0777 -p -i.arghwin32 )] ) ]} \$(DISTVNAME)/AUTHORS +@{[ $crlf_fixup->( '$(DISTVNAME)/AUTHORS' ) ]} +\t\$(RM_F) \$(DISTVNAME)/AUTHORS.arghwin32 EOP } diff --git a/maint/Makefile.PL.inc/54_autogen_legalese_and_README.pl b/maint/Makefile.PL.inc/54_autogen_legalese_and_README.pl index 16259af3e..169fea619 100644 --- a/maint/Makefile.PL.inc/54_autogen_legalese_and_README.pl +++ b/maint/Makefile.PL.inc/54_autogen_legalese_and_README.pl @@ -33,6 +33,7 @@ dbic_distdir_regen_license : @{[ $start_file->( Meta->name . '-' . Meta->version . '/LICENSE' ) ]} \t@{[ $mm_proto->oneliner('cat', ['-MExtUtils::Command']) ]} LICENSE >> \$(DISTVNAME)/LICENSE +@{[ $crlf_fixup->('$(DISTVNAME)/LICENSE') ]} EOP diff --git a/maint/Makefile.PL.inc/11_authortests.pl b/maint/Makefile.PL.inc/92_authortests.pl similarity index 76% rename from maint/Makefile.PL.inc/11_authortests.pl rename to maint/Makefile.PL.inc/92_authortests.pl index 0643ca95a..77b52e5f8 100644 --- a/maint/Makefile.PL.inc/11_authortests.pl +++ b/maint/Makefile.PL.inc/92_authortests.pl @@ -10,6 +10,11 @@ my @xt_dist_tests = map { "$_/*.t" } sort keys %$xt_dist_dirs; +my $parallel_jobs = ( $^O eq 'MSWin32' ) + ? 1 # FIXME for some reason windows hangs on parallel jobs at `make dist` + : 4 +; + # inject an explicit xt test run, mainly to check the contents of # lib and the generated POD's *before* anything is copied around # @@ -30,7 +35,10 @@ # perl cmd join( ' ', '$(ABSPERLRUN)', - map { $mm_proto->quote_literal($_) } qw(-e $ENV{RELEASE_TESTING}=1;$ENV{HARNESS_OPTIONS}=j4;) + map { $mm_proto->quote_literal($_) } ( + '-e', + "\$ENV{RELEASE_TESTING}=1;\$ENV{HARNESS_OPTIONS}=j$parallel_jobs;" + ), ), # test list join( ' ', @@ -49,7 +57,11 @@ # perl cmd join( ' ', '$(ABSPERLRUN)', - map { $mm_proto->quote_literal($_) } qw(-Ilib -e $ENV{RELEASE_TESTING}=1;$ENV{HARNESS_OPTIONS}=j4;) + map { $mm_proto->quote_literal($_) } ( + '-Ilib', + '-e', + "\$ENV{RELEASE_TESTING}=1;\$ENV{HARNESS_OPTIONS}=j$parallel_jobs;" + ), ), 'xt/dist/postdistdir/*.t', ) diff --git a/xt/dist/postdistdir/whitespace.t b/xt/dist/postdistdir/whitespace.t index 9b2ba87b4..6601de234 100644 --- a/xt/dist/postdistdir/whitespace.t +++ b/xt/dist/postdistdir/whitespace.t @@ -27,8 +27,9 @@ Test::EOL::all_perl_files_ok({ trailing_whitespace => 1 }, @pl_targets); Test::NoTabs::all_perl_files_ok(@pl_targets); # check some non-"perl files" in the root separately -# use .gitignore as a guide of what to skip -# (or do not test at all if no .gitignore is found) +my @root_files = grep { -f $_ } bsd_glob('*'); + +# use .gitignore as a partial guide of what to skip if (open(my $gi, '<', '.gitignore')) { my $skipnames; while (my $ln = <$gi>) { @@ -37,15 +38,23 @@ if (open(my $gi, '<', '.gitignore')) { $skipnames->{$_}++ for bsd_glob($ln); } - # that we want to check anyway - delete $skipnames->{'META.yml'}; + # these we want to check no matter what the above says + delete $skipnames->{qw( + Changes + LICENSE + AUTHORS + README + MANIFEST + META.yml + META.json + )}; + + @root_files = grep { ! $skipnames->{$_} } @root_files; +} - for my $fn (bsd_glob('*')) { - next if $skipnames->{$fn}; - next unless -f $fn; - Test::EOL::eol_unix_ok($fn, { trailing_whitespace => 1 }); - Test::NoTabs::notabs_ok($fn); - } +for my $fn (@root_files) { + Test::EOL::eol_unix_ok($fn, { trailing_whitespace => 1 }); + Test::NoTabs::notabs_ok($fn) unless $fn eq 'MANIFEST'; # it is always tab infested } # FIXME - Test::NoTabs and Test::EOL declare 'no_plan' which conflicts with done_testing From ad3a59bdd40c1f6b5ddf56c0b5f4b716c0ccdacf Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 5 Mar 2016 14:43:44 +0100 Subject: [PATCH 023/262] These files are not used by anything - remnants from the distant ea2e61bf --- t/cdbi/testlib/MyFilm.pm | 27 --------------------------- t/cdbi/testlib/MyStar.pm | 23 ----------------------- t/cdbi/testlib/MyStarLink.pm | 23 ----------------------- t/cdbi/testlib/MyStarLinkMCPK.pm | 30 ------------------------------ t/cdbi/testlib/OtherFilm.pm | 23 ----------------------- 5 files changed, 126 deletions(-) delete mode 100644 t/cdbi/testlib/MyFilm.pm delete mode 100644 t/cdbi/testlib/MyStar.pm delete mode 100644 t/cdbi/testlib/MyStarLink.pm delete mode 100644 t/cdbi/testlib/MyStarLinkMCPK.pm delete mode 100644 t/cdbi/testlib/OtherFilm.pm diff --git a/t/cdbi/testlib/MyFilm.pm b/t/cdbi/testlib/MyFilm.pm deleted file mode 100644 index 40ecf7e77..000000000 --- a/t/cdbi/testlib/MyFilm.pm +++ /dev/null @@ -1,27 +0,0 @@ -package # hide from PAUSE - MyFilm; - -use warnings; -use strict; - -use base 'MyBase'; -use MyStarLink; - -__PACKAGE__->set_table(); -__PACKAGE__->columns(All => qw/filmid title/); -__PACKAGE__->has_many(_stars => 'MyStarLink'); -__PACKAGE__->columns(Stringify => 'title'); - -sub _carp { } - -sub stars { map $_->star, shift->_stars } - -sub create_sql { - return qq{ - filmid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY, - title VARCHAR(255) - }; -} - -1; - diff --git a/t/cdbi/testlib/MyStar.pm b/t/cdbi/testlib/MyStar.pm deleted file mode 100644 index 100fbf4a0..000000000 --- a/t/cdbi/testlib/MyStar.pm +++ /dev/null @@ -1,23 +0,0 @@ -package # hide from PAUSE - MyStar; - -use warnings; -use strict; - -use base 'MyBase'; - -__PACKAGE__->set_table(); -__PACKAGE__->columns(All => qw/starid name/); -__PACKAGE__->has_many(films => [ MyStarLink => 'film' ]); - -# sub films { map $_->film, shift->_films } - -sub create_sql { - return qq{ - starid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY, - name VARCHAR(255) - }; -} - -1; - diff --git a/t/cdbi/testlib/MyStarLink.pm b/t/cdbi/testlib/MyStarLink.pm deleted file mode 100644 index 27254d884..000000000 --- a/t/cdbi/testlib/MyStarLink.pm +++ /dev/null @@ -1,23 +0,0 @@ -package # hide from PAUSE - MyStarLink; - -use warnings; -use strict; - -use base 'MyBase'; - -__PACKAGE__->set_table(); -__PACKAGE__->columns(All => qw/linkid film star/); -__PACKAGE__->has_a(film => 'MyFilm'); -__PACKAGE__->has_a(star => 'MyStar'); - -sub create_sql { - return qq{ - linkid TINYINT NOT NULL AUTO_INCREMENT PRIMARY KEY, - film TINYINT NOT NULL, - star TINYINT NOT NULL - }; -} - -1; - diff --git a/t/cdbi/testlib/MyStarLinkMCPK.pm b/t/cdbi/testlib/MyStarLinkMCPK.pm deleted file mode 100644 index 1173163be..000000000 --- a/t/cdbi/testlib/MyStarLinkMCPK.pm +++ /dev/null @@ -1,30 +0,0 @@ -package # hide from PAUSE - MyStarLinkMCPK; - -use warnings; -use strict; - -use base 'MyBase'; - -use MyStar; -use MyFilm; - -# This is a many-to-many mapping table that uses the two foreign keys -# as its own primary key - there's no extra 'auto-inc' column here - -__PACKAGE__->set_table(); -__PACKAGE__->columns(Primary => qw/film star/); -__PACKAGE__->columns(All => qw/film star/); -__PACKAGE__->has_a(film => 'MyFilm'); -__PACKAGE__->has_a(star => 'MyStar'); - -sub create_sql { - return qq{ - film INTEGER NOT NULL, - star INTEGER NOT NULL, - PRIMARY KEY (film, star) - }; -} - -1; - diff --git a/t/cdbi/testlib/OtherFilm.pm b/t/cdbi/testlib/OtherFilm.pm deleted file mode 100644 index a0afdd8b5..000000000 --- a/t/cdbi/testlib/OtherFilm.pm +++ /dev/null @@ -1,23 +0,0 @@ -package # hide from PAUSE - OtherFilm; - -use warnings; -use strict; - -use base 'Film'; - -__PACKAGE__->set_table('Different_Film'); - -sub create_sql { - return qq{ - title VARCHAR(255), - director VARCHAR(80), - codirector VARCHAR(80), - rating CHAR(5), - numexplodingsheep INTEGER, - hasvomit CHAR(1) - }; -} - -1; - From 7c29ff830bf11e12320f25964643e627c72cb5b1 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 6 Mar 2016 07:08:56 +0100 Subject: [PATCH 024/262] (optdeps) _gen_pod can *very much* fail, not sure what I was thinking --- maint/Makefile.PL.inc/53_autogen_pod.pl | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/maint/Makefile.PL.inc/53_autogen_pod.pl b/maint/Makefile.PL.inc/53_autogen_pod.pl index f595f0d74..1c5530fa1 100644 --- a/maint/Makefile.PL.inc/53_autogen_pod.pl +++ b/maint/Makefile.PL.inc/53_autogen_pod.pl @@ -22,10 +22,17 @@ { print "Regenerating Optional/Dependencies.pod\n"; - # this should always succeed - hence no error checking - # if someone breaks OptDeps - travis should catch it - require DBIx::Class::Optional::Dependencies; - DBIx::Class::Optional::Dependencies->_gen_pod ($ver, "$pod_dir/lib"); + eval { + require DBIx::Class::Optional::Dependencies; + DBIx::Class::Optional::Dependencies->_gen_pod ($ver, "$pod_dir/lib"); + 1; + } + or + printf ("FAILED!!! Subsequent `make dist` will fail. %s\n", + $ENV{DBICDIST_DEBUG} + ? "Full error: $@" + : 'Re-run with $ENV{DBICDIST_DEBUG} set for more info' + ); postamble <<"EOP"; From bd52af73fba43175e16439d2a241dbf9d468cd5f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= Date: Mon, 7 Mar 2016 16:25:59 +0100 Subject: [PATCH 025/262] Fix erroneous use of multidimensional array emulation in 1fb834df --- xt/dist/postdistdir/whitespace.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/xt/dist/postdistdir/whitespace.t b/xt/dist/postdistdir/whitespace.t index 6601de234..17b20602b 100644 --- a/xt/dist/postdistdir/whitespace.t +++ b/xt/dist/postdistdir/whitespace.t @@ -39,7 +39,7 @@ if (open(my $gi, '<', '.gitignore')) { } # these we want to check no matter what the above says - delete $skipnames->{qw( + delete @{$skipnames}{qw( Changes LICENSE AUTHORS From 10dd5c05fee5be6ff4d72e41ab0d7b51809fdb5a Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 5 Mar 2016 15:32:11 +0100 Subject: [PATCH 026/262] Restructure thread/fork tests to run with maximum concurrency Add better exit handling on older perls: the thread-related failures on global destroy have nothing to do with what we want to test. Activated by setting $ENV{DBICTEST_DIRTY_EXIT} Also reduce the default amount of workers - 10 is too many --- t/50fork.t | 18 +++++++++++++----- t/51threadnodb.t | 23 +++++++++++++++++++---- t/51threads.t | 42 +++++++++++++++++++++++++++++++----------- t/51threadtxn.t | 27 +++++++++++++++++++++++---- t/lib/ANFANG.pm | 30 ++++++++++++++++++++++++++++++ 5 files changed, 116 insertions(+), 24 deletions(-) diff --git a/t/50fork.t b/t/50fork.t index c3c60ec88..244bf2af6 100644 --- a/t/50fork.t +++ b/t/50fork.t @@ -5,17 +5,17 @@ use strict; use warnings; use Test::More; use Test::Exception; - +use Time::HiRes qw(time sleep); use DBICTest; my $main_pid = $$; -# README: If you set the env var to a number greater than 10, +# README: If you set the env var to a number greater than 5, # we will use that many children my $num_children = $ENV{DBICTEST_FORK_STRESS} || 1; -if($num_children !~ /^[0-9]+$/ || $num_children < 10) { - $num_children = 10; +if($num_children !~ /^[0-9]+$/ || $num_children < 5) { + $num_children = 5; } my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; @@ -88,6 +88,11 @@ ok(!$@) or diag "Creation eval failed: $@"; } $parent_rs->reset; + +# sleep until this spot so everything starts simultaneously +# add "until turn of second" for prettier display +my $t = int( time() ) + 4; + my @pids; while(@pids < $num_children) { @@ -102,6 +107,9 @@ while(@pids < $num_children) { $pid = $$; + sleep ( $t - time ); + note ("Child process $pid starting work at " . time() ); + my $work = sub { my $child_rs = $schema->resultset('CD')->search({ year => 1901 }); my $row = $parent_rs->next; @@ -122,7 +130,7 @@ while(@pids < $num_children) { $work->(); } - sleep(3); + sleep(2); exit 0; } diff --git a/t/51threadnodb.t b/t/51threadnodb.t index 30e8aec65..ab3683c83 100644 --- a/t/51threadnodb.t +++ b/t/51threadnodb.t @@ -19,6 +19,7 @@ use warnings; use Test::More; use Errno (); use DBIx::Class::_Util 'sigwarn_silencer'; +use Time::HiRes qw(time sleep); use DBICTest; @@ -28,16 +29,20 @@ plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' plan skip_all => 'Potential problems on Win32 Perl < 5.14 and Variable::Magic - investigation pending' if $^O eq 'MSWin32' && "$]" < 5.014 && DBICTest::RunMode->is_plain; -# README: If you set the env var to a number greater than 10, +# README: If you set the env var to a number greater than 5, # we will use that many children my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; -if($num_children !~ /^[0-9]+$/ || $num_children < 10) { - $num_children = 10; +if($num_children !~ /^[0-9]+$/ || $num_children < 5) { + $num_children = 5; } my $schema = DBICTest->init_schema(no_deploy => 1); isa_ok ($schema, 'DBICTest::Schema'); +# sleep until this spot so everything starts simultaneously +# add "until turn of second" for prettier display +my $t = int( time() ) + 4; + my @threads; SKIP: { @@ -45,12 +50,17 @@ SKIP: { for (1.. $num_children) { push @threads, threads->create(sub { + my $tid = threads->tid; + + sleep ($t - time); + note ("Thread $tid starting work at " . time() ); + my $rsrc = $schema->source('Artist'); undef $schema; isa_ok ($rsrc->schema, 'DBICTest::Schema'); my $s2 = $rsrc->schema->clone; - sleep 1; # without this many tasty crashes + sleep (0.2); # without this many tasty crashes even on latest perls }) || do { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 if $! == Errno::EAGAIN(); @@ -65,4 +75,9 @@ ok(1, "past spawning"); $_->join for @threads; ok(1, "past joining"); +# Too many threading bugs on exit, none of which have anything to do with +# the actual stuff we test +$ENV{DBICTEST_DIRTY_EXIT} = 1 + if "$]"< 5.012; + done_testing; diff --git a/t/51threads.t b/t/51threads.t index 0f24f7ece..be0b1d670 100644 --- a/t/51threads.t +++ b/t/51threads.t @@ -21,6 +21,7 @@ use warnings; use Test::More; use Test::Exception; +use Time::HiRes qw(time sleep); plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' if "$]" < 5.008005; @@ -28,11 +29,11 @@ plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' use DBICTest; -# README: If you set the env var to a number greater than 10, +# README: If you set the env var to a number greater than 5, # we will use that many children my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; -if($num_children !~ /^[0-9]+$/ || $num_children < 10) { - $num_children = 10; +if($num_children !~ /^[0-9]+$/ || $num_children < 5) { + $num_children = 5; } my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; @@ -85,7 +86,7 @@ lives_ok (sub { done_testing; close $tb->$_ for (qw/output failure_output todo_output/); - sleep(1); # tasty crashes without this + sleep (0.2); # tasty crashes without this $out; }; @@ -103,18 +104,31 @@ lives_ok (sub { } $parent_rs->reset; + +# sleep until this spot so everything starts simultaneously +# add "until turn of second" for prettier display +my $t = int( time() ) + 4; + my @children; while(@children < $num_children) { my $newthread = async { my $tid = threads->tid; + sleep ($t - time); + + # FIXME if we do not stagger the threads, sparks fly due to CXSA + sleep ( $tid / 10 ) if "$]" < 5.012; + + note ("Thread $tid starting work at " . time() ); + my $child_rs = $schema->resultset('CD')->search({ year => 1901 }); my $row = $parent_rs->next; if($row && $row->get_column('artist') =~ /^(?:123|456)$/) { $schema->resultset('CD')->create({ title => "test success $tid", artist => $tid, year => scalar(@children) }); } - sleep(1); # tasty crashes without this + + sleep (0.2); # without this many tasty crashes even on latest perls }; die "Thread creation failed: $! $@" if !defined $newthread; push(@children, $newthread); @@ -122,16 +136,17 @@ while(@children < $num_children) { ok(1, "past spawning"); -{ - $_->join for(@children); +my @tids; +for (@children) { + push @tids, $_->tid; + $_->join; } ok(1, "past joining"); -while(@children) { - my $child = pop(@children); - my $tid = $child->tid; - my $rs = $schema->resultset('CD')->search({ title => "test success $tid", artist => $tid, year => scalar(@children) }); +while (@tids) { + my $tid = pop @tids; + my $rs = $schema->resultset('CD')->search({ title => "test success $tid", artist => $tid, year => scalar(@tids) }); is($rs->next->get_column('artist'), $tid, "Child $tid successful"); } @@ -140,4 +155,9 @@ undef $parent_rs; $schema->storage->dbh->do("DROP TABLE cd"); +# Too many threading bugs on exit, none of which have anything to do with +# the actual stuff we test +$ENV{DBICTEST_DIRTY_EXIT} = 1 + if "$]" < 5.012; + done_testing; diff --git a/t/51threadtxn.t b/t/51threadtxn.t index 3e285cace..52a6966e2 100644 --- a/t/51threadtxn.t +++ b/t/51threadtxn.t @@ -1,6 +1,6 @@ BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } -# README: If you set the env var to a number greater than 10, +# README: If you set the env var to a number greater than 5, # we will use that many children use Config; @@ -28,12 +28,13 @@ plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' if "$]" < 5.008005; use Scalar::Util 'weaken'; +use Time::HiRes qw(time sleep); use DBICTest; my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; -if($num_children !~ /^[0-9]+$/ || $num_children < 10) { - $num_children = 10; +if($num_children !~ /^[0-9]+$/ || $num_children < 5) { + $num_children = 5; } my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; @@ -59,11 +60,23 @@ eval { }; ok(!$@) or diag "Creation eval failed: $@"; +# sleep until this spot so everything starts simultaneously +# add "until turn of second" for prettier display +my $t = int( time() ) + 4; + my @children; while(@children < $num_children) { my $newthread = async { my $tid = threads->tid; + + sleep ($t - time); + + # FIXME if we do not stagger the threads, sparks fly due to CXSA + sleep ( $tid / 10 ) if "$]" < 5.012; + + note ("Thread $tid starting work at " . time() ); + weaken(my $weak_schema = $schema); weaken(my $weak_parent_rs = $parent_rs); $schema->txn_do(sub { @@ -73,7 +86,8 @@ while(@children < $num_children) { $weak_schema->resultset('CD')->create({ title => "test success $tid", artist => $tid, year => scalar(@children) }); } }); - sleep(1); # tasty crashes without this + + sleep (0.2); # without this many tasty crashes even on latest perls }; die "Thread creation failed: $! $@" if !defined $newthread; push(@children, $newthread); @@ -98,4 +112,9 @@ ok(1, "Made it to the end"); $schema->storage->dbh->do("DROP TABLE cd"); +# Too many threading bugs on exit, none of which have anything to do with +# the actual stuff we test +$ENV{DBICTEST_DIRTY_EXIT} = 1 + if "$]" < 5.012; + done_testing; diff --git a/t/lib/ANFANG.pm b/t/lib/ANFANG.pm index 354bc0138..bdae98362 100644 --- a/t/lib/ANFANG.pm +++ b/t/lib/ANFANG.pm @@ -151,6 +151,36 @@ lib->import('t/lib'); # dead. In order to reduce hair-pulling make sure that ./inc/ is always there -f 'Makefile.PL' and mkdir 'inc' and mkdir 'inc/.author'; +END { + if( my @finalest_tasks = ( + + ( !$ENV{DBICTEST_DIRTY_EXIT} ? () : sub { + + my $exit = $?; + require POSIX; + + # Crucial flushes in case we are piping things out (e.g. prove) + # Otherwise the last lines will never arrive at the receiver + select($_), $| = 1 for \*STDOUT, \*STDERR; + + POSIX::_exit($exit); + } ), + + )) { + + # in the case of an early skip_all B may very well not have loaded + unless( $INC{"B.pm"} ) { + local ( $!, $^E, $?, $@ ); + require B; + } + + # Make sure we run after any cleanup in other END blocks + # ( push-to-end twice in a row ) + push @{ B::end_av()->object_2svref }, sub { + push @{ B::end_av()->object_2svref }, @finalest_tasks; + } + } +} # make absolutely sure this is last $anfang_loaded = 1; From 2c4abbea2d69eda73c1b91194eb8b7f52414d522 Mon Sep 17 00:00:00 2001 From: Matthew Horsfall Date: Tue, 8 Mar 2016 15:15:04 +0100 Subject: [PATCH 027/262] Much simpler sure-flush on dirty exit ( ribasushi-- # overcomplicating ) --- AUTHORS | 1 + t/lib/ANFANG.pm | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/AUTHORS b/AUTHORS index 086b0e0ce..264ee550c 100644 --- a/AUTHORS +++ b/AUTHORS @@ -19,6 +19,7 @@ acca: Alexander Kuznetsov aherzog: Adam Herzog Alexander Keusch alexrj: Alessandro Ranellucci +alh: Matthew Horsfall alnewkirk: Al Newkirk Altreus: Alastair McGowan-Douglas amiri: Amiri Barksdale diff --git a/t/lib/ANFANG.pm b/t/lib/ANFANG.pm index bdae98362..05304bf79 100644 --- a/t/lib/ANFANG.pm +++ b/t/lib/ANFANG.pm @@ -161,7 +161,7 @@ END { # Crucial flushes in case we are piping things out (e.g. prove) # Otherwise the last lines will never arrive at the receiver - select($_), $| = 1 for \*STDOUT, \*STDERR; + close($_) for \*STDOUT, \*STDERR; POSIX::_exit($exit); } ), From 81698df5b8fb9654139e5ebe3d112d958bcb9856 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 8 Mar 2016 18:29:41 +0100 Subject: [PATCH 028/262] (travis) Make sure DEVREL_DEPS + CLEANTEST-false behaves as intended This lapse was the reason https://github.com/Test-More/test-more/issues/637 went undetected for a while (also made me aware of RT#112312, ARGH!) --- maint/travis-ci_scripts/30_before_script.bash | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index d5f3cd0c0..24515a83d 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -142,7 +142,12 @@ else run_or_err "Configure on current branch with --with-optdeps" "perl Makefile.PL --with-optdeps" - parallel_installdeps_notest "$(make listdeps | sort -R)" + # if we are smoking devrels - make sure we upgrade everything we know about + if [[ "$DEVREL_DEPS" == "true" ]] ; then + parallel_installdeps_notest "$(make listalldeps | sort -R)" + else + parallel_installdeps_notest "$(make listdeps | sort -R)" + fi run_or_err "Re-configure with --with-optdeps" "perl Makefile.PL --with-optdeps" fi From bf3802a96bc090d96e7aa4f0f60d2731d3dbd003 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 9 Mar 2016 17:48:16 +0100 Subject: [PATCH 029/262] (travis) Strangely `cpan .` does not work in certain configs No intention to investigate further at this time --- maint/travis-ci_scripts/50_after_success.bash | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/maint/travis-ci_scripts/50_after_success.bash b/maint/travis-ci_scripts/50_after_success.bash index a6dfecc96..16c90d541 100755 --- a/maint/travis-ci_scripts/50_after_success.bash +++ b/maint/travis-ci_scripts/50_after_success.bash @@ -88,9 +88,11 @@ if [[ -n "$tarball_assembled" ]] ; then export $e="" done + # FIXME - for some reason a plain `cpan .` does not work in this case + # no time to investigate run_or_err \ "Attempt to configure/test/build/install dist using latest CPAN@$(perl -MCPAN -e 'print CPAN->VERSION')" \ - "cpan ." + "perl -MCPAN -e 'install( q{.} )'" else run_or_err \ From 24fbd7fba01adfc25b53614f8d713af1bd31ae21 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 3 Mar 2016 15:27:34 +0100 Subject: [PATCH 030/262] Move expensive test to xt/, add malloc-canary preventing false-negatives This test was originally written to validate both Devel::GlobalDestruction::PP and the M.A.D. cyclic reference handler (a4367b26). These days it makes little sense to run on end-user installs, yet this bizarre test still uncovers weird problems in the underlying Rube Goldberg machine. So instead of outright deleting it - move it to xt/ and validate its execution environment with what is essentially a guarded calloc() Add a tight-memory travis config to make sure that OOM won't kill the wrong thing Read diff under -C --- .travis.yml | 1 + t/lib/DBICTest/Util.pm | 24 ++++++++ .../extra/internals/ithread_stress.t | 59 ++++++++++++++----- 3 files changed, 68 insertions(+), 16 deletions(-) rename t/51threadnodb.t => xt/extra/internals/ithread_stress.t (59%) diff --git a/.travis.yml b/.travis.yml index 4b3fb43cc..250679eb5 100644 --- a/.travis.yml +++ b/.travis.yml @@ -139,6 +139,7 @@ matrix: - perl: "5.8.8_thr" sudo: required dist: precise + group: legacy env: - VCPU_USE=1 - CLEANTEST=false diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 5d54c1170..68b6e2c68 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -302,6 +302,30 @@ sub rm_rf ($) { } +# This is an absolutely horrible thing to do on an end-user system +# DO NOT use it indiscriminately - ideally under nothing short of ->is_smoker +# Not added to EXPORT_OK on purpose +sub can_alloc_MB ($) { + my $arg = shift; + $arg = 'UNDEF' if not defined $arg; + + croak "Expecting a positive integer, got '$arg'" + if $arg !~ /^[1-9][0-9]*$/; + + my ($perl) = $^X =~ /(.+)/; + local $ENV{PATH}; + local $ENV{PERL5LIB} = join ($Config{path_sep}, @INC); + + local ( $!, $^E, $?, $@ ); + + system( $perl, qw( -Mt::lib::ANFANG -e ), <<'EOS', $arg ); +$0 = 'malloc_canary'; +my $tail_character_of_reified_megastring = substr( ( join '', map chr, 0..255 ) x (4 * 1024 * $ARGV[0]), -1 ); +EOS + + !!( $? == 0 ) +} + sub stacktrace { my $frame = shift; $frame++; diff --git a/t/51threadnodb.t b/xt/extra/internals/ithread_stress.t similarity index 59% rename from t/51threadnodb.t rename to xt/extra/internals/ithread_stress.t index ab3683c83..c1d46f2a8 100644 --- a/t/51threadnodb.t +++ b/xt/extra/internals/ithread_stress.t @@ -1,34 +1,60 @@ BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } +use warnings; +use strict; + use Config; BEGIN { - unless ($Config{useithreads}) { - print "1..0 # SKIP your perl does not support ithreads\n"; - exit 0; + my $skipall; + + # FIXME: this discrepancy is crazy, need to investigate + my $mem_needed = ($Config{ptrsize} == 4) + ? 200 + : 750 + ; + + if( ! $Config{useithreads} ) { + $skipall = 'your perl does not support ithreads'; + } + elsif( "$]" < 5.008005 ) { + $skipall = 'DBIC does not actively support threads before perl 5.8.5'; + } + elsif( $INC{'Devel/Cover.pm'} ) { + $skipall = 'Devel::Cover does not work with ithreads yet'; + } + elsif( + ! $ENV{DBICTEST_RUN_ALL_TESTS} + and + require DBICTest::RunMode + and + ! DBICTest::RunMode->is_smoker + ) { + $skipall = "Test is too expensive (may use up to ${mem_needed}MB of memory), skipping on non-smoker"; } + else { + require threads; + threads->import(); - if ($INC{'Devel/Cover.pm'}) { - print "1..0 # SKIP Devel::Cover does not work with threads yet\n"; + require DBICTest; + # without this the can_alloc may very well shoot half of the CI down + DBICTest->import(':GlobalLock'); + + unless ( DBICTest::Util::can_alloc_MB($mem_needed) ) { + $skipall = "Your system does not have the necessary amount of memory (${mem_needed}MB) for this ridiculous test"; + } + } + + if( $skipall ) { + print "1..0 # SKIP $skipall\n"; exit 0; } } -use threads; -use strict; -use warnings; use Test::More; use Errno (); use DBIx::Class::_Util 'sigwarn_silencer'; use Time::HiRes qw(time sleep); -use DBICTest; - -plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' - if "$]" < 5.008005; - -plan skip_all => 'Potential problems on Win32 Perl < 5.14 and Variable::Magic - investigation pending' - if $^O eq 'MSWin32' && "$]" < 5.014 && DBICTest::RunMode->is_plain; - # README: If you set the env var to a number greater than 5, # we will use that many children my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; @@ -73,6 +99,7 @@ SKIP: { ok(1, "past spawning"); $_->join for @threads; + ok(1, "past joining"); # Too many threading bugs on exit, none of which have anything to do with From 820a29360e4920d9edff9e9cefe721b8a265e40d Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 10 Mar 2016 19:02:00 +0100 Subject: [PATCH 031/262] Really work around RT#108390 (630e2ea8a) A certain chain of events can still deadlock things without an explicit flush --- t/lib/DBICTest/Util.pm | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 68b6e2c68..b084560f3 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -88,7 +88,21 @@ sub await_flock ($$) { # "say something" every 10 cycles to work around RT#108390 # jesus christ our tooling is such a crock of shit :( - print "#\n" if not $tries % 10; + unless ( $tries % 10 ) { + + # Turning on autoflush is crucial: if stars align just right buffering + # will ensure we never actually call write() underneath until the grand + # timeout is reached (and that's too long). Reproducible via + # + # DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1 \ + # DBICTEST_RUN_ALL_TESTS=1 \ + # strace -f \ + # prove -lj10 xt/extra/internals/ + # + select( ( select(\*STDOUT), $|=1 )[0] ); + + print "#\n"; + } } return $res; From 90a5b0237843707bba83646e8d14f6bf4b782ba5 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 10 Mar 2016 21:32:35 +0100 Subject: [PATCH 032/262] Fix failing test case missed during da9346a03 Adjust CI to execute one job as a non-poisoning noisy tracer --- .travis.yml | 2 +- t/34exception_action.t | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 250679eb5..6c63f9002 100644 --- a/.travis.yml +++ b/.travis.yml @@ -187,8 +187,8 @@ matrix: dist: precise env: - CLEANTEST=false - - POISON_ENV=true - DBIC_TRACE=1 + - DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1 - BREWVER=5.16.3 - BREWOPTS="-Duseithreads -Dusemorebits" diff --git a/t/34exception_action.t b/t/34exception_action.t index c9c0f6b81..d326bf707 100644 --- a/t/34exception_action.t +++ b/t/34exception_action.t @@ -102,14 +102,14 @@ for my $ap (qw( # make sure an exception_action can replace $@ with an antipattern $schema->exception_action(sub { die $ap->new }); - warnings_like { + warnings_exist { eval { $throw->() }; isa_ok $@, $ap; } $exp_warn, 'proper warning on antipattern encountered within exception_action'; # and make sure that the rethrow works $schema->exception_action(sub { die @_ }); - warnings_like { + warnings_exist { eval { $schema->txn_do (sub { die $ap->new }); }; From d0289ee13bb30b44fbdc541cc796174c40929bc4 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 12 Feb 2016 09:27:38 +0100 Subject: [PATCH 033/262] Better testing that RT#63874 being fully fixed by ddcc02d1 Also separate some of the basic find() tests to a new testfile --- Changes | 1 + t/60core.t | 11 ----------- t/resultset/find.t | 47 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 48 insertions(+), 11 deletions(-) create mode 100644 t/resultset/find.t diff --git a/Changes b/Changes index 954675273..ba1c4aaa0 100644 --- a/Changes +++ b/Changes @@ -6,6 +6,7 @@ Revision history for DBIx::Class insulated from changes in control flow, as the handlers are only invoked when an error is leaving the DBIC internals to be handled by the caller (n.b. https://github.com/PerlDancer/Dancer2/issues/1125) + (also fixes the previously rejected RT#63874) - $result->related_resultset() no longer passes extra arguments to an underlying search_rs(), as by design these arguments would be used only on the first call to ->related_resultset(), and ignored diff --git a/t/60core.t b/t/60core.t index d01a5fd8d..0420a9fc5 100644 --- a/t/60core.t +++ b/t/60core.t @@ -125,19 +125,8 @@ warnings_exist { $schema->resultset('Artist')->search_rs(id => 4) } qr/\Qsearch( %condition ) is deprecated/, 'Deprecation warning on ->search( %condition )'; -# this has been warning for 4 years, killing -throws_ok { - $schema->resultset('Artist')->find(artistid => 4); -} qr|expects either a column/value hashref, or a list of values corresponding to the columns of the specified unique constraint|; - is($schema->resultset("Artist")->count, 4, 'count ok'); -# test find on an unresolvable condition -is( - $schema->resultset('Artist')->find({ artistid => [ -and => 1, 2 ]}), - undef -); - # test find_or_new { diff --git a/t/resultset/find.t b/t/resultset/find.t new file mode 100644 index 000000000..8244a6da4 --- /dev/null +++ b/t/resultset/find.t @@ -0,0 +1,47 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +use DBICTest; + +my $schema = DBICTest->init_schema(); + +# this has been warning for 4 years, killing +throws_ok { + $schema->resultset('Artist')->find(artistid => 4); +} qr|expects either a column/value hashref, or a list of values corresponding to the columns of the specified unique constraint|; + +{ + my $exception_callback_count = 0; + + my $ea = $schema->exception_action(sub { + $exception_callback_count++; + die @_; + }); + + # No, this is not a great idea. + # Yes, people do it anyway. + # Might as well test that we have fixed it for good, by never invoking + # a potential __DIE__ handler in internal_try() stacks + local $SIG{__DIE__} = sub { $ea->(@_) }; + + # test find on non-unique non-existing value + is ( + $schema->resultset('Artist')->find({ rank => 666 }), + undef + ); + + # test find on an unresolvable condition + is( + $schema->resultset('Artist')->find({ artistid => [ -and => 1, 2 ]}), + undef + ); + + is $exception_callback_count, 0, 'exception_callback never invoked'; +} + +done_testing; From 5c33c8beee177383b6c7913989b60629783dedf1 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 22 Mar 2016 23:43:19 +0100 Subject: [PATCH 034/262] Expand ASSERT_NO_SPURIOUS_EXCEPTION_ACTION to set a rogue $SIG{__DIE__} This simple augmentation of ddcc02d1 caught a couple extra spots where a __DIE__ handler could be incorrectly triggered (one of them ironically introduced by 86cdddbe which happened *after* the work in ddcc02d1) See next commit for *YET MORE* of the same... --- lib/DBIx/Class/Optional/Dependencies.pm | 3 +++ lib/DBIx/Class/ResultSource.pm | 1 + lib/DBIx/Class/Schema.pm | 1 + lib/DBIx/Class/Storage/DBI.pm | 6 ++---- lib/DBIx/Class/_Util.pm | 7 +++---- t/lib/DBICTest/BaseSchema.pm | 25 +++++++++++++++++++++++-- t/lib/DBICTest/Util/LeakTracer.pm | 2 ++ t/storage/txn_scope_guard.t | 5 +++++ 8 files changed, 40 insertions(+), 10 deletions(-) diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm index 7b447ef9e..43790b247 100644 --- a/lib/DBIx/Class/Optional/Dependencies.pm +++ b/lib/DBIx/Class/Optional/Dependencies.pm @@ -1156,6 +1156,9 @@ sub _errorlist_for_modreqs { my $v = $reqs->{$m}; if (! exists $req_unavailability_cache{$m}{$v} ) { + # masking this off is important, as it may very well be + # a transient error + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; eval( "require $m;" . ( $v ? "$m->VERSION(q($v))" : '' ) ); $req_unavailability_cache{$m}{$v} = $@; diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 0940e0dd1..847cecb98 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -2358,6 +2358,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 :((( + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; eval { weaken $_[0]->{schema}; diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 17427054b..7527ddfc6 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -1448,6 +1448,7 @@ sub DESTROY { # however beware - on older perls the exception seems randomly untrappable # due to some weird race condition during thread joining :((( if (length ref $srcs->{$source_name} and refcount($srcs->{$source_name}) > 1) { + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; eval { $srcs->{$source_name}->schema($self); diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index cafdf1939..1f66d713a 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -904,10 +904,8 @@ sub disconnect { my $g = scope_guard { - { - local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT; - eval { $self->_dbh->disconnect }; - } + defined( $self->_dbh ) + and dbic_internal_try { $self->_dbh->disconnect }; $self->_dbh(undef); $self->_dbh_details({}); diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 358a3aa7e..8c62054cc 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -161,6 +161,7 @@ sub is_exception ($) { my ($not_blank, $suberror); { + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; eval { # The ne() here is deliberate - a plain length($e), or worse "$e" ne @@ -270,9 +271,7 @@ sub is_exception ($) { unless $callstack_state->{in_internal_try}; # always unset - someone may have snuck it in - local $SIG{__DIE__} - if $SIG{__DIE__}; - + local $SIG{__DIE__} if $SIG{__DIE__}; if( $wantarray ) { @ret = $try_cref->(); @@ -383,8 +382,8 @@ sub modver_gt_or_eq ($$) { local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ ) if SPURIOUS_VERSION_CHECK_WARNINGS; + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; - local $SIG{__DIE__}; eval { $mod->VERSION($ver) } ? 1 : 0; }; diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index 0214933cd..111b84b16 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -13,7 +13,7 @@ use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY use namespace::clean; if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { - __PACKAGE__->exception_action( sub { + my $ea = __PACKAGE__->exception_action( sub { my ( $fr_num, $disarmed, $throw_exception_fr_num ); while( ! $disarmed and my @fr = caller(++$fr_num) ) { @@ -55,7 +55,27 @@ if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { ) unless $disarmed; DBIx::Class::Exception->throw( $_[0] ); - }) + }); + + my $interesting_ns_rx = qr/^ (?: main$ | DBIx::Class:: | DBICTest:: ) /x; + + # hard-set $SIG{__DIE__} to the class-wide exception_action + # with a little escape preceeding it + $SIG{__DIE__} = sub { + + # without this there would be false positives everywhere :( + die @_ if ( + (caller(0))[0] !~ $interesting_ns_rx + or + ( + caller(0) eq 'main' + and + (caller(1))[0] !~ $interesting_ns_rx + ) + ); + + &$ea; + }; } sub capture_executed_sql_bind { @@ -216,6 +236,7 @@ sub connection { # we need to work with a forced fresh clone so that we do not upset any state # of the main $schema (some tests examine it quite closely) local $SIG{__WARN__} = sub {}; + local $SIG{__DIE__}; local $@; # this will either give us an undef $locktype or will determine things diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index 82ff01065..03a8a13f7 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -57,6 +57,7 @@ sub populate_weakregistry { # on perl < 5.8.3 sometimes a weaken can throw (can't find RT) # so guard against that unlikely event + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; eval { weaken( $weak_registry->{$refaddr}{weakref} ); $refs_traced++ } or delete $weak_registry->{$refaddr}; @@ -134,6 +135,7 @@ sub visit_refs { my $type = reftype $r; + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; eval { if ($type eq 'HASH') { diff --git a/t/storage/txn_scope_guard.t b/t/storage/txn_scope_guard.t index 56d602dac..e9e69a34e 100644 --- a/t/storage/txn_scope_guard.t +++ b/t/storage/txn_scope_guard.t @@ -139,6 +139,11 @@ require DBICTest::AntiPattern::NullObject; } }; + + # we are driving manually here, do not allow interference + local $SIG{__DIE__} if $SIG{__DIE__}; + + no warnings 'redefine'; local *DBIx::Class::Storage::DBI::txn_rollback = sub { die 'die die my darling' }; Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; From 7704dbc93be76967fd8b051a3f6b1df32a2467a3 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 12 Feb 2016 09:27:38 +0100 Subject: [PATCH 035/262] Make sure handling of exception_action is recursion-safe Pointed out by Lukas Mai in the last (fifth) bullet point of https://github.com/PerlDancer/Dancer2/issues/1125#issuecomment-180326756 In addition add extra testing making sure that we will not inadvertently silence $SIG{__DIE__} when the error is *not* transient Hopefully this is the last piece of the "clean transient exceptions" puzzle, it's already been way too much faffing: 7cb35852, ddcc02d1 and 5c33c8be :( --- lib/DBIx/Class/Schema.pm | 17 ++++++++--------- t/34exception_action.t | 16 ++++++++++++++++ t/storage/reconnect.t | 28 +++++++++++++++++++--------- 3 files changed, 43 insertions(+), 18 deletions(-) diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 7527ddfc6..f8179fb65 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -1088,7 +1088,7 @@ This guard was activated beginning" ); }; - eval { + dbic_internal_try { # if it throws - good, we'll assign to @args in the end # if it doesn't - do different things depending on RV truthiness if( $act->(@args) ) { @@ -1109,14 +1109,13 @@ This guard was activated beginning" 1; } - - or - - # We call this to get the necessary warnings emitted and disregard the RV - # as it's definitely an exception if we got as far as this do{} block - is_exception( - $args[0] = $@ - ); + catch { + # We call this to get the necessary warnings emitted and disregard the RV + # as it's definitely an exception if we got as far as this catch{} block + is_exception( + $args[0] = $_ + ); + }; # Done guarding against https://github.com/PerlDancer/Dancer2/issues/1125 $guard_disarmed = 1; diff --git a/t/34exception_action.t b/t/34exception_action.t index d326bf707..aa803eb23 100644 --- a/t/34exception_action.t +++ b/t/34exception_action.t @@ -6,6 +6,7 @@ use warnings; use Test::More; use Test::Exception; use Test::Warn; +use Scalar::Util 'weaken'; use DBICTest; @@ -118,4 +119,19 @@ for my $ap (qw( } $exp_warn, 'Proper warning on encountered antipattern'; } +# ensure we do not get into an infloop +{ + weaken( my $s = $schema ); + + $schema->exception_action(sub{ + $s->throw_exception(@_) + }); + + throws_ok { + $schema->storage->dbh_do(sub { + $_[1]->do('wgwfwfwghawhjsejsethjwetjesjesjsejsetjes') + } ) + } qr/syntax error/i; +} + done_testing; diff --git a/t/storage/reconnect.t b/t/storage/reconnect.t index c19f44f81..9c1c564e8 100644 --- a/t/storage/reconnect.t +++ b/t/storage/reconnect.t @@ -16,12 +16,22 @@ my $db_tmp = "$db_orig.tmp"; # Set up the "usual" sqlite for DBICTest my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); -my $exception_action_count; -$schema->exception_action(sub { - $exception_action_count++; +my $exception_callback_count; +my $ea = $schema->exception_action(sub { + $exception_callback_count++; die @_; }); + +# No, this is not a great idea. +# Yes, people do it anyway. +# Might as well test that we have fixed it for good, by never invoking +# a potential __DIE__ handler in internal_try() stacks. In cases of regular +# exceptions we expect *both* the exception action *AND* the __DIE__ to +# fire once +$SIG{__DIE__} = sub { &$ea }; + + # Make sure we're connected by doing something my @art = $schema->resultset("Artist")->search({ }, { order_by => { -desc => 'name' }}); cmp_ok(@art, '==', 3, "Three artists returned"); @@ -98,7 +108,7 @@ for my $ctx (keys %$ctx_map) { # start disconnected and then connected $schema->storage->disconnect; - $exception_action_count = 0; + $exception_callback_count = 0; for (1, 2) { my $disarmed; @@ -115,7 +125,7 @@ for my $ctx (keys %$ctx_map) { }, @$args) }); } - is( $exception_action_count, 0, 'exception_action never called' ); + is( $exception_callback_count, 0, 'neither exception_action nor $SIG{__DIE__} ever called' ); }; # make sure RT#110429 does not recur on manual DBI-side disconnect @@ -149,7 +159,7 @@ for my $cref ( note( "Testing with " . B::Deparse->new->coderef2text($cref) ); $schema->storage->disconnect; - $exception_action_count = 0; + $exception_callback_count = 0; ok( !$schema->storage->connected, 'Not connected' ); @@ -164,13 +174,13 @@ for my $cref ( is( $schema->storage->transaction_depth, undef, "Depth expectedly unknown after failed rollbacks" ); - is( $exception_action_count, 1, "exception_action called only once" ); + is( $exception_callback_count, 2, 'exception_action and $SIG{__DIE__} called only once each' ); } # check exception_action under tenacious disconnect { $schema->storage->disconnect; - $exception_action_count = 0; + $exception_callback_count = 0; throws_ok { $schema->txn_do(sub { $schema->storage->_dbh->disconnect; @@ -178,7 +188,7 @@ for my $cref ( $schema->resultset('Artist')->next; })} qr/prepare on inactive database handle/; - is( $exception_action_count, 1, "exception_action called only once" ); + is( $exception_callback_count, 2, 'exception_action and $SIG{__DIE__} called only once each' ); } # check that things aren't crazy with a non-violent disconnect From 27f3e97d85a38736e91d30f2b78195be898316d9 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 24 Mar 2016 15:35:51 +0100 Subject: [PATCH 036/262] Remove some old forgotten pieces of code in collapse resolver --- lib/DBIx/Class/ResultSource/RowParser.pm | 3 +-- t/resultset/rowparser_internals.t | 8 -------- 2 files changed, 1 insertion(+), 10 deletions(-) diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index 83be406fc..aaa02fb71 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -225,7 +225,7 @@ sub _resolve_collapse { if ( ! $args->{_parent_info}{underdefined} and ! $args->{_parent_info}{rev_rel_is_optional} ) { for my $col ( values %{$args->{_parent_info}{rel_condition} || {}} ) { next if exists $my_cols->{$col}; - $my_cols->{$col} = { via_collapse => $args->{_parent_info}{collapse_on_idcols} }; + $my_cols->{$col} = {}; $assumed_from_parent->{columns}{$col}++; } } @@ -402,7 +402,6 @@ sub _resolve_collapse { @{ $collapse_map->{-identifying_columns} }, )]; - my @id_sets; for my $rel (sort keys %$relinfo) { $collapse_map->{$rel} = $relinfo->{$rel}{rsrc}->_resolve_collapse ({ diff --git a/t/resultset/rowparser_internals.t b/t/resultset/rowparser_internals.t index 235e5d4df..3f6c38a04 100644 --- a/t/resultset/rowparser_internals.t +++ b/t/resultset/rowparser_internals.t @@ -9,14 +9,6 @@ use DBICTest; use B::Deparse; use DBIx::Class::_Util 'perlstring'; -# globally set for the rest of test -# the rowparser maker does not order its hashes by default for the miniscule -# speed gain. But it does not disable sorting either - for this test -# everything will be ordered nicely, and the hash randomization of 5.18 -# will not trip up anything -use Data::Dumper; -$Data::Dumper::Sortkeys = 1; - my $schema = DBICTest->init_schema(no_deploy => 1); my $infmap = [qw/ single_track.cd.artist.name From 8fc4291ef4f19b6f4c4f25cd695cb613da613fe1 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 28 Mar 2016 22:50:55 +0200 Subject: [PATCH 037/262] Lose yet another dep (Data::Dumper::Concise) --- Makefile.PL | 1 - lib/DBIx/Class/ResultSet.pm | 12 +++--- lib/DBIx/Class/Storage/DBI.pm | 14 +++---- lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm | 5 +-- lib/DBIx/Class/Storage/DBIHacks.pm | 11 +++--- lib/DBIx/Class/_Util.pm | 38 ++++++++++++++++++- .../Translator/Producer/DBIx/Class/File.pm | 11 ++---- t/00describe_environment.t | 1 + t/cdbi/23-cascade.t | 5 +-- t/lib/DBICTest/Util/LeakTracer.pm | 5 +-- t/prefetch/attrs_untouched.t | 12 +++--- t/search/stack_cond.t | 6 +-- t/sqlmaker/dbihacks_internals.t | 5 +-- t/sqlmaker/oracle.t | 4 +- t/sqlmaker/order_by_bindtransport.t | 4 +- t/storage/base.t | 11 ++++-- .../deprecated_exception_source_bind_attrs.t | 2 - t/storage/quote_names.t | 17 ++------- 18 files changed, 86 insertions(+), 78 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index 0bf82f3f4..a44941b20 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -57,7 +57,6 @@ my $runtime_requires = { 'Class::C3::Componentised' => '1.0009', 'Class::Inspector' => '1.24', 'Context::Preserve' => '0.01', - 'Data::Dumper::Concise' => '2.020', 'Data::Page' => '2.00', 'Devel::GlobalDestruction' => '0.09', 'Hash::Merge' => '0.12', diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 0a6c002c7..e60483293 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -8,7 +8,7 @@ use DBIx::Class::ResultSetColumn; use DBIx::Class::ResultClass::HashRefInflator; use Scalar::Util qw/blessed weaken reftype/; use DBIx::Class::_Util qw( - dbic_internal_try + dbic_internal_try dump_value fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION ); use Try::Tiny; @@ -554,7 +554,6 @@ sub search_rs { return $rs; } -my $dark_sel_dumper; sub _normalize_selection { my ($self, $attrs) = @_; @@ -619,11 +618,10 @@ sub _normalize_selection { else { $attrs->{_dark_selector} = { plus_stage => $pref, - string => ($dark_sel_dumper ||= do { - require Data::Dumper::Concise; - Data::Dumper::Concise::DumperObject()->Indent(0); - })->Values([$_])->Dump - , + string => do { + local $Data::Dumper::Indent = 0; + dump_value $_; + }, }; last SELECTOR; } diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 1f66d713a..01c8dccba 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -14,7 +14,7 @@ use Context::Preserve 'preserve_context'; use Try::Tiny; use SQL::Abstract qw(is_plain_value is_literal_value); use DBIx::Class::_Util qw( - quote_sub perlstring serialize + quote_sub perlstring serialize dump_value dbic_internal_try detected_reinvoked_destructor scope_guard mkdir_p @@ -1419,12 +1419,10 @@ sub _get_rdbms_name { shift->_dbh_get_info('SQL_DBMS_NAME') } sub _warn_undetermined_driver { my ($self, $msg) = @_; - require Data::Dumper::Concise; - carp_once ($msg . ' While we will attempt to continue anyway, the results ' . 'are likely to be underwhelming. Please upgrade DBIC, and if this message ' . "does not go away, file a bugreport including the following info:\n" - . Data::Dumper::Concise::Dumper($self->_describe_connection) + . dump_value $self->_describe_connection ); } @@ -2200,13 +2198,12 @@ sub _insert_bulk { $msg, $cols->[$c_idx], do { - require Data::Dumper::Concise; local $Data::Dumper::Maxdepth = 5; - Data::Dumper::Concise::Dumper ({ + dump_value { map { $cols->[$_] => $data->[$r_idx][$_] } 0..$#$cols - }), + }; } ); }; @@ -2403,10 +2400,9 @@ sub _dbh_execute_for_fetch { $self->throw_exception("Unexpected populate error: $err") if ($i > $#$tuple_status); - require Data::Dumper::Concise; $self->throw_exception(sprintf "execute_for_fetch() aborted with '%s' at populate slice:\n%s", ($tuple_status->[$i][1] || $err), - Data::Dumper::Concise::Dumper( { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) } ), + dump_value { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) }, ); } diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm index 3479ff34e..3d66fa169 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm @@ -13,10 +13,9 @@ use DBIx::Class::Carp; use Scalar::Util qw/blessed weaken/; use List::Util 'first'; use Sub::Name(); -use Data::Dumper::Concise 'Dumper'; use Try::Tiny; use Context::Preserve 'preserve_context'; -use DBIx::Class::_Util qw( sigwarn_silencer dbic_internal_try ); +use DBIx::Class::_Util qw( sigwarn_silencer dbic_internal_try dump_value ); use namespace::clean; __PACKAGE__->sql_limit_dialect ('GenericSubQ'); @@ -781,7 +780,7 @@ sub _insert_blobs { if (not $sth) { $self->throw_exception( "Could not find row in table '$table' for blob update:\n" - . (Dumper \%where) + . dump_value \%where ); } diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm index 14410b700..e98bc4948 100644 --- a/lib/DBIx/Class/Storage/DBIHacks.pm +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -30,7 +30,7 @@ use mro 'c3'; use List::Util 'first'; use Scalar::Util 'blessed'; -use DBIx::Class::_Util qw(UNRESOLVABLE_CONDITION serialize); +use DBIx::Class::_Util qw(UNRESOLVABLE_CONDITION serialize dump_value); use SQL::Abstract qw(is_plain_value is_literal_value); use DBIx::Class::Carp; use namespace::clean; @@ -513,9 +513,9 @@ sub _resolve_aliastypes_from_select_args { ( $_ = join ' ', map { ( ! defined $_ ) ? () - : ( length ref $_ ) ? (require Data::Dumper::Concise && $self->throw_exception( - "Unexpected ref in scan-plan: " . Data::Dumper::Concise::Dumper($_) - )) + : ( length ref $_ ) ? $self->throw_exception( + "Unexpected ref in scan-plan: " . dump_value $_ + ) : ( $_ =~ /^\s*$/ ) ? () : $_ @@ -1346,11 +1346,10 @@ sub _collapse_cond_unroll_pairs { # extra sanity check if (keys %$p > 1) { - require Data::Dumper::Concise; local $Data::Dumper::Deepcopy = 1; $self->throw_exception( "Internal error: unexpected collapse unroll:" - . Data::Dumper::Concise::Dumper { in => { $lhs => $rhs }, out => $p } + . dump_value { in => { $lhs => $rhs }, out => $p } ); } diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 8c62054cc..60a4815ab 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -75,7 +75,7 @@ our @EXPORT_OK = qw( refdesc refcount hrefaddr scope_guard detected_reinvoked_destructor is_exception dbic_internal_try - quote_sub qsub perlstring serialize deep_clone + quote_sub qsub perlstring serialize deep_clone dump_value parent_dir mkdir_p UNRESOLVABLE_CONDITION ); @@ -121,6 +121,42 @@ sub serialize ($) { nfreeze($_[0]); } +my ($dd_obj, $dump_str); +sub dump_value ($) { + local $Data::Dumper::Indent = 1 + unless defined $Data::Dumper::Indent; + + $dump_str = ( + $dd_obj + ||= + do { + require Data::Dumper; + my $d = Data::Dumper->new([]) + ->Purity(0) + ->Pad('') + ->Useqq(1) + ->Terse(1) + ->Freezer('') + ->Quotekeys(0) + ->Bless('bless') + ->Pair(' => ') + ->Sortkeys(1) + ->Deparse(1) + ; + + $d->Sparseseen(1) if modver_gt_or_eq ( + 'Data::Dumper', '2.136' + ); + + $d; + } + )->Values([$_[0]])->Dump; + + $dd_obj->Reset->Values([]); + + $dump_str; +} + sub scope_guard (&) { croak 'Calling scope_guard() in void context makes no sense' if ! defined wantarray; diff --git a/lib/SQL/Translator/Producer/DBIx/Class/File.pm b/lib/SQL/Translator/Producer/DBIx/Class/File.pm index 90c61fd38..db02f7c70 100644 --- a/lib/SQL/Translator/Producer/DBIx/Class/File.pm +++ b/lib/SQL/Translator/Producer/DBIx/Class/File.pm @@ -36,7 +36,7 @@ $DEBUG = 0 unless defined $DEBUG; use SQL::Translator::Schema::Constants; use SQL::Translator::Utils qw(header_comment); -use Data::Dumper (); +use DBIx::Class::_Util 'dump_value'; ## Skip all column type translation, as we want to use whatever the parser got. @@ -108,13 +108,9 @@ __PACKAGE__->table('${tname}'); $output .= "\n__PACKAGE__->add_columns("; foreach my $f (@fields) { - local $Data::Dumper::Terse = 1; $output .= "\n '" . (keys %$f)[0] . "' => " ; - my $colinfo = - Data::Dumper->Dump([values %$f], - [''] # keys %$f] - ); - chomp($colinfo); + ( my $colinfo = dump_value( (values %$f)[0] ) ) =~ s/^/ /mg; + $colinfo =~ s/^\s*|\s*$//g; $output .= $colinfo . ","; } $output .= "\n);\n"; @@ -129,7 +125,6 @@ __PACKAGE__->table('${tname}'); foreach my $cont ($table->get_constraints) { -# print Data::Dumper::Dumper($cont->type); if($cont->type =~ /foreign key/i) { # $output .= "\n__PACKAGE__->belongs_to('" . diff --git a/t/00describe_environment.t b/t/00describe_environment.t index a88c18741..37e3da946 100644 --- a/t/00describe_environment.t +++ b/t/00describe_environment.t @@ -192,6 +192,7 @@ my $load_weights = { my @known_modules = sort { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) } + qw( Data::Dumper ), keys %{ DBIx::Class::Optional::Dependencies->req_list_for([ grep diff --git a/t/cdbi/23-cascade.t b/t/cdbi/23-cascade.t index c66cffb73..cedf91a15 100644 --- a/t/cdbi/23-cascade.t +++ b/t/cdbi/23-cascade.t @@ -5,7 +5,7 @@ use strict; use warnings; use Test::More; -use Data::Dumper; +use DBIx::Class::_Util 'dump_value'; use lib 't/cdbi/testlib'; use Film; @@ -42,8 +42,7 @@ for my $args ({ no_cascade_delete => 1 }, { cascade => "None" }) { is $dir->nasties, 1, "We have one nasty"; ok $dir->delete; - local $Data::Dumper::Terse = 1; - ok +Film->retrieve("Alligator"), 'has_many with ' . Dumper ($args);; + ok +Film->retrieve("Alligator"), 'has_many with ' . dump_value $args; $kk->delete; } diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index 03a8a13f7..8e2e6e896 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -6,9 +6,8 @@ use strict; use ANFANG; use Carp; use Scalar::Util qw(isweak weaken blessed reftype); -use DBIx::Class::_Util qw(refcount hrefaddr refdesc); +use DBIx::Class::_Util qw(refcount hrefaddr refdesc dump_value); use DBICTest::RunMode; -use Data::Dumper::Concise; use DBICTest::Util qw( stacktrace visit_namespaces ); use constant { CV_TRACING => !!( @@ -280,7 +279,7 @@ sub assert_empty_weakregistry { ref($weak_registry->{$addr}{weakref}) eq 'CODE' and B::svref_2object($weak_registry->{$addr}{weakref})->XSUB - ) ? '__XSUB__' : Dumper( $weak_registry->{$addr}{weakref} ) + ) ? '__XSUB__' : dump_value $weak_registry->{$addr}{weakref} ; }; diff --git a/t/prefetch/attrs_untouched.t b/t/prefetch/attrs_untouched.t index ce99b4259..7b5034488 100644 --- a/t/prefetch/attrs_untouched.t +++ b/t/prefetch/attrs_untouched.t @@ -6,9 +6,7 @@ use strict; use Test::More; use DBICTest; - -use Data::Dumper; -$Data::Dumper::Sortkeys = 1; +use DBIx::Class::_Util 'dump_value'; my $schema = DBICTest->init_schema(); @@ -19,11 +17,11 @@ plan tests => 3; my $search = { 'artist.name' => 'Caterwauler McCrae' }; my $attr = { prefetch => [ qw/artist liner_notes/ ], order_by => 'me.cdid' }; -my $search_str = Dumper($search); -my $attr_str = Dumper($attr); +my $search_str = dump_value $search; +my $attr_str = dump_value $attr; my $rs = $schema->resultset("CD")->search($search, $attr); -is(Dumper($search), $search_str, 'Search hash untouched after search()'); -is(Dumper($attr), $attr_str, 'Attribute hash untouched after search()'); +is( dump_value $search, $search_str, 'Search hash untouched after search()'); +is( dump_value $attr, $attr_str, 'Attribute hash untouched after search()'); cmp_ok($rs + 0, '==', 3, 'Correct number of records returned'); diff --git a/t/search/stack_cond.t b/t/search/stack_cond.t index 4c06a5db5..497b69834 100644 --- a/t/search/stack_cond.t +++ b/t/search/stack_cond.t @@ -5,12 +5,10 @@ use warnings; use Test::More; +use DBIx::Class::_Util 'dump_value'; use DBICTest ':DiffSQL'; use SQL::Abstract qw(is_plain_value is_literal_value); use List::Util 'shuffle'; -use Data::Dumper; -$Data::Dumper::Terse = 1; -$Data::Dumper::Useqq = 1; $Data::Dumper::Indent = 0; my $schema = DBICTest->init_schema(); @@ -87,7 +85,7 @@ for my $c ( year $c->{sql} )", \@bind, - 'Double condition correctly collapsed for steps' . Dumper \@query_steps, + 'Double condition correctly collapsed for steps' . dump_value \@query_steps, ); } diff --git a/t/sqlmaker/dbihacks_internals.t b/t/sqlmaker/dbihacks_internals.t index cf75a2644..4e34f13e6 100644 --- a/t/sqlmaker/dbihacks_internals.t +++ b/t/sqlmaker/dbihacks_internals.t @@ -8,9 +8,8 @@ use Test::Exception; use DBICTest ':DiffSQL'; -use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION'; +use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dump_value ); -use Data::Dumper; BEGIN { if ( eval { require Test::Differences } ) { no warnings 'redefine'; @@ -626,7 +625,7 @@ for my $t (@tests) { ) { die unless Test::Builder->new->is_passing; - my $name = do { local ($Data::Dumper::Indent, $Data::Dumper::Terse, $Data::Dumper::Sortkeys) = (0, 1, 1); Dumper $w }; + my $name = do { local $Data::Dumper::Indent = 0; dump_value $w }; my ($collapsed_cond, $collapsed_cond_as_sql); diff --git a/t/sqlmaker/oracle.t b/t/sqlmaker/oracle.t index 31fc4961c..0fef7fba7 100644 --- a/t/sqlmaker/oracle.t +++ b/t/sqlmaker/oracle.t @@ -6,8 +6,8 @@ use warnings; use Test::More; use Test::Exception; -use Data::Dumper::Concise; +use DBIx::Class::_Util 'dump_value'; use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::Oracle; @@ -68,7 +68,7 @@ for my $case (@handle_tests) { sub { ( $stmt, @bind ) = $sqla_oracle->_recurse_where( $case->{connect_by} ); is_same_sql_bind( $stmt, \@bind, $case->{stmt}, $case->{bind},$msg ) - || diag "Search term:\n" . Dumper $case->{connect_by}; + || diag "Search term:\n" . dump_value $case->{connect_by}; } ,sprintf("lives is ok from '%s'",$msg)); } diff --git a/t/sqlmaker/order_by_bindtransport.t b/t/sqlmaker/order_by_bindtransport.t index f99a19182..08afe42e9 100644 --- a/t/sqlmaker/order_by_bindtransport.t +++ b/t/sqlmaker/order_by_bindtransport.t @@ -5,8 +5,8 @@ use warnings; use Test::More; use Test::Exception; -use Data::Dumper::Concise; +use DBIx::Class::_Util 'dump_value'; use DBICTest ':DiffSQL'; sub test_order { @@ -43,7 +43,7 @@ sub test_order { ? map { [ { dbic_colname => $_->[0] } => $_->[1] ] } @{ $args->{bind} } : () ], - ) || diag Dumper $args->{order_by}; + ) || diag dump_value $args->{order_by}; }; } diff --git a/t/storage/base.t b/t/storage/base.t index b4fd7892c..90cd8f7b1 100644 --- a/t/storage/base.t +++ b/t/storage/base.t @@ -8,7 +8,7 @@ use Test::Warn; use Test::Exception; use DBICTest; -use Data::Dumper; +use DBIx::Class::_Util 'dump_value'; my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); @@ -157,8 +157,7 @@ for my $type (keys %$invocations) { # we can not use a cloner portably because of the coderef # so compare dumps instead - local $Data::Dumper::Sortkeys = 1; - my $arg_dump = Dumper ($invocations->{$type}{args}); + my $arg_dump = dump_value $invocations->{$type}{args}; warnings_exist ( sub { $storage->connect_info ($invocations->{$type}{args}) }, @@ -166,7 +165,11 @@ for my $type (keys %$invocations) { 'Warned about ignored attributes', ); - is ($arg_dump, Dumper ($invocations->{$type}{args}), "$type didn't modify passed arguments"); + is ( + $arg_dump, + dump_value $invocations->{$type}{args}, + "$type didn't modify passed arguments", + ); is_deeply ($storage->_dbi_connect_info, $invocations->{$type}{dbi_connect_info}, "$type produced correct _dbi_connect_info"); ok ( (not $storage->auto_savepoint and not $storage->unsafe), "$type correctly ignored extra hashref"); diff --git a/t/storage/deprecated_exception_source_bind_attrs.t b/t/storage/deprecated_exception_source_bind_attrs.t index 3a6c2dd98..cba18bcb2 100644 --- a/t/storage/deprecated_exception_source_bind_attrs.t +++ b/t/storage/deprecated_exception_source_bind_attrs.t @@ -13,8 +13,6 @@ use DBICTest; package DBICTest::Legacy::Storage; use base 'DBIx::Class::Storage::DBI::SQLite'; - use Data::Dumper::Concise; - sub source_bind_attributes { return {} } } diff --git a/t/storage/quote_names.t b/t/storage/quote_names.t index ff82d9f0a..591606c4d 100644 --- a/t/storage/quote_names.t +++ b/t/storage/quote_names.t @@ -3,10 +3,11 @@ BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use strict; use warnings; use Test::More; -use Data::Dumper::Concise; use Try::Tiny; use DBICTest; +use DBIx::Class::_Util 'dump_value'; +$Data::Dumper::Indent = 0; my %expected = ( 'DBIx::Class::Storage::DBI' => @@ -62,7 +63,7 @@ for my $class (keys %expected) { SKIP: { my ($quote_char, $name_sep) = @$mapping{qw/quote_char name_sep/}; my $instance = $class->new; - my $quote_char_text = dumper($quote_char); + my $quote_char_text = dump_value $quote_char; if (exists $mapping->{quote_char}) { is_deeply $instance->sql_quote_char, $quote_char, @@ -122,7 +123,7 @@ for my $db (sort { my ($exp_quote_char, $exp_name_sep) = @{$expected{$dbs{$db}}}{qw/quote_char name_sep/}; - my ($quote_char_text, $name_sep_text) = map { dumper($_) } + my ($quote_char_text, $name_sep_text) = map { dump_value $_ } ($exp_quote_char, $exp_name_sep); is_deeply $sql_maker->quote_char, @@ -148,13 +149,3 @@ for my $db (sort { } done_testing; - -sub dumper { - my $val = shift; - - my $dd = DumperObject; - $dd->Indent(0); - return $dd->Values([ $val ])->Dump; -} - -1; From 40471d469bc450ab29789724d94f4c3c825c158f Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 26 Mar 2016 23:14:09 +0100 Subject: [PATCH 038/262] Fix incorrect data returned in a corner case of partial-select HRI While investigating better reporting on disagreeing metadata and actual results returned by the data source, I stumbled across an incorrect optimization applied to the HRI fast-path in aa1d8a87. The reason this has never been a problem in the wild is that the failure case is very convoluted: In order for the problem to present itself one needs to have a subchain of ... something-single ... with the "something" not fetching anything AND the entire chain being hit exactly once (no multiplication of the branch neither by a result or a parallel 1:M) AND the HRI fast-path code needs to be in effect. Then and only then everything from "something"onwards will present as "nonexisting left join" and a sole undef will be returned in place of the entire substructure. --- Changes | 3 ++ lib/DBIx/Class/ResultSource/RowParser/Util.pm | 8 ++-- t/inflate/hri_torture.t | 38 +++++++++++++++++++ t/resultset/rowparser_internals.t | 6 +-- 4 files changed, 48 insertions(+), 7 deletions(-) diff --git a/Changes b/Changes index ba1c4aaa0..2714c0f45 100644 --- a/Changes +++ b/Changes @@ -34,6 +34,9 @@ Revision history for DBIx::Class similar produces a large warning - Make sure exception objects stringifying to '' are properly handled and warned about (GH#15) + - Fix incorrect data returned in a corner case of partial-select HRI + invocation (no known manifestations of this bug in the field, see + commit message for description of exact failure scenario) - Fix corner case of stringify-only overloaded objects being used in create()/populate() - Fix spurious ROLLBACK statements when a TxnScopeGuard fails a commit diff --git a/lib/DBIx/Class/ResultSource/RowParser/Util.pm b/lib/DBIx/Class/ResultSource/RowParser/Util.pm index a20d07cb9..d82f7b4b7 100644 --- a/lib/DBIx/Class/ResultSource/RowParser/Util.pm +++ b/lib/DBIx/Class/ResultSource/RowParser/Util.pm @@ -285,19 +285,19 @@ sub __visit_infmap_collapse { ); if ($args->{collapse_map}->{-is_single}) { - push @src, sprintf ( '( %s %s %s%s ),', + push @src, sprintf ( '( %s %s %s = %s ),', $parent_attach_slot, (HAS_DOR ? '//=' : '||='), $node_idx_slot, - $me_struct ? " = $me_struct" : '', + $me_struct || '{}', ); } else { - push @src, sprintf('( (! %s) and push @{%s}, %s%s ),', + push @src, sprintf('( (! %s) and push @{%s}, %s = %s ),', $node_idx_slot, $parent_attach_slot, $node_idx_slot, - $me_struct ? " = $me_struct" : '', + $me_struct || '{}', ); } } diff --git a/t/inflate/hri_torture.t b/t/inflate/hri_torture.t index c0b763eb2..610a47b40 100644 --- a/t/inflate/hri_torture.t +++ b/t/inflate/hri_torture.t @@ -40,6 +40,7 @@ $schema->resultset('CD')->create({ title => 'Oxygene', year => 1976, artist => { name => 'JMJ' }, + artwork => {}, tracks => [ { title => 'o2', position => 2}, # the position should not be needed here, bug in MC ], @@ -330,6 +331,43 @@ cmp_deeply 'collapsing 1:1:1:M:M chain ' . $rs->result_class, ; +cmp_deeply + [ $rs->search_rs ( + { + 'tracks.title' => 'e2', + 'cds.title' => 'Oxygene', + }, + { + collapse => 1, + join => [ + 'tracks', + { single_track => { cd => 'mandatory_artwork' } }, + { artist => { cds => 'mandatory_artwork'} }, + ], + columns => { + cdid => 'cdid', + 'single_track.cd.mandatory_artwork.cd_id' => 'mandatory_artwork.cd_id', + 'artist.cds.mandatory_artwork.cd_id' => 'mandatory_artwork_2.cd_id', + }, + }, + )->all ], + [ + { + cdid => 3, + single_track => { + cd => { + mandatory_artwork => { cd_id => 2 }, + }, + }, + artist => { + cds => [ + { mandatory_artwork => { cd_id => 2 } } + ] + }, + }, + ], +; + } done_testing; diff --git a/t/resultset/rowparser_internals.t b/t/resultset/rowparser_internals.t index 3f6c38a04..0ad310701 100644 --- a/t/resultset/rowparser_internals.t +++ b/t/resultset/rowparser_internals.t @@ -343,10 +343,10 @@ is_same_src ( # prefetch data of single_track (placed in root) ( (! defined($cur_row_data->[1]) ) ? $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}}{single_track} = undef : do { - ( $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}}{single_track} //= $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} ), + ( $collapse_idx[0]{$cur_row_ids{4}}{$cur_row_ids{5}}{single_track} //= $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = {} ), # prefetch data of cd (placed in single_track) - ( $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}{cd} //= $collapse_idx[2]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} ), + ( $collapse_idx[1]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}{cd} //= $collapse_idx[2]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = {} ), # prefetch data of artist ( placed in single_track->cd) ( $collapse_idx[2]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}}{artist} //= $collapse_idx[3]{$cur_row_ids{1}}{$cur_row_ids{4}}{$cur_row_ids{5}} = { artistid => $cur_row_data->[1] } ), @@ -787,7 +787,7 @@ is_same_src ( ( $collapse_idx[0]{$cur_row_ids{10}}{single_track} //= ($collapse_idx[1]{$cur_row_ids{0}} = { trackid => $$cur_row_data[0] }) ), - ( $collapse_idx[1]{$cur_row_ids{0}}{cd} //= $collapse_idx[2]{$cur_row_ids{0}} ), + ( $collapse_idx[1]{$cur_row_ids{0}}{cd} //= $collapse_idx[2]{$cur_row_ids{0}} = {} ), ( $collapse_idx[2]{$cur_row_ids{0}}{artist} //= ($collapse_idx[3]{$cur_row_ids{0}} = { artistid => $$cur_row_data[6] }) ), From 9ceb04c6a5a6de6e11009e1f58e387a77c618284 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 28 Mar 2016 18:56:46 +0200 Subject: [PATCH 039/262] More tests and tighter code with better error reporting in collapser maker Additionally RowParser::Util was scanned with Devel::Core to ensure I don't have any remaining holes similar to 1fd3505d. The coverage of said file is not at 100%, due to bugs in Devel::Cover itself, notably handling of $x = $y || $z ( https://github.com/pjcj/Devel--Cover/issues/154 ) --- lib/DBIx/Class/ResultSource/RowParser/Util.pm | 25 +++++++---- t/resultset/inflate_result_api.t | 44 +++++++++++++++++++ 2 files changed, 60 insertions(+), 9 deletions(-) diff --git a/lib/DBIx/Class/ResultSource/RowParser/Util.pm b/lib/DBIx/Class/ResultSource/RowParser/Util.pm index d82f7b4b7..09b8ec4f8 100644 --- a/lib/DBIx/Class/ResultSource/RowParser/Util.pm +++ b/lib/DBIx/Class/ResultSource/RowParser/Util.pm @@ -4,8 +4,7 @@ package # hide from the pauses use strict; use warnings; -use List::Util 'first'; -use DBIx::Class::_Util 'perlstring'; +use DBIx::Class::_Util qw( perlstring dump_value ); use constant HAS_DOR => ( "$]" < 5.010 ? 0 : 1 ); @@ -126,7 +125,7 @@ sub assemble_collapsing_parser { my @path_parts = map { sprintf "( ( defined \$cur_row_data->[%d] ) && (join qq(\xFF), '', %s, '') )", $_->[0], # checking just first is enough - one ID defined, all defined - ( join ', ', map { ++$variant_idcols->{$_} and " \$cur_row_ids{$_} " } @$_ ), + ( join ', ', map { $variant_idcols->{$_} = 1; " \$cur_row_ids{$_} " } @$_ ), } @variants; my $virtual_column_idx = (scalar keys %{$args->{val_index}} ) + 1; @@ -144,7 +143,10 @@ sub assemble_collapsing_parser { }; } else { - die('Unexpected collapse map contents'); + DBIx::Class::Exception->throw( + 'Unexpected collapse map contents: ' . dump_value $args->{collapse_map}, + 1, + ) } my ($data_assemblers, $stats) = __visit_infmap_collapse ($args); @@ -169,7 +171,7 @@ sub assemble_collapsing_parser { ) ; - my $parser_src = sprintf (<<'EOS', $row_id_defs, $top_node_key_assembler||'', $top_node_key, join( "\n", @{$data_assemblers||[]} ) ); + my $parser_src = sprintf (<<'EOS', $row_id_defs, $top_node_key_assembler||'', $top_node_key, join( "\n", @$data_assemblers ) ); ### BEGIN LITERAL STRING EVAL my $rows_pos = 0; my ($result_pos, @collapse_idx, $cur_row_data, %%cur_row_ids ); @@ -322,12 +324,17 @@ sub __visit_infmap_collapse { if ( $relinfo->{-is_optional} - and - defined ( my $first_distinct_child_idcol = first + ) { + + my ($first_distinct_child_idcol) = grep { ! $known_present_ids->{$_} } @{$relinfo->{-identifying_columns}} - ) - ) { + ; + + DBIx::Class::Exception->throw( + "An optional node *without* a distinct identifying set shouldn't be possible: " . dump_value $args->{collapse_map}, + 1, + ) unless defined $first_distinct_child_idcol; if ($args->{prune_null_branches}) { diff --git a/t/resultset/inflate_result_api.t b/t/resultset/inflate_result_api.t index 6f5b0a8aa..e09bad18e 100644 --- a/t/resultset/inflate_result_api.t +++ b/t/resultset/inflate_result_api.t @@ -39,6 +39,7 @@ $schema->resultset('CD')->create({ title => 'Oxygene', year => 1976, artist => { name => 'JMJ' }, + artwork => {}, tracks => [ { title => 'o2', position => 2}, # the position should not be needed here, bug in MC ], @@ -469,6 +470,49 @@ INFTYPE: for ('', '(native inflator)') { ], "Expected output of collapsing 1:M with empty root selection $native_inflator", ); + + cmp_structures ( + rs_contents( $schema->resultset ('CD')->search_rs ( + { + 'tracks.title' => 'e2', + 'cds.title' => 'Oxygene', + }, + { + collapse => 1, + join => [ + 'tracks', + { single_track => { cd => 'mandatory_artwork' } }, + { artist => { cds => 'mandatory_artwork'} }, + ], + columns => { + cdid => 'cdid', + 'single_track.cd.mandatory_artwork.cd_id' => 'mandatory_artwork.cd_id', + 'artist.cds.mandatory_artwork.cd_id' => 'mandatory_artwork_2.cd_id', + }, + }, + )), + [[ + { cdid => 3 }, + { + single_track => [ + undef, + { cd => [ + undef, + { mandatory_artwork => [ { cd_id => 2 } ] } + ] } + ], + artist => [ + undef, + { cds => [ + [ + undef, + { mandatory_artwork => [ { cd_id => 2 } ] } + ] + ] }, + ], + } + ]], + ); } sub null_branch { From 2d5ac3cf038f571d61c422abadc11ef2779b2b0a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= Date: Tue, 29 Mar 2016 13:10:39 +0100 Subject: [PATCH 040/262] Remove confusing code introduced in 8fc4291e but why is $dump_str declared outside dump_value? ilmari: silly minimalistic microoptimization (not to reclear the dump every time it's needed) ilmari: my $foo { reuse $foo many time in this scope } *minimally faster* than { use my $foo_to_be_cleared_any_time_we_leave_scope } less for the scope unwinder to do as I said - it's silly, and 100% undetectable is dump_value that hot? it's not hot at all we've probably wasted more time discussing this now than the total CPU time saved by that micro-optimisation, over the entire future lifetime of DBIC ilmari: well, my 1st sentence today was admitting exactly that ;) I have been working on the rowparser for 5 days, the mindset is different, and it "bleeds through" --- lib/DBIx/Class/_Util.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 60a4815ab..f07dff6d5 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -121,12 +121,12 @@ sub serialize ($) { nfreeze($_[0]); } -my ($dd_obj, $dump_str); +my $dd_obj; sub dump_value ($) { local $Data::Dumper::Indent = 1 unless defined $Data::Dumper::Indent; - $dump_str = ( + my $dump_str = ( $dd_obj ||= do { From fd2d3c95807b9d4f812966cec28d110c70680cd2 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 25 Mar 2016 18:15:34 +0100 Subject: [PATCH 041/262] Support one more convoluted case of data-poor collapse Any might_have ( optional, 1:1 ) relation with a fully defined left-side is identifiable as long as at least one non-nullable (not necessarily unique) column is fetched --- lib/DBIx/Class/ResultSource/RowParser.pm | 51 +++++++- t/resultset/rowparser_internals.t | 160 +++++++++++++++++++++++ 2 files changed, 207 insertions(+), 4 deletions(-) diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index aaa02fb71..93d7ef933 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -178,13 +178,13 @@ sub _resolve_collapse { $args->{_is_top_level} = 1; }; - my ($my_cols, $rel_cols); + my ($my_cols, $rel_cols, $native_cols); for (keys %{$args->{as}}) { if ($_ =~ /^ ([^\.]+) \. (.+) /x) { $rel_cols->{$1}{$2} = 1; } else { - $my_cols->{$_} = {}; # important for ||='s below + $native_cols->{$_} = $my_cols->{$_} = {}; # important for ||='s below } } @@ -240,9 +240,50 @@ sub _resolve_collapse { # first try to reuse the parent's collapser (i.e. reuse collapser over 1:1) # (makes for a leaner coderef later) - unless ($collapse_map->{-identifying_columns}) { + if( + ! $collapse_map->{-identifying_columns} + and + $args->{_parent_info}{collapser_reusable} + ) { $collapse_map->{-identifying_columns} = $args->{_parent_info}{collapse_on_idcols} - if $args->{_parent_info}{collapser_reusable}; + } + + # Still don't know how to collapse - in case we are a *single* relationship + # AND our parent is defined AND we have any *native* non-nullable pieces: then + # we are still good to go + # NOTE: it doesn't matter if the nonnullable set is unique or not - it will be + # made unique by the parents identifying cols + if( + ! $collapse_map->{-identifying_columns} + and + $args->{_parent_info}{is_single} + and + @{ $args->{_parent_info}{collapse_on_idcols} } + and + ( my @native_nonnull_cols = grep { + $native_cols->{$_}{colinfo} + and + ! $native_cols->{$_}{colinfo}{is_nullable} + } keys %$native_cols ) + ) { + + $collapse_map->{-identifying_columns} = [ __unique_numlist( + @{ $args->{_parent_info}{collapse_on_idcols}||[] }, + + # FIXME - we don't really need *all* of the columns, $our_nonnull_cols[0] + # is sufficient. However map the entire thing to engage the extra nonnull + # explicit checks, just to be on the safe side + # Remove some day in the future + (map + { + $common_args->{_as_fq_idx}{join ('.', + @{$args->{_rel_chain}}[1 .. $#{$args->{_rel_chain}}], + $_, + )} + } + @native_nonnull_cols + ), + )]; } # Still don't know how to collapse - try to resolve based on our columns (plus already inserted FK bridges) @@ -415,6 +456,8 @@ sub _resolve_collapse { is_optional => ! $relinfo->{$rel}{is_inner}, + is_single => $relinfo->{$rel}{is_single}, + # if there is at least one *inner* reverse relationship which is HASH-based (equality only) # we can safely assume that the child can not exist without us rev_rel_is_optional => ( first diff --git a/t/resultset/rowparser_internals.t b/t/resultset/rowparser_internals.t index 0ad310701..50f3ebf73 100644 --- a/t/resultset/rowparser_internals.t +++ b/t/resultset/rowparser_internals.t @@ -828,6 +828,166 @@ is_same_src ( 'Multiple has_many on multiple branches with underdefined root, HRI-direct torture test', ); + +$infmap = [ + 'single_track.lyrics.track_id', # (0) random optional 1:1:1 chain + 'year', # (1) non-unique + 'tracks.cd', # (2) \ together both uniqueness for second multirel + 'tracks.title', # (3) / and definitive link back to root + 'single_track.cd.artist.cds.cdid', # (4) to give uniquiness to ...tracks.title below + 'single_track.cd.artist.cds.year', # (5) non-unique + 'single_track.cd.artist.artistid', # (6) uniqufies entire parental chain + 'single_track.cd.artist.cds.genreid', # (7) nullable + 'single_track.cd.artist.cds.tracks.title', # (8) unique when combined with ...cds.cdid above + 'single_track.lyrics.lyric_versions.text', # (9) unique combined with the single_track.lyrics 1:1:1 +]; + +is_deeply ( + $schema->source('CD')->_resolve_collapse({ as => {map { $infmap->[$_] => $_ } 0 .. $#$infmap} }), + { + -identifying_columns => [], + -identifying_columns_variants => [ + [ 2 ], [ 6 ], + ], + single_track => { + -identifying_columns => [ 6 ], + -is_optional => 1, + -is_single => 1, + cd => { + -identifying_columns => [ 6 ], + -is_single => 1, + artist => { + -identifying_columns => [ 6 ], + -is_single => 1, + cds => { + -identifying_columns => [ 4, 6 ], + -is_optional => 1, + tracks => { + -identifying_columns => [ 4, 6, 8 ], + -is_optional => 1, + } + } + } + }, + lyrics => { + -identifying_columns => [ 0, 6 ], + -is_optional => 1, + -is_single => 1, + lyric_versions => { + -identifying_columns => [ 0, 6, 9 ], + -is_optional => 1, + }, + }, + }, + tracks => { + -identifying_columns => [ 2, 3 ], + -is_optional => 1, + } + }, + 'Correct underdefined root tripple-has-many-torture collapse map constructed' +); + +is_same_src ( + ($schema->source ('CD')->_mk_row_parser({ + inflate_map => $infmap, + collapse => 1, + hri_style => 1, + prune_null_branches => 1, + }))[0], + ' my $rows_pos = 0; + my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids); + + while ($cur_row_data = ( + ( + $rows_pos >= 0 + and + ( + $_[0][$rows_pos++] + or + ( ($rows_pos = -1), undef ) + ) + ) + or + ( $_[1] and $_[1]->() ) + ) ) { + + # do not care about nullability here + ( @cur_row_ids{( 0, 2, 3, 4, 6, 8, 9 )} = @{$cur_row_data}[( 0, 2, 3, 4, 6, 8, 9 )] ), + + # cache expensive set of ops in a non-existent rowid slot + ( $cur_row_ids{11} = ( + ( ( defined $cur_row_data->[2] ) && (join "\xFF", q{}, $cur_row_ids{2}, q{} )) + or + ( ( defined $cur_row_data->[6] ) && (join "\xFF", q{}, $cur_row_ids{6}, q{} )) + or + "\0$rows_pos\0" + )), + + # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2] + ( $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{11}} and (unshift @{$_[2]}, $cur_row_data) and last ), + + ( $collapse_idx[0]{$cur_row_ids{11}} //= $_[0][$result_pos++] = { year => $$cur_row_data[1] } ), + + ( (! defined $cur_row_data->[6] ) ? $collapse_idx[0]{$cur_row_ids{11}}{single_track} = undef : do { + + ( $collapse_idx[0]{$cur_row_ids{11}}{single_track} //= ( $collapse_idx[1]{$cur_row_ids{6}} = {} ) ), + + ( $collapse_idx[1]{$cur_row_ids{6}}{cd} //= $collapse_idx[2]{$cur_row_ids{6}} = {} ), + + ( $collapse_idx[2]{$cur_row_ids{6}}{artist} //= ($collapse_idx[3]{$cur_row_ids{6}} = { artistid => $$cur_row_data[6] }) ), + + ( (! defined $cur_row_data->[4] ) ? $collapse_idx[3]{$cur_row_ids{6}}{cds} = [] : do { + + ( + (! $collapse_idx[4]{$cur_row_ids{4}}{$cur_row_ids{6}} ) + and + push @{$collapse_idx[3]{$cur_row_ids{6}}{cds}}, ( + $collapse_idx[4]{$cur_row_ids{4}}{$cur_row_ids{6}} = { cdid => $$cur_row_data[4], genreid => $$cur_row_data[7], year => $$cur_row_data[5] } + ) + ), + + ( (! defined $cur_row_data->[8] ) ? $collapse_idx[4]{$cur_row_ids{4}}{$cur_row_ids{6}}{tracks} = [] : do { + + (! $collapse_idx[5]{$cur_row_ids{4}}{$cur_row_ids{6}}{$cur_row_ids{8}} ) + and + push @{$collapse_idx[4]{$cur_row_ids{4}}{$cur_row_ids{6}}{tracks}}, ( + $collapse_idx[5]{$cur_row_ids{4}}{$cur_row_ids{6}}{$cur_row_ids{8}} = { title => $$cur_row_data[8] } + ), + } ), + } ), + + ( ( ! defined $cur_row_data->[0] ) ? $collapse_idx[1]{ $cur_row_ids{6} }{"lyrics"} = undef : do { + + ( $collapse_idx[1]{ $cur_row_ids{6} }{"lyrics"} //= ( $collapse_idx[6]{ $cur_row_ids{0} }{ $cur_row_ids{6} } = { "track_id" => $cur_row_data->[0] } ) ), + + ( ( ! defined $cur_row_data->[9] ) ? $collapse_idx[6]{ $cur_row_ids{0} }{ $cur_row_ids{6} }{"lyric_versions"} = [] : do { + ( + (! $collapse_idx[7]{ $cur_row_ids{0} }{ $cur_row_ids{6} }{ $cur_row_ids{9} }) + and + push @{$collapse_idx[6]{ $cur_row_ids{0} }{ $cur_row_ids{6} }{"lyric_versions"}}, ( + $collapse_idx[7]{ $cur_row_ids{0} }{ $cur_row_ids{6} }{ $cur_row_ids{9} } = { "text" => $cur_row_data->[9] } + ), + ), + } ), + } ), + } ), + + ( (! defined $cur_row_data->[2] ) ? $collapse_idx[0]{$cur_row_ids{11}}{tracks} = [] : do { + ( + (! $collapse_idx[8]{$cur_row_ids{2}}{$cur_row_ids{3}} ) + and + push @{$collapse_idx[0]{$cur_row_ids{11}}{tracks}}, ( + $collapse_idx[8]{$cur_row_ids{2}}{$cur_row_ids{3}} = { cd => $$cur_row_data[2], title => $$cur_row_data[3] } + ) + ), + } ), + } + + $#{$_[0]} = $result_pos - 1; + ', + 'Tripple multiple has_many on multiple branches with underdefined root, HRI-direct torture test', +); + is_same_src ( ($schema->source ('Owners')->_mk_row_parser({ inflate_map => [qw( books.title books.owner )], From 5ff6d6034ddcb696d24c4b716b5c12f109004d1f Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 24 Mar 2016 16:22:44 +0100 Subject: [PATCH 042/262] First part of changes for better unexpected NULL reporting Doing things in two parts to make it easier to reason about. This part only changes the collapse_map visitor to collect more metadata, and uses a bit of it to elide a couple of // ops. Additionally we are now feeding the stash-arrayref to the collapser at all times, it will become clear way in the next commit (where all the real changes are) Read under -w --- lib/DBIx/Class/ResultSet.pm | 3 +- lib/DBIx/Class/ResultSource/RowParser/Util.pm | 107 +++++++++++++++--- t/prefetch/lazy_cursor.t | 2 +- t/resultset/rowparser_internals.t | 6 +- 4 files changed, 96 insertions(+), 22 deletions(-) diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index e60483293..456503162 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -1485,7 +1485,8 @@ EOS $self->{_row_parser}{$parser_type}{cref}->( $rows, - $next_cref ? ( $next_cref, $self->{_stashed_rows} = [] ) : (), + $next_cref, + ( $self->{_stashed_rows} = [] ), ); # simple in-place substitution, does not regrow $rows diff --git a/lib/DBIx/Class/ResultSource/RowParser/Util.pm b/lib/DBIx/Class/ResultSource/RowParser/Util.pm index 09b8ec4f8..7192e1b8c 100644 --- a/lib/DBIx/Class/ResultSource/RowParser/Util.pm +++ b/lib/DBIx/Class/ResultSource/RowParser/Util.pm @@ -119,6 +119,8 @@ sub assemble_collapsing_parser { { "{ \$cur_row_ids{$_} }" } @{$args->{collapse_map}{-identifying_columns}} ); + + $top_node_key_assembler = ''; } elsif( my @variants = @{$args->{collapse_map}{-identifying_columns_variants}} ) { @@ -163,15 +165,19 @@ sub assemble_collapsing_parser { ( $args->{prune_null_branches} ? sprintf( '@{$cur_row_data}[( %s )]', join ', ', @row_ids ) : join (",\n", map { - my $quoted_null_val = qq("\0NULL\xFF\${rows_pos}\xFF${_}\0"); - HAS_DOR - ? qq!( \$cur_row_data->[$_] // $quoted_null_val )! - : qq!( defined(\$cur_row_data->[$_]) ? \$cur_row_data->[$_] : $quoted_null_val )! + $stats->{nullchecks}{mandatory}{$_} + ? qq!( \$cur_row_data->[$_] )! + : do { + my $quoted_null_val = qq("\0NULL\xFF\${rows_pos}\xFF${_}\0"); + HAS_DOR + ? qq!( \$cur_row_data->[$_] // $quoted_null_val )! + : qq!( defined(\$cur_row_data->[$_]) ? \$cur_row_data->[$_] : $quoted_null_val )! + } } @row_ids) ) ; - my $parser_src = sprintf (<<'EOS', $row_id_defs, $top_node_key_assembler||'', $top_node_key, join( "\n", @$data_assemblers ) ); + my $parser_src = sprintf (<<'EOS', $row_id_defs, $top_node_key_assembler, $top_node_key, join( "\n", @$data_assemblers ) ); ### BEGIN LITERAL STRING EVAL my $rows_pos = 0; my ($result_pos, @collapse_idx, $cur_row_data, %%cur_row_ids ); @@ -211,19 +217,19 @@ sub assemble_collapsing_parser { # won't play well when used as hash lookups # we also need to differentiate NULLs on per-row/per-col basis # (otherwise folding of optional 1:1s will be greatly confused -%1$s +%s # in the case of an underdefined root - calculate the virtual id (otherwise no code at all) -%2$s +%s # if we were supplied a coderef - we are collapsing lazily (the set # is ordered properly) # as long as we have a result already and the next result is new we # return the pre-read data and bail -( $_[1] and $result_pos and ! $collapse_idx[0]%3$s and (unshift @{$_[2]}, $cur_row_data) and last ), +( $_[1] and $result_pos and ! $collapse_idx[0]%s and (unshift @{$_[2]}, $cur_row_data) and last ), # the rel assemblers -%4$s +%s } @@ -241,6 +247,27 @@ sub __visit_infmap_collapse { my $cur_node_idx = ${ $args->{-node_idx_counter} ||= \do { my $x = 0} }++; + $args->{-mandatory_ids} ||= {}; + $args->{-seen_ids} ||= {}; + $args->{-all_or_nothing_sets} ||= []; + $args->{-null_from} ||= []; + + $args->{-seen_ids}{$_} = 1 + for @{$args->{collapse_map}->{-identifying_columns}}; + + my $node_specific_ids = { map { $_ => 1 } grep + { ! $args->{-parent_ids}{$_} } + @{$args->{collapse_map}->{-identifying_columns}} + }; + + if (not ( $args->{-chain_is_optional} ||= $args->{collapse_map}{-is_optional} ) ) { + $args->{-mandatory_ids}{$_} = 1 + for @{$args->{collapse_map}->{-identifying_columns}}; + } + elsif ( keys %$node_specific_ids > 1 ) { + push @{$args->{-all_or_nothing_sets}}, $node_specific_ids; + } + my ($my_cols, $rel_cols) = {}; for ( keys %{$args->{val_index}} ) { if ($_ =~ /^ ([^\.]+) \. (.+) /x) { @@ -305,17 +332,19 @@ sub __visit_infmap_collapse { } my $known_present_ids = { map { $_ => 1 } @{$args->{collapse_map}{-identifying_columns}} }; - my ($stats, $rel_src); + my $rel_src; for my $rel (sort keys %$rel_cols) { my $relinfo = $args->{collapse_map}{$rel}; - ($rel_src, $stats->{$rel}) = __visit_infmap_collapse({ %$args, + ($rel_src) = __visit_infmap_collapse({ %$args, val_index => $rel_cols->{$rel}, collapse_map => $relinfo, -parent_node_idx => $cur_node_idx, -parent_node_key => $node_key, + -parent_id_path => [ @{$args->{-parent_id_path}||[]}, sort { $a <=> $b } keys %$node_specific_ids ], + -parent_ids => { map { %$_ } $node_specific_ids, $args->{-parent_ids}||{} }, -node_rel_name => $rel, }); @@ -362,14 +391,58 @@ sub __visit_infmap_collapse { } } + if ( + + # calculation only valid for leaf nodes + ! values %$rel_cols + + and + + # child of underdefined path doesn't leave us anything to test + @{$args->{-parent_id_path} || []} + + and + + (my @nullable_portion = grep + { ! $args->{-mandatory_ids}{$_} } + ( + @{$args->{-parent_id_path}}, + sort { $a <=> $b } keys %$node_specific_ids + ) + ) > 1 + ) { + # there may be 1:1 overlap with a specific all_or_nothing + push @{$args->{-null_from}}, \@nullable_portion unless grep + { + my $a_o_n_set = $_; + + keys %$a_o_n_set == @nullable_portion + and + ! grep { ! $a_o_n_set->{$_} } @nullable_portion + } + @{ $args->{-all_or_nothing_sets} || [] } + ; + } + return ( \@src, - { - idcols_seen => { - ( map { %{ $_->{idcols_seen} } } values %$stats ), - ( map { $_ => 1 } @{$args->{collapse_map}->{-identifying_columns}} ), - } - } + ( $cur_node_idx != 0 ) ? () : { + idcols_seen => $args->{-seen_ids}, + nullchecks => { + ( keys %{$args->{-mandatory_ids} } + ? ( mandatory => $args->{-mandatory_ids} ) + : () + ), + ( @{$args->{-all_or_nothing_sets}} + ? ( all_or_nothing => $args->{-all_or_nothing_sets} ) + : () + ), + ( @{$args->{-null_from}} + ? ( from_first_encounter => $args->{-null_from} ) + : () + ), + }, + }, ); } diff --git a/t/prefetch/lazy_cursor.t b/t/prefetch/lazy_cursor.t index 3ed3c7c01..411248839 100644 --- a/t/prefetch/lazy_cursor.t +++ b/t/prefetch/lazy_cursor.t @@ -64,7 +64,7 @@ $rs->next; my @objs = $rs->all; is (@objs, $initial_artists_cnt + 3, '->all resets everything correctly'); is ( ($rs->cursor->next)[0], 1, 'Cursor auto-rewound after all()'); -is ($rs->{_stashed_rows}, undef, 'Nothing else left in $rs stash'); +ok (! @{ $rs->{_stashed_rows} || [] }, 'Nothing else left in $rs stash'); my $unordered_rs = $rs->search({}, { order_by => 'cds.title' }); diff --git a/t/resultset/rowparser_internals.t b/t/resultset/rowparser_internals.t index 50f3ebf73..d83a685f8 100644 --- a/t/resultset/rowparser_internals.t +++ b/t/resultset/rowparser_internals.t @@ -263,8 +263,8 @@ is_same_src ( ( $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0" ), ( $cur_row_data->[1] // "\0NULL\xFF$rows_pos\xFF1\0" ), ( $cur_row_data->[3] // "\0NULL\xFF$rows_pos\xFF3\0" ), - ( $cur_row_data->[4] // "\0NULL\xFF$rows_pos\xFF4\0" ), - ( $cur_row_data->[5] // "\0NULL\xFF$rows_pos\xFF5\0" ), + ( $cur_row_data->[4] ), + ( $cur_row_data->[5] ), ) ), # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2] @@ -466,7 +466,7 @@ is_same_src ( ( @cur_row_ids{0, 1, 5, 6, 8, 10} = ( $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0", - $cur_row_data->[1] // "\0NULL\xFF$rows_pos\xFF1\0", + $cur_row_data->[1], $cur_row_data->[5] // "\0NULL\xFF$rows_pos\xFF5\0", $cur_row_data->[6] // "\0NULL\xFF$rows_pos\xFF6\0", $cur_row_data->[8] // "\0NULL\xFF$rows_pos\xFF8\0", From b3a400a044a5e4a768e26d450e3cce289481ee7a Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 25 Mar 2016 14:28:42 +0100 Subject: [PATCH 043/262] Step up the error reporting on unexpected NULLs during collapse The collapser became so complex that it is practically impossible to debug when things go sideways. Expand the rudimentary "just check root identifier" to a comprehensive check of all identifier groups, at the expense of some performance. This builds on top of the {nullchecks} metadata collected in 5ff6d603, generating maximally unrolled definedness checks which cause an early return with no results and flagged unexpected-null-positions The commit itself is relatively straightforward, though the meager changeset in lib/ is misleading: the damned thing took almost 8 days to fully think through and implement with several detours for bugfixing :/ --- Changes | 3 + lib/DBIx/Class/ResultSet.pm | 63 +-- lib/DBIx/Class/ResultSource/RowParser.pm | 6 - lib/DBIx/Class/ResultSource/RowParser/Util.pm | 75 +++- t/resultset/misled_rowparser.t | 63 +++ t/resultset/rowparser_internals.t | 402 ++++++++++++++++++ 6 files changed, 559 insertions(+), 53 deletions(-) create mode 100644 t/resultset/misled_rowparser.t diff --git a/Changes b/Changes index 2714c0f45..9954895d0 100644 --- a/Changes +++ b/Changes @@ -11,6 +11,9 @@ Revision history for DBIx::Class an underlying search_rs(), as by design these arguments would be used only on the first call to ->related_resultset(), and ignored afterwards. Instead an exception (detailing the fix) is thrown. + - Increased checking for the correctness of the is_nullable attribute + within the prefetch result parser may highlight previously unknown + mismatches between your codebase and data source - Calling the set_* many-to-many helper with a list (instead of an arrayref) now emits a deprecation warning diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 456503162..cc5b39818 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -1425,7 +1425,7 @@ sub _construct_results { # $args and $attrs to _mk_row_parser are separated to delineate what is # core collapser stuff and what is dbic $rs specific - @{$self->{_row_parser}{$parser_type}}{qw(cref nullcheck)} = $rsrc->_mk_row_parser({ + $self->{_row_parser}{$parser_type}{cref} = $rsrc->_mk_row_parser({ eval => 1, inflate_map => $infmap, collapse => $attrs->{collapse}, @@ -1434,49 +1434,9 @@ sub _construct_results { prune_null_branches => $self->{_result_inflator}{is_hri} || $self->{_result_inflator}{is_core_row}, }, $attrs) unless $self->{_row_parser}{$parser_type}{cref}; - # column_info metadata historically hasn't been too reliable. - # We need to start fixing this somehow (the collapse resolver - # can't work without it). Add an explicit check for the *main* - # result, hopefully this will gradually weed out such errors - # - # FIXME - this is a temporary kludge that reduces performance - # It is however necessary for the time being - my ($unrolled_non_null_cols_to_check, $err); - - if (my $check_non_null_cols = $self->{_row_parser}{$parser_type}{nullcheck} ) { - - $err = - 'Collapse aborted due to invalid ResultSource metadata - the following ' - . 'selections are declared non-nullable but NULLs were retrieved: ' - ; - - my @violating_idx; - COL: for my $i (@$check_non_null_cols) { - ! defined $_->[$i] and push @violating_idx, $i and next COL for @$rows; - } - - $self->throw_exception( $err . join (', ', map { "'$infmap->[$_]'" } @violating_idx ) ) - if @violating_idx; - - $unrolled_non_null_cols_to_check = join (',', @$check_non_null_cols); - - utf8::upgrade($unrolled_non_null_cols_to_check) - if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE; - } - - my $next_cref = - ($did_fetch_all or ! $attrs->{collapse}) ? undef - : defined $unrolled_non_null_cols_to_check ? eval sprintf <<'EOS', $unrolled_non_null_cols_to_check -sub { - # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref - my @r = $cursor->next or return; - if (my @violating_idx = grep { ! defined $r[$_] } (%s) ) { - $self->throw_exception( $err . join (', ', map { "'$infmap->[$_]'" } @violating_idx ) ) - } - \@r -} -EOS - : sub { + my $next_cref = ($did_fetch_all or ! $attrs->{collapse}) + ? undef + : sub { # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref my @r = $cursor->next or return; \@r @@ -1487,8 +1447,23 @@ EOS $rows, $next_cref, ( $self->{_stashed_rows} = [] ), + ( my $null_violations = {} ), ); + $self->throw_exception( + 'Collapse aborted - the following columns are declared (or defaulted to) ' + . 'non-nullable within DBIC but NULLs were retrieved from storage: ' + . join( ', ', map { "'$infmap->[$_]'" } sort { $a <=> $b } keys %$null_violations ) + . ' within data row ' . dump_value({ + map { + $infmap->[$_] => + ( ! defined $self->{_stashed_rows}[0][$_] or length $self->{_stashed_rows}[0][$_] < 50 ) + ? $self->{_stashed_rows}[0][$_] + : substr( $self->{_stashed_rows}[0][$_], 0, 50 ) . '...' + } 0 .. $#{$self->{_stashed_rows}[0]} + }) + ) if keys %$null_violations; + # simple in-place substitution, does not regrow $rows if ($self->{_result_inflator}{is_core_row}) { $_ = $inflator_cref->($res_class, $rsrc, @$_) for @$rows diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index 93d7ef933..4683e1529 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -122,8 +122,6 @@ sub _mk_row_parser { }, ); - my $check_null_columns; - my $src = (! $args->{collapse} ) ? assemble_simple_parser(\%common) : do { my $collapse_map = $self->_resolve_collapse ({ # FIXME @@ -141,9 +139,6 @@ sub _mk_row_parser { premultiplied => $args->{premultiplied}, }); - $check_null_columns = $collapse_map->{-identifying_columns} - if @{$collapse_map->{-identifying_columns}}; - assemble_collapsing_parser({ %common, collapse_map => $collapse_map, @@ -155,7 +150,6 @@ sub _mk_row_parser { return ( $args->{eval} ? ( eval "sub $src" || die $@ ) : $src, - $check_null_columns, ); } diff --git a/lib/DBIx/Class/ResultSource/RowParser/Util.pm b/lib/DBIx/Class/ResultSource/RowParser/Util.pm index 7192e1b8c..0409c1ada 100644 --- a/lib/DBIx/Class/ResultSource/RowParser/Util.pm +++ b/lib/DBIx/Class/ResultSource/RowParser/Util.pm @@ -177,7 +177,65 @@ sub assemble_collapsing_parser { ) ; - my $parser_src = sprintf (<<'EOS', $row_id_defs, $top_node_key_assembler, $top_node_key, join( "\n", @$data_assemblers ) ); + my $null_checks = ''; + + for my $c ( sort { $a <=> $b } keys %{$stats->{nullchecks}{mandatory}} ) { + $null_checks .= sprintf <<'EOS', $c +( defined( $cur_row_data->[%1$s] ) or $_[3]->{%1$s} = 1 ), + +EOS + } + + for my $set ( @{ $stats->{nullchecks}{from_first_encounter} || [] } ) { + my @sub_checks; + + for my $i (0 .. $#$set - 1) { + + push @sub_checks, sprintf + '( not defined $cur_row_data->[%1$s] ) ? ( %2$s or ( $_[3]->{%1$s} = 1 ) )', + $set->[$i], + join( ' and ', map + { "( not defined \$cur_row_data->[$set->[$_]] )" } + ( $i+1 .. $#$set ) + ), + ; + } + + $null_checks .= "(\n @{[ join qq(\n: ), @sub_checks, '()' ]} \n),\n"; + } + + for my $set ( @{ $stats->{nullchecks}{all_or_nothing} || [] } ) { + + $null_checks .= sprintf "(\n( %s )\n or\n(\n%s\n)\n),\n", + join ( ' and ', map + { "( not defined \$cur_row_data->[$_] )" } + sort { $a <=> $b } keys %$set + ), + join ( ",\n", map + { "( defined(\$cur_row_data->[$_]) or \$_[3]->{$_} = 1 )" } + sort { $a <=> $b } keys %$set + ), + ; + } + + # If any of the above generators produced something, we need to add the + # final "if seen any violations - croak" part + # Do not throw from within the string eval itself as it does not have + # the necessary metadata to construct a nice exception text. As a bonus + # we get to entirely avoid https://github.com/Test-More/Test2/issues/16 + # and https://rt.perl.org/Public/Bug/Display.html?id=127774 + + $null_checks .= <<'EOS' if $null_checks; + +( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last +) ), +EOS + + + my $parser_src = sprintf (<<'EOS', $null_checks, $row_id_defs, $top_node_key_assembler, $top_node_key, join( "\n", @$data_assemblers ) ); ### BEGIN LITERAL STRING EVAL my $rows_pos = 0; my ($result_pos, @collapse_idx, $cur_row_data, %%cur_row_ids ); @@ -210,13 +268,24 @@ sub assemble_collapsing_parser { ( $_[1] and $_[1]->() ) ) ) { - # the undef checks may or may not be there - # depending on whether we prune or not + # column_info metadata historically hasn't been too reliable. + # We need to start fixing this somehow (the collapse resolver + # can't work without it). Add explicit checks for several cases + # of "unexpected NULL", based on the metadata returned by + # __visit_infmap_collapse # + # FIXME - this is a temporary kludge that reduces performance + # It is however necessary for the time being, until way into the + # future when the extra errors clear out all invalid metadata +%s + # due to left joins some of the ids may be NULL/undef, and # won't play well when used as hash lookups # we also need to differentiate NULLs on per-row/per-col basis # (otherwise folding of optional 1:1s will be greatly confused + # + # the undef checks may or may not be there depending on whether + # we prune or not %s # in the case of an underdefined root - calculate the virtual id (otherwise no code at all) diff --git a/t/resultset/misled_rowparser.t b/t/resultset/misled_rowparser.t new file mode 100644 index 000000000..2c76aeda1 --- /dev/null +++ b/t/resultset/misled_rowparser.t @@ -0,0 +1,63 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +use DBICTest; +my $schema = DBICTest->init_schema(); + +# The nullchecks metadata for this collapse resolution is: +# +# mandatory => { 0 => 1 } +# from_first_encounter => [ [ 1, 2, 3 ] ] +# all_or_nothing => [ { 1 => 1, 2 => 1 } ] +# +my $rs = $schema->resultset('Artist')->search({}, { + collapse => 1, + join => { cds => 'tracks' }, + columns => [qw( + me.artistid + cds.artist + cds.title + ), + { 'cds.tracks.title' => 'tracks.title' }, + ], +}); + +my @cases = ( + "'artistid'" + => [ undef, 0, 0, undef ], + + "'artistid', 'cds.title'" + => [ undef, 0, undef, undef ], + + "'artistid', 'cds.artist'" + => [ undef, undef, 0, undef ], + + "'cds.artist'" + => [ 0, undef, 0, 0 ], + + "'cds.title'" + => [ 0, 0, undef, 0 ], + + # petrhaps need to report cds.title here as well, but that'll complicate checks even more... + "'cds.artist'" + => [ 0, undef, undef, 0 ], +); + +while (@cases) { + my ($err, $cursor) = splice @cases, 0, 2; + + $rs->{_stashed_rows} = [ $cursor ]; + + throws_ok + { $rs->next } + qr/\Qthe following columns are declared (or defaulted to) non-nullable within DBIC but NULLs were retrieved from storage: $err within data row/, + "Correct exception on non-nullable-yet-NULL $err" + ; +} + +done_testing; diff --git a/t/resultset/rowparser_internals.t b/t/resultset/rowparser_internals.t index d83a685f8..2c593e751 100644 --- a/t/resultset/rowparser_internals.t +++ b/t/resultset/rowparser_internals.t @@ -259,6 +259,40 @@ is_same_src ( ( $_[1] and $_[1]->() ) ) ) { + + # NULL checks + # mandatory => { 4 => 1, 5 => 1 } + # from_first_encounter => [ [ 1, 3, 0 ] ] + # + ( defined( $cur_row_data->[4] ) or $_[3]->{4} = 1 ), + + ( defined( $cur_row_data->[5] ) or $_[3]->{5} = 1 ), + + ( + ( not defined $cur_row_data->[1] ) + ? ( + ( not defined $cur_row_data->[3] ) + and + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{1} = 1 ) + ) + : ( not defined $cur_row_data->[3] ) + ? ( + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{3} = 1 ) + ) + : () + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + ( @cur_row_ids{0,1,3,4,5} = ( ( $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0" ), ( $cur_row_data->[1] // "\0NULL\xFF$rows_pos\xFF1\0" ), @@ -333,6 +367,40 @@ is_same_src ( ( $_[1] and $_[1]->() ) ) ) { + + # NULL checks + # mandatory => { 4 => 1, 5 => 1 } + # from_first_encounter => [ [ 1, 3, 0 ] ] + # + ( defined( $cur_row_data->[4] ) or $_[3]->{4} = 1 ), + + ( defined( $cur_row_data->[5] ) or $_[3]->{5} = 1 ), + + ( + ( not defined $cur_row_data->[1] ) + ? ( + ( not defined $cur_row_data->[3] ) + and + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{1} = 1 ) + ) + : ( not defined $cur_row_data->[3] ) + ? ( + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{3} = 1 ) + ) + : () + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + ( @cur_row_ids{0, 1, 3, 4, 5} = @{$cur_row_data}[0, 1, 3, 4, 5] ), # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2] @@ -464,6 +532,48 @@ is_same_src ( ( $_[1] and $_[1]->() ) ) ) { + + # NULL checks + # mandatory => { 1 => 1 } + # from_first_encounter => [ [6, 8], [5, 10, 0] ], + # + ( defined( $cur_row_data->[1] ) or $_[3]->{1} = 1 ), + + ( + ( not defined $cur_row_data->[6] ) + ? ( + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{6} = 1 ) + ) + : () + ), + + ( + ( not defined $cur_row_data->[5] ) + ? ( + ( not defined $cur_row_data->[10] ) + and + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{5} = 1 ) + ) + : ( not defined $cur_row_data->[10] ) + ? ( + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{10} = 1 ) + ) + : () + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + ( @cur_row_ids{0, 1, 5, 6, 8, 10} = ( $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0", $cur_row_data->[1], @@ -549,6 +659,48 @@ is_same_src ( ( $_[1] and $_[1]->() ) ) ) { + + # NULL checks + # mandatory => { 1 => 1 } + # from_first_encounter => [ [6, 8], [5, 10, 0] ], + # + ( defined( $cur_row_data->[1] ) or $_[3]->{1} = 1 ), + + ( + ( not defined $cur_row_data->[6] ) + ? ( + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{6} = 1 ) + ) + : () + ), + + ( + ( not defined $cur_row_data->[5] ) + ? ( + ( not defined $cur_row_data->[10] ) + and + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{5} = 1 ) + ) + : ( not defined $cur_row_data->[10] ) + ? ( + ( not defined $cur_row_data->[0] ) + or + ( $_[3]->{10} = 1 ) + ) + : () + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + ( @cur_row_ids{( 0, 1, 5, 6, 8, 10 )} = @{$cur_row_data}[( 0, 1, 5, 6, 8, 10 )] ), # a present cref in $_[1] implies lazy prefetch, implies a supplied stash in $_[2] @@ -680,6 +832,49 @@ is_same_src ( ( $_[1] and $_[1]->() ) ) ) { + + # NULL checks + # + # from_first_encounter => [ [0, 4, 8] ] + # all_or_nothing => [ { 2 => 1, 3 => 1 } ] + ( + ( not defined $cur_row_data->[0] ) + ? ( + ( not defined $cur_row_data->[4] ) + and + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{0} = 1 ) + ) + : ( not defined $cur_row_data->[4] ) + ? ( + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{4} = 1 ) + ) + : () + ), + + ( + ( + ( not defined $cur_row_data->[2] ) + and + ( not defined $cur_row_data->[3] ) + ) + or + ( + ( defined($cur_row_data->[2]) or $_[3]->{2} = 1 ), + ( defined($cur_row_data->[3]) or $_[3]->{3} = 1 ), + ) + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + ( @cur_row_ids{( 0, 2, 3, 4, 8 )} = ( $cur_row_data->[0] // "\0NULL\xFF$rows_pos\xFF0\0", $cur_row_data->[2] // "\0NULL\xFF$rows_pos\xFF2\0", @@ -766,6 +961,49 @@ is_same_src ( ( $_[1] and $_[1]->() ) ) ) { + + # NULL checks + # + # from_first_encounter => [ [0, 4, 8] ] + # all_or_nothing => [ { 2 => 1, 3 => 1 } ] + ( + ( not defined $cur_row_data->[0] ) + ? ( + ( not defined $cur_row_data->[4] ) + and + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{0} = 1 ) + ) + : ( not defined $cur_row_data->[4] ) + ? ( + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{4} = 1 ) + ) + : () + ), + + ( + ( + ( not defined $cur_row_data->[2] ) + and + ( not defined $cur_row_data->[3] ) + ) + or + ( + ( defined($cur_row_data->[2]) or $_[3]->{2} = 1 ), + ( defined($cur_row_data->[3]) or $_[3]->{3} = 1 ), + ) + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + # do not care about nullability here ( @cur_row_ids{( 0, 2, 3, 4, 8 )} = @{$cur_row_data}[( 0, 2, 3, 4, 8 )] ), @@ -911,6 +1149,66 @@ is_same_src ( ( $_[1] and $_[1]->() ) ) ) { + # NULL checks + # + # from_first_encounter => [ [6, 4, 8], [6, 0, 9] ] + # all_or_nothing => [ { 2 => 1, 3 => 1 } ] + ( + ( not defined $cur_row_data->[6] ) + ? ( + ( not defined $cur_row_data->[4] ) + and + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{6} = 1 ) + ) + : ( not defined $cur_row_data->[4] ) + ? ( + ( not defined $cur_row_data->[8] ) + or + ( $_[3]->{4} = 1 ) + ) + : () + ), + + ( + ( not defined $cur_row_data->[6] ) + ? ( + ( not defined $cur_row_data->[0] ) + and + ( not defined $cur_row_data->[9] ) + or + ( $_[3]->{6} = 1 ) + ) + : ( not defined $cur_row_data->[0] ) + ? ( + ( not defined $cur_row_data->[9] ) + or + ( $_[3]->{0} = 1 ) + ) + : () + ), + + ( + ( + ( not defined $cur_row_data->[2] ) + and + ( not defined $cur_row_data->[3] ) + ) + or + ( + ( defined($cur_row_data->[2]) or $_[3]->{2} = 1 ), + ( defined($cur_row_data->[3]) or $_[3]->{3} = 1 ), + ) + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + # do not care about nullability here ( @cur_row_ids{( 0, 2, 3, 4, 6, 8, 9 )} = @{$cur_row_data}[( 0, 2, 3, 4, 6, 8, 9 )] ), @@ -1037,6 +1335,110 @@ is_same_src ( 'Non-premultiplied implicit collapse with missing join columns', ); +is_same_src ( + ($schema->source('Artist')->_mk_row_parser({ + inflate_map => [qw( artistid cds.artist cds.title cds.tracks.title )], + collapse => 1, + prune_null_branches => 1, + }))[0], + ' my $rows_pos = 0; + my ($result_pos, @collapse_idx, $cur_row_data, %cur_row_ids ); + + while ($cur_row_data = ( + ( + $rows_pos >= 0 + and + ( + $_[0][$rows_pos++] + or + ( ($rows_pos = -1), undef ) + ) + ) + or + ( $_[1] and $_[1]->() ) + ) ) { + + # NULL checks + # + # mandatory => { 0 => 1 } + # from_first_encounter => [ [1, 2, 3] ] + # all_or_nothing => [ { 1 => 1, 2 => 1 } ] + + ( defined( $cur_row_data->[0] ) or $_[3]->{0} = 1 ), + + ( + ( not defined $cur_row_data->[1] ) + ? ( + ( not defined $cur_row_data->[2] ) + and + ( not defined $cur_row_data->[3] ) + or + $_[3]->{1} = 1 + ) + : ( not defined $cur_row_data->[2] ) + ? ( + ( not defined $cur_row_data->[3] ) + or + $_[3]->{2} = 1 + ) + : () + ), + + ( + ( + ( not defined $cur_row_data->[1] ) + and + ( not defined $cur_row_data->[2] ) + ) + or + ( + ( defined($cur_row_data->[1]) or $_[3]->{1} = 1 ), + ( defined($cur_row_data->[2]) or $_[3]->{2} = 1 ), + ) + ), + + ( keys %{$_[3]} and ( + ( @{$_[2]} = $cur_row_data ), + ( $result_pos = 0 ), + last + ) ), + + + ( @cur_row_ids{( 0, 1, 2, 3 )} = @{$cur_row_data}[ 0, 1, 2, 3 ] ), + + ( $_[1] and $result_pos and ! $collapse_idx[0]{$cur_row_ids{0}} and (unshift @{$_[2]}, $cur_row_data) and last ), + + ( $collapse_idx[0]{ $cur_row_ids{0} } + //= $_[0][$result_pos++] = [ { "artistid" => $cur_row_data->[0] } ] + ), + + ( ( ! defined $cur_row_data->[1] ) ? $collapse_idx[0]{ $cur_row_ids{0} }[1]{"cds"} = [] : do { + + ( + ! $collapse_idx[1]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{2} } + and + push @{$collapse_idx[0]{ $cur_row_ids{0} }[1]{"cds"}}, + $collapse_idx[1]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{2} } + = [ { "artist" => $cur_row_data->[1], "title" => $cur_row_data->[2] } ] + ), + + ( ( ! defined $cur_row_data->[3] ) ? $collapse_idx[1]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{2} }[1]{"tracks"} = [] : do { + ( + ! $collapse_idx[2]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{2} }{ $cur_row_ids{3} } + and + push @{$collapse_idx[1]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{2} }[1]{"tracks"}}, + $collapse_idx[2]{ $cur_row_ids{0} }{ $cur_row_ids{1} }{ $cur_row_ids{2} }{ $cur_row_ids{3} } + = [ { "title" => $cur_row_data->[3] } ] + ), + } ), + } ), + } + + $#{$_[0]} = $result_pos - 1 + ', + 'A rolled out version of inflate map of misled_rowparser.t' +); + done_testing; my $deparser; From 5bcb167324052d051f5ab7313dac37815e53e02e Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 23 Mar 2016 14:05:10 +0100 Subject: [PATCH 044/262] Store collapser source in the resultset private metadata as well After 05a5ca4b the deparse of the row-parser coderef is incomprehensible at best. Add the source to the private cache structure to aid debugging if it ever becomes necessary (fingercross it won't be). Aside from the explicit evaluation package name, and the slight change of the return of _mk_row_parser there are no functional changes Read under -w --- lib/DBIx/Class/ResultSet.pm | 30 ++++++++++++------- lib/DBIx/Class/ResultSource/RowParser.pm | 4 +-- lib/DBIx/Class/ResultSource/RowParser/Util.pm | 2 +- t/resultset/rowparser_internals.t | 2 +- 4 files changed, 23 insertions(+), 15 deletions(-) diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index cc5b39818..0fc240c63 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -1423,17 +1423,27 @@ sub _construct_results { : 'classic_nonpruning' ; - # $args and $attrs to _mk_row_parser are separated to delineate what is - # core collapser stuff and what is dbic $rs specific - $self->{_row_parser}{$parser_type}{cref} = $rsrc->_mk_row_parser({ - eval => 1, - inflate_map => $infmap, - collapse => $attrs->{collapse}, - premultiplied => $attrs->{_main_source_premultiplied}, - hri_style => $self->{_result_inflator}{is_hri}, - prune_null_branches => $self->{_result_inflator}{is_hri} || $self->{_result_inflator}{is_core_row}, - }, $attrs) unless $self->{_row_parser}{$parser_type}{cref}; + unless( $self->{_row_parser}{$parser_type}{cref} ) { + + # $args and $attrs to _mk_row_parser are separated to delineate what is + # core collapser stuff and what is dbic $rs specific + $self->{_row_parser}{$parser_type}{src} = $rsrc->_mk_row_parser({ + inflate_map => $infmap, + collapse => $attrs->{collapse}, + premultiplied => $attrs->{_main_source_premultiplied}, + hri_style => $self->{_result_inflator}{is_hri}, + prune_null_branches => $self->{_result_inflator}{is_hri} || $self->{_result_inflator}{is_core_row}, + }, $attrs); + + $self->{_row_parser}{$parser_type}{cref} = do { + package # hide form PAUSE + DBIx::Class::__GENERATED_ROW_PARSER__; + + eval $self->{_row_parser}{$parser_type}{src}; + } || die $@; + } + # this needs to close over the *current* cursor, hence why it is not cached above my $next_cref = ($did_fetch_all or ! $attrs->{collapse}) ? undef : sub { diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index 4683e1529..12e309b11 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -148,9 +148,7 @@ sub _mk_row_parser { utf8::upgrade($src) if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE; - return ( - $args->{eval} ? ( eval "sub $src" || die $@ ) : $src, - ); + $src; } diff --git a/lib/DBIx/Class/ResultSource/RowParser/Util.pm b/lib/DBIx/Class/ResultSource/RowParser/Util.pm index 0409c1ada..68f7e6b3d 100644 --- a/lib/DBIx/Class/ResultSource/RowParser/Util.pm +++ b/lib/DBIx/Class/ResultSource/RowParser/Util.pm @@ -18,7 +18,7 @@ our @EXPORT_OK = qw( our $null_branch_class = 'DBIx::ResultParser::RelatedNullBranch'; sub __wrap_in_strictured_scope { - " { use strict; use warnings; use warnings FATAL => 'uninitialized';\n$_[0]\n }" + "sub { use strict; use warnings; use warnings FATAL => 'uninitialized';\n$_[0]\n }" } sub assemble_simple_parser { diff --git a/t/resultset/rowparser_internals.t b/t/resultset/rowparser_internals.t index 2c593e751..67215eb09 100644 --- a/t/resultset/rowparser_internals.t +++ b/t/resultset/rowparser_internals.t @@ -1457,7 +1457,7 @@ sub is_same_src { SKIP: { $expect =~ s/__NBC__/perlstring($DBIx::Class::ResultSource::RowParser::Util::null_branch_class)/ge; - $expect = " { use strict; use warnings FATAL => 'uninitialized';\n$expect\n }"; + $expect = "sub { use strict; use warnings FATAL => 'uninitialized';\n$expect\n }"; my @normalized = map { my $cref = eval "sub { $_ }" or do { From b4976ee31c2f188f9aa8f226a3155bf15a7da36b Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 30 Mar 2016 15:44:15 +0200 Subject: [PATCH 045/262] Fix *stupid* silencing of exceptions introduced in 4e9fc3f3 The reason this has not been detected is because it is virtually impossible for the stock inflate_result() to throw, and pretty rare for custom ones. ARGH! Found and individually vetted all remaining eval()s as in: grep -Pnr -B2 -A7 '^(?!\s*#).*?\beval\b' lib | less --- Changes | 1 + lib/DBIx/Class/ResultSet.pm | 2 +- t/resultset/inflate_result_api.t | 16 ++++++++++++++++ 3 files changed, 18 insertions(+), 1 deletion(-) diff --git a/Changes b/Changes index 9954895d0..07bb2065b 100644 --- a/Changes +++ b/Changes @@ -37,6 +37,7 @@ Revision history for DBIx::Class similar produces a large warning - Make sure exception objects stringifying to '' are properly handled and warned about (GH#15) + - Fix silencing of exceptions thrown by custom inflate_result() methods - Fix incorrect data returned in a corner case of partial-select HRI invocation (no known manifestations of this bug in the field, see commit message for description of exact failure scenario) diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 0fc240c63..71ff3ab3c 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -1413,7 +1413,7 @@ sub _construct_results { : '@$rows = map { $inflator_cref->($res_class, $rsrc, { %s } ) } @$rows' ), ( join (', ', map { "\$infmap->[$_] => \$_->[$_]" } 0..$#$infmap ) ) - ); + ) . '; 1' or die; } } else { diff --git a/t/resultset/inflate_result_api.t b/t/resultset/inflate_result_api.t index e09bad18e..d4a0f8e3d 100644 --- a/t/resultset/inflate_result_api.t +++ b/t/resultset/inflate_result_api.t @@ -6,6 +6,7 @@ no warnings 'exiting'; use Test::More; use Test::Deep; +use Test::Exception; use DBICTest; @@ -548,6 +549,7 @@ sub cmp_structures { cmp_deeply($left, $right, $msg||()) or next INFTYPE; } + { package DBICTest::_DoubleResult; @@ -575,4 +577,18 @@ is_deeply( })->all_hri}) x 2 ], ); + +{ + package DBICTest::_DieTrying; + + sub inflate_result { + die "nyah nyah nyah"; + } +} + +throws_ok { + $schema->resultset('CD')->search({}, { result_class => 'DBICTest::_DieTrying' })->all +} qr/nyah nyah nyah/, 'Exception in custom inflate_result propagated correctly'; + + done_testing; From 67cbc0a8171b13f8c90ec5c5184d598a3b63e007 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 30 Mar 2016 16:06:48 +0200 Subject: [PATCH 046/262] Fix incorrect exception propagation in ::Replicated::execute_reliably The code makes no sense in its current state, lapse left in after 1abccf54 --- Changes | 2 ++ lib/DBIx/Class/Storage/DBI/Replicated.pm | 12 +++--------- t/storage/replicated.t | 18 +++++++++++++++++- 3 files changed, 22 insertions(+), 10 deletions(-) diff --git a/Changes b/Changes index 07bb2065b..e6dc25ff0 100644 --- a/Changes +++ b/Changes @@ -43,6 +43,8 @@ Revision history for DBIx::Class commit message for description of exact failure scenario) - Fix corner case of stringify-only overloaded objects being used in create()/populate() + - Remove spurious exception warping in ::Replicated::execute_reliably + (RT#113339) - Fix spurious ROLLBACK statements when a TxnScopeGuard fails a commit of a transaction with deferred FK checks: a guard is now inactivated immediately before the commit is attempted (RT#107159) diff --git a/lib/DBIx/Class/Storage/DBI/Replicated.pm b/lib/DBIx/Class/Storage/DBI/Replicated.pm index 73998d2e7..512c53e0b 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated.pm @@ -693,19 +693,13 @@ sub execute_reliably { my $self = shift; my $coderef = shift; - unless( ref $coderef eq 'CODE') { - $self->throw_exception('Second argument must be a coderef'); - } + $self->throw_exception('Second argument must be a coderef') + unless( ref $coderef eq 'CODE'); ## replace the current read handler for the remainder of the scope local $self->{read_handler} = $self->master; - my $args = \@_; - return dbic_internal_try { - $coderef->(@$args); - } catch { - $self->throw_exception("coderef returned an error: $_"); - }; + &$coderef; } =head2 set_reliable_storage diff --git a/t/storage/replicated.t b/t/storage/replicated.t index 9ecc7e826..59bf7e575 100644 --- a/t/storage/replicated.t +++ b/t/storage/replicated.t @@ -709,9 +709,19 @@ ok my $reliably = sub { is $debug{storage_type}, 'MASTER', "got last query from a master: $debug{dsn}"; + $_[1] = 9; + } => 'created coderef properly'; -$replicated->schema->storage->execute_reliably($reliably); +my @list_to_mangle = (1, 2, 3); + +$replicated->schema->storage->execute_reliably($reliably, @list_to_mangle); + +is_deeply + \@list_to_mangle, + [ 1, 9, 3], + 'Aliasing of values passed to execute_reliably works' +; ## Try something with an error @@ -726,6 +736,12 @@ throws_ok {$replicated->schema->storage->execute_reliably($unreliably)} qr/Can't find source for ArtistXX/ => 'Bad coderef throws proper error'; +throws_ok { + $replicated->schema->storage->execute_reliably(sub{ + die bless [], 'SomeExceptionThing'; + }); +} 'SomeExceptionThing', "Blessed exception kept intact"; + ## Make sure replication came back ok $replicated->schema->resultset('Artist')->find(3) From 66c817df10d62ecc3d49df5839b1048e3454b2cf Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 30 Mar 2016 20:24:49 +0200 Subject: [PATCH 047/262] Really fix SQLite savepoints unlike the shortsighted 398215b1 --- Changes | 2 ++ lib/DBIx/Class/Storage/DBI/SQLite.pm | 25 ++++++++++--------------- t/752sqlite.t | 5 +++++ t/storage/savepoints.t | 18 ++++-------------- 4 files changed, 21 insertions(+), 29 deletions(-) diff --git a/Changes b/Changes index e6dc25ff0..accc48ce5 100644 --- a/Changes +++ b/Changes @@ -50,6 +50,8 @@ Revision history for DBIx::Class immediately before the commit is attempted (RT#107159) - Work around unreliable $sth->finish() on INSERT ... RETURNING within DBD::Firebird on some compiler/driver combinations (RT#110979) + - Really fix savepoint rollbacks on older DBD::SQLite (fix in 0.082800 + was not sufficient to cover up RT#67843) - Fix several corner cases with Many2Many over custom relationships - Fix the Sybase ASE storage incorrectly attempting to retrieve an autoinc value when inserting rows containing blobs (GH#82) diff --git a/lib/DBIx/Class/Storage/DBI/SQLite.pm b/lib/DBIx/Class/Storage/DBI/SQLite.pm index 28e9a087e..dcebce754 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLite.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLite.pm @@ -123,22 +123,17 @@ sub _exec_svp_rollback { my ($self, $name) = @_; $self->_dbh->do("ROLLBACK TO SAVEPOINT $name"); -} - -# older SQLite has issues here too - both of these are in fact -# completely benign warnings (or at least so say the tests) -sub _exec_txn_rollback { - local $SIG{__WARN__} = sigwarn_silencer( qr/rollback ineffective/ ) - unless $DBD::SQLite::__DBIC_TXN_SYNC_SANE__; - - shift->next::method(@_); -} - -sub _exec_txn_commit { - local $SIG{__WARN__} = sigwarn_silencer( qr/commit ineffective/ ) - unless $DBD::SQLite::__DBIC_TXN_SYNC_SANE__; - shift->next::method(@_); + # resync state for older DBD::SQLite (RT#67843) + # https://github.com/DBD-SQLite/DBD-SQLite/commit/9b3cdbf + if ( + ! modver_gt_or_eq('DBD::SQLite', '1.33') + and + $self->_dbh->FETCH('AutoCommit') + ) { + $self->_dbh->STORE('AutoCommit', 0); + $self->_dbh->STORE('BegunWork', 1); + } } sub _ping { diff --git a/t/752sqlite.t b/t/752sqlite.t index fe076d1c4..c0695546a 100644 --- a/t/752sqlite.t +++ b/t/752sqlite.t @@ -96,6 +96,11 @@ DDL } # test blank begin/svp/commit/begin cycle +# +# need to prime this for exotic testing scenarios +# before testing for lack of warnings +modver_gt_or_eq('DBD::SQLite', '1.33'); + warnings_are { my $schema = DBICTest->init_schema( no_populate => 1 ); my $rs = $schema->resultset('Artist'); diff --git a/t/storage/savepoints.t b/t/storage/savepoints.t index 66b7d71a4..b125d6e45 100644 --- a/t/storage/savepoints.t +++ b/t/storage/savepoints.t @@ -6,8 +6,7 @@ use warnings; use Test::More; use Test::Exception; use DBIx::Class::Optional::Dependencies; -use DBIx::Class::_Util qw(modver_gt_or_eq sigwarn_silencer scope_guard); - +use DBIx::Class::_Util qw(sigwarn_silencer scope_guard); use DBICTest; @@ -228,15 +227,6 @@ for ('', keys %$env2optdep) { SKIP: { is_deeply( $schema->storage->savepoints, [], 'All savepoints forgotten' ); -SKIP: { - skip "FIXME: Reading inexplicably fails on very old replicated DBD::SQLite<1.33", 1 if ( - $ENV{DBICTEST_VIA_REPLICATED} - and - $prefix eq 'SQLite Internal DB' - and - ! modver_gt_or_eq('DBD::SQLite', '1.33') - ); - ok($ars->search({ name => 'in_outer_transaction' })->first, 'commit from outer transaction'); ok($ars->search({ name => 'in_outer_transaction2' })->first, @@ -246,7 +236,9 @@ SKIP: { is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first, undef, 'rollback from inner transaction'; -} + + # make sure a fresh txn will work after above + $schema->storage->txn_do(sub { ok "noop" } ); ### cleanupz $schema->storage->dbh_do(sub { $_[1]->do("DROP TABLE artist") }); @@ -255,8 +247,6 @@ SKIP: { done_testing; END { - local $SIG{__WARN__} = sigwarn_silencer( qr/Internal transaction state of handle/ ) - unless modver_gt_or_eq('DBD::SQLite', '1.33'); eval { $schema->storage->dbh_do(sub { $_[1]->do("DROP TABLE artist") }) } if defined $schema; undef $schema; } From f5f0cb1ddc5bc6b022f08a2cd95201596a5246f0 Mon Sep 17 00:00:00 2001 From: Paul Mooney Date: Thu, 10 Mar 2016 10:50:57 +0000 Subject: [PATCH 048/262] Avoid infinite loop if save point does not exist --- AUTHORS | 1 + Changes | 1 + lib/DBIx/Class/Storage.pm | 11 +++++++---- t/storage/savepoints.t | 12 ++++++++++++ 4 files changed, 21 insertions(+), 4 deletions(-) diff --git a/AUTHORS b/AUTHORS index 264ee550c..5193ba86e 100644 --- a/AUTHORS +++ b/AUTHORS @@ -162,6 +162,7 @@ Peter Valdemar Mørch peter: Peter Collingbourne phaylon: Robert Sedlacek plu: Johannes Plunien +pmooney: Paul Mooney Possum: Daniel LeWarne pplu: Jose Luis Martinez quicksilver: Jules Bean diff --git a/Changes b/Changes index accc48ce5..7b2a01d07 100644 --- a/Changes +++ b/Changes @@ -45,6 +45,7 @@ Revision history for DBIx::Class create()/populate() - Remove spurious exception warping in ::Replicated::execute_reliably (RT#113339) + - Fix infinite loop on ->svp_release("nonexistent_savepoint") (GH#97) - Fix spurious ROLLBACK statements when a TxnScopeGuard fails a commit of a transaction with deferred FK checks: a guard is now inactivated immediately before the commit is attempted (RT#107159) diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm index 45839e105..f51284364 100644 --- a/lib/DBIx/Class/Storage.pm +++ b/lib/DBIx/Class/Storage.pm @@ -431,12 +431,15 @@ sub svp_release { if (defined $name) { my @stack = @{ $self->savepoints }; - my $svp; + my $svp = ''; - do { $svp = pop @stack } until $svp eq $name; + while( $svp ne $name ) { - $self->throw_exception ("Savepoint '$name' does not exist") - unless $svp; + $self->throw_exception ("Savepoint '$name' does not exist") + unless @stack; + + $svp = pop @stack; + } $self->savepoints(\@stack); # put back what's left } diff --git a/t/storage/savepoints.t b/t/storage/savepoints.t index b125d6e45..8960a5e5e 100644 --- a/t/storage/savepoints.t +++ b/t/storage/savepoints.t @@ -7,6 +7,7 @@ use Test::More; use Test::Exception; use DBIx::Class::Optional::Dependencies; use DBIx::Class::_Util qw(sigwarn_silencer scope_guard); +use Scalar::Util 'weaken'; use DBICTest; @@ -240,6 +241,17 @@ for ('', keys %$env2optdep) { SKIP: { # make sure a fresh txn will work after above $schema->storage->txn_do(sub { ok "noop" } ); +### Make sure non-existend savepoint release doesn't infloop itself + { + weaken( my $s = $schema ); + + throws_ok { + $s->storage->txn_do(sub { $s->svp_release('wibble') }) + } qr/Savepoint 'wibble' does not exist/, + "Calling svp_release on a non-existant savepoint throws expected error" + ; + } + ### cleanupz $schema->storage->dbh_do(sub { $_[1]->do("DROP TABLE artist") }); }} From 23b72652ee1dc2896630cd16a3ead96de1bc8772 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 1 Apr 2016 12:05:51 +0200 Subject: [PATCH 049/262] Silence spurious warnings from todoified test --- t/74mssql.t | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/t/74mssql.t b/t/74mssql.t index 5ade8a7ff..f24e1967c 100644 --- a/t/74mssql.t +++ b/t/74mssql.t @@ -7,6 +7,7 @@ use warnings; use Test::More; use Test::Exception; use Scalar::Util 'weaken'; +use DBIx::Class::_Util 'sigwarn_silencer'; use DBICTest; @@ -203,7 +204,7 @@ SQL $schema->storage->_get_dbh->disconnect; - lives_and { + lives_ok { $wrappers->{$wrapper}->( sub { $rs_cp->create({ amount => 900 + $_ }) for 1..3; }); @@ -229,11 +230,16 @@ SQL weaken(my $a_rs_cp = $artist_rs); - local $TODO = 'Transaction handling with multiple active statements will ' - .'need eager cursor support.' - unless $wrapper eq 'no_transaction'; + $wrapper ne 'no_transaction' + and + ( + local $TODO = 'Transaction handling with multiple active statements will ' + .'need eager cursor support.', + + local local $SIG{__WARN__} = sigwarn_silencer qr/disconnect invalidates .+? active statement/ + ); - lives_and { + lives_ok { my @results; $wrappers->{$wrapper}->( sub { From d3a2e424976a449718ad750b72d4bf3acf689caf Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 1 Apr 2016 12:19:51 +0200 Subject: [PATCH 050/262] Fix annoying warnings on innocent looking MSSQL code After several rounds of improvements in the retry logic (84efb6d7, 729656c5) MSSQL code non-fatally aborting due to clashing multiple active resultsets would emit an annoying warning. Such warnings are especially baffling when encountered in innocent-looking code like: my $first_bar_of_first_foo = $schema->resultset('Foo') ->search({ foo => 'fa' }) ->next ->related_resultset("bar") ->next; Since no object destruction takes place until the = operator is executed, the cursor returning "first foo matching fa" is still active when we run a second search for the "bars". With default MSSQL settings (i.e. without an enabled MARS[1] implementation) this leads to an exception on the second ->next(). The failed next() is properly retried, since we are not in transaction or some similar complicating factor, and the entire thing executes correctly, except the force-disconnect-before-reconnect-after-failed-ping warns about the first cursor being still alive. Add extra stack marker for this particular case, and teach the MSSQL driver to hide the (at this stage spurious) warning [1] http://p3rl.org/DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server#MULTIPLE-ACTIVE-STATEMENTS --- Changes | 1 + lib/DBIx/Class/Storage/BlockRunner.pm | 7 +++++- lib/DBIx/Class/Storage/DBI/MSSQL.pm | 35 +++++++++++++++++++++------ t/746mssql.t | 33 ++++++++++++++++++++++--- 4 files changed, 63 insertions(+), 13 deletions(-) diff --git a/Changes b/Changes index 7b2a01d07..5aa2ea57a 100644 --- a/Changes +++ b/Changes @@ -49,6 +49,7 @@ Revision history for DBIx::Class - Fix spurious ROLLBACK statements when a TxnScopeGuard fails a commit of a transaction with deferred FK checks: a guard is now inactivated immediately before the commit is attempted (RT#107159) + - Fix spurious warning on MSSQL cursor invalidation retries (RT#102166) - Work around unreliable $sth->finish() on INSERT ... RETURNING within DBD::Firebird on some compiler/driver combinations (RT#110979) - Really fix savepoint rollbacks on older DBD::SQLite (fix in 0.082800 diff --git a/lib/DBIx/Class/Storage/BlockRunner.pm b/lib/DBIx/Class/Storage/BlockRunner.pm index 0f884daac..9b5bdbc6b 100644 --- a/lib/DBIx/Class/Storage/BlockRunner.pm +++ b/lib/DBIx/Class/Storage/BlockRunner.pm @@ -187,7 +187,12 @@ sub _run { # FIXME - we assume that $storage->{_dbh_autocommit} is there if # txn_init_depth is there, but this is a DBI-ism $txn_init_depth > ( $storage->{_dbh_autocommit} ? 0 : 1 ) - ) or ! $self->retry_handler->($self) + ) + or + ! do { + local $self->storage->{_in_do_block_retry_handler} = 1; + $self->retry_handler->($self) + } ); # we got that far - let's retry diff --git a/lib/DBIx/Class/Storage/DBI/MSSQL.pm b/lib/DBIx/Class/Storage/DBI/MSSQL.pm index 4eb090a71..aed3689a4 100644 --- a/lib/DBIx/Class/Storage/DBI/MSSQL.pm +++ b/lib/DBIx/Class/Storage/DBI/MSSQL.pm @@ -9,7 +9,8 @@ use base qw/ /; use mro 'c3'; -use DBIx::Class::_Util 'dbic_internal_try'; +use Try::Tiny; +use DBIx::Class::_Util qw( dbic_internal_try sigwarn_silencer ); use List::Util 'first'; use namespace::clean; @@ -175,16 +176,34 @@ sub _ping { my $dbh = $self->_dbh or return 0; - local $dbh->{RaiseError} = 1; - local $dbh->{PrintError} = 0; + dbic_internal_try { + local $dbh->{RaiseError} = 1; + local $dbh->{PrintError} = 0; - (dbic_internal_try { $dbh->do('select 1'); 1; - }) - ? 1 - : 0 - ; + } + catch { + # MSSQL is *really* annoying wrt multiple active resultsets, + # and this may very well be the reason why the _ping failed + # + # Proactively disconnect, while hiding annoying warnings if the case + # + # The callchain is: + # < check basic retryability prerequisites (e.g. no txn) > + # ->retry_handler + # ->storage->connected() + # ->ping + # So if we got here with the in_handler bit set - we won't break + # anything by a disconnect + if( $self->{_in_do_block_retry_handler} ) { + local $SIG{__WARN__} = sigwarn_silencer qr/disconnect invalidates .+? active statement/; + $self->disconnect; + } + + # RV of _ping itself + 0; + }; } package # hide from PAUSE diff --git a/t/746mssql.t b/t/746mssql.t index c7753c7d7..d1b8773f0 100644 --- a/t/746mssql.t +++ b/t/746mssql.t @@ -6,6 +6,7 @@ use warnings; use Test::More; use Test::Exception; +use Test::Warn; use Try::Tiny; @@ -98,11 +99,35 @@ SQL ok(($new->artistid||0) > 0, "Auto-PK worked for $opts_name"); -# Test multiple active statements - SKIP: { - skip 'not a multiple active statements configuration', 1 - if $opts_name eq 'plain'; +# Test graceful error handling if not supporting multiple active statements + if( $opts_name eq 'plain' ) { + + # keep the first cursor alive (as long as $rs is alive) + my $rs = $schema->resultset("Artist"); + + my $a1 = $rs->next; + + my $a2; + + warnings_are { + # second cursor, invalidates $rs, but it doesn't + # matter as long as we do not try to use it + $a2 = $schema->resultset("Artist")->next; + } [], 'No warning on retry due to previous cursor invalidation'; + is_deeply( + { $a1->get_columns }, + { $a2->get_columns }, + 'Same data', + ); + + dies_ok { + $rs->next; + } 'Invalid cursor did not silently return garbage'; + } + +# Test multiple active statements + else { $schema->storage->ensure_connected; lives_ok { From e43288721573f6b73a16e1340d8a533e04642d6f Mon Sep 17 00:00:00 2001 From: Fabrice Gabolde Date: Fri, 1 Apr 2016 15:05:42 +0200 Subject: [PATCH 051/262] Fix parsing DSN when the driver part includes DBI attributes --- AUTHORS | 1 + Changes | 1 + lib/DBIx/Class/Storage/DBI.pm | 11 ++++++++++- t/lib/DBICTest/BaseSchema.pm | 2 +- t/storage/dbi_env.t | 4 ++++ 5 files changed, 17 insertions(+), 2 deletions(-) diff --git a/AUTHORS b/AUTHORS index 5193ba86e..f4f97f1b3 100644 --- a/AUTHORS +++ b/AUTHORS @@ -74,6 +74,7 @@ ether: Karen Etheridge evdb: Edmund von der Burg faxm0dem: Fabien Wernli felliott: Fitz Elliott +fgabolde: Fabrice Gabolde freetime: Bill Moseley frew: Arthur Axel "fREW" Schmidt gbjk: Gareth Kirwan diff --git a/Changes b/Changes index 5aa2ea57a..8ce62d61e 100644 --- a/Changes +++ b/Changes @@ -50,6 +50,7 @@ Revision history for DBIx::Class of a transaction with deferred FK checks: a guard is now inactivated immediately before the commit is attempted (RT#107159) - Fix spurious warning on MSSQL cursor invalidation retries (RT#102166) + - Fix parsing of DSNs containing driver arguments (GH#99) - Work around unreliable $sth->finish() on INSERT ... RETURNING within DBD::Firebird on some compiler/driver combinations (RT#110979) - Really fix savepoint rollbacks on older DBD::SQLite (fix in 0.082800 diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 01c8dccba..adcd6b493 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -1377,7 +1377,16 @@ sub _extract_driver_from_connect_info { # try to use dsn to not require being connected, the driver may still # force a connection later in _rebless to determine version # (dsn may not be supplied at all if all we do is make a mock-schema) - ($drv) = ($self->_dbi_connect_info->[0] || '') =~ /^dbi:([^:]+):/i; + # + # Use the same regex as the one used by DBI itself (even if the use of + # \w is odd given unicode): + # https://metacpan.org/source/TIMB/DBI-1.634/DBI.pm#L621 + # + # DO NOT use https://metacpan.org/source/TIMB/DBI-1.634/DBI.pm#L559-566 + # as there is a long-standing precedent of not loading DBI.pm until the + # very moment we are actually connecting + # + ($drv) = ($self->_dbi_connect_info->[0] || '') =~ /^dbi:(\w*)/i; $drv ||= $ENV{DBI_DRIVER}; } diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index 111b84b16..2663530db 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -224,7 +224,7 @@ sub connection { and ref($_[0]) ne 'CODE' and - ($_[0]||'') !~ /^ (?i:dbi) \: SQLite \: (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x + ($_[0]||'') !~ /^ (?i:dbi) \: SQLite (?: \: | \W ) .*? (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x ) { my $locktype; diff --git a/t/storage/dbi_env.t b/t/storage/dbi_env.t index 4e71ce59f..7b9ccc832 100644 --- a/t/storage/dbi_env.t +++ b/t/storage/dbi_env.t @@ -79,6 +79,10 @@ $schema = DBICTest::Schema->connect("dbi:SQLite:$dbname"); lives_ok { count_sheep($schema) } 'SQLite passed to connect_info'; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite'; +$schema = DBICTest::Schema->connect("dbi:SQLite(ReadOnly=1):$dbname"); +lives_ok { count_sheep($schema) } 'SQLite passed to connect_info despite extra arguments present'; +isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite'; + $ENV{DBI_DRIVER} = 'SQLite'; $schema = DBICTest::Schema->connect("dbi::$dbname"); lives_ok { count_sheep($schema) } 'SQLite in DBI_DRIVER'; From bf726d9cd6f7e53d6b3eb540d899e494f245fb5a Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 2 Apr 2016 15:21:37 +0200 Subject: [PATCH 052/262] Test with explicitly readonly 'replicants' under DBICTEST_VIA_REPLICATED --- t/lib/DBICTest.pm | 17 ++++++++++++++--- t/lib/DBICTest/BaseSchema.pm | 7 ++++++- 2 files changed, 20 insertions(+), 4 deletions(-) diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index d09a9dc32..e4768a07b 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -32,7 +32,7 @@ use DBICTest::Util qw( ); use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; use DBICTest::Schema; -use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard ); +use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard modver_gt_or_eq ); use Carp; use Fcntl qw/:DEFAULT :flock/; use Config; @@ -374,8 +374,19 @@ sub init_schema { if ( !$args{no_connect} ) { $schema->connection(@dsn); - $schema->storage->connect_replicants(\@dsn) - if $ENV{DBICTEST_VIA_REPLICATED}; + if( $ENV{DBICTEST_VIA_REPLICATED} ) { + + # add explicit ReadOnly=1 if we can support it + $dsn[0] =~ /^dbi:SQLite:/i + and + require DBD::SQLite + and + modver_gt_or_eq('DBD::SQLite', '1.49_05') + and + $dsn[0] =~ s/^dbi:SQLite:/dbi:SQLite(ReadOnly=1):/i; + + $schema->storage->connect_replicants(\@dsn); + } } if ( !$args{no_deploy} ) { diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index 2663530db..4fa2f208a 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -242,7 +242,12 @@ sub connection { # this will either give us an undef $locktype or will determine things # properly with a default ( possibly connecting in the process ) eval { - my $s = ref($self)->connect(@{$self->storage->connect_info})->storage; + my $cur_storage = $self->storage; + + $cur_storage = $cur_storage->master + if $cur_storage->isa('DBIx::Class::Storage::DBI::Replicated'); + + my $s = ref($self)->connect(@{$cur_storage->connect_info})->storage; $locktype = $s->sqlt_type || 'generic'; From b482a0958732d987d8f742c7bdd61816a898f083 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 2 Apr 2016 17:41:52 +0200 Subject: [PATCH 053/262] Fix another ::FilterColumn bug sigh... This one is technically a regression introduced by dc6dadae, which aimed to solve multiple runs on already-dirty columns. Unfortunately this very same change broke update(). Overload get_dirty_columns to fix that, and add a bunch of tests validating nothing crazy is going on. I should have seen all of these problems when FC was initially considered, but alas I was too damn inexperienced :/ --- Changes | 2 + lib/DBIx/Class/FilterColumn.pm | 28 ++++++++++--- t/row/filter_column.t | 75 ++++++++++++++++++++++++++++++++++ xt/dist/pod_coverage.t | 1 + 4 files changed, 101 insertions(+), 5 deletions(-) diff --git a/Changes b/Changes index 8ce62d61e..2fc18e9e9 100644 --- a/Changes +++ b/Changes @@ -11,6 +11,8 @@ Revision history for DBIx::Class an underlying search_rs(), as by design these arguments would be used only on the first call to ->related_resultset(), and ignored afterwards. Instead an exception (detailing the fix) is thrown. + - Another relatively invasive set of ::FilterColumn changes, covering + potential data loss (RT#111567). Please run your regression tests! - Increased checking for the correctness of the is_nullable attribute within the prefetch result parser may highlight previously unknown mismatches between your codebase and data source diff --git a/lib/DBIx/Class/FilterColumn.pm b/lib/DBIx/Class/FilterColumn.pm index fedbf79c5..b7860c95a 100644 --- a/lib/DBIx/Class/FilterColumn.pm +++ b/lib/DBIx/Class/FilterColumn.pm @@ -78,11 +78,13 @@ sub get_filtered_column { sub get_column { my ($self, $col) = @_; - if (exists $self->{_filtered_column}{$col}) { - return $self->{_column_data}{$col} ||= $self->_column_to_storage ( - $col, $self->{_filtered_column}{$col} - ); - } + ! exists $self->{_column_data}{$col} + and + exists $self->{_filtered_column}{$col} + and + $self->{_column_data}{$col} = $self->_column_to_storage ( + $col, $self->{_filtered_column}{$col} + ); return $self->next::method ($col); } @@ -101,6 +103,22 @@ sub get_columns { $self->next::method (@_); } +# and *another* separate codepath, argh! +sub get_dirty_columns { + my $self = shift; + + $self->{_dirty_columns}{$_} + and + ! exists $self->{_column_data}{$_} + and + $self->{_column_data}{$_} = $self->_column_to_storage ( + $_, $self->{_filtered_column}{$_} + ) + for keys %{$self->{_filtered_column}||{}}; + + $self->next::method(@_); +} + sub store_column { my ($self, $col) = (shift, @_); diff --git a/t/row/filter_column.t b/t/row/filter_column.t index af7a951f2..cf7e24582 100644 --- a/t/row/filter_column.t +++ b/t/row/filter_column.t @@ -132,6 +132,72 @@ CACHE_TEST: { is $from_storage_ran, ++$expected_from, 'from did run'; is $to_storage_ran, $expected_to, 'to did not run'; + ok ! $artist->is_changed, 'object clean'; + is_deeply + { $artist->get_dirty_columns }, + {}, + 'dirty columns as expected', + ; + + is $from_storage_ran, $expected_from, 'from did not run'; + is $to_storage_ran, $expected_to, 'to did not run'; + + $artist->charfield(42); + + is $from_storage_ran, $expected_from, 'from did not run'; + is $to_storage_ran, ++$expected_to, 'to ran once, determining dirtyness'; + + is $artist->charfield, 42, 'setting once works'; + ok $artist->is_column_changed('charfield'), 'column changed'; + ok $artist->is_changed, 'object changed'; + is_deeply + { $artist->get_dirty_columns }, + { charfield => 21 }, + 'dirty columns as expected', + ; + + is $from_storage_ran, $expected_from, 'from did not run'; + is $to_storage_ran, $expected_to, 'to did not run'; + + $artist->charfield(66); + is $artist->charfield, 66, 'setting twice works'; + ok $artist->is_column_changed('charfield'), 'column changed'; + ok $artist->is_changed, 'object changed'; + + is $from_storage_ran, $expected_from, 'from did not run'; + is $to_storage_ran, $expected_to, 'to did not run a second time on dirty column'; + + is_deeply + { $artist->get_dirty_columns }, + { charfield => 33 }, + 'dirty columns as expected', + ; + is $from_storage_ran, $expected_from, 'from did not run'; + is $to_storage_ran, ++$expected_to, 'to did run producing a new dirty_columns set'; + + is_deeply + { $artist->get_dirty_columns }, + { charfield => 33 }, + 'dirty columns still as expected', + ; + is $from_storage_ran, $expected_from, 'from did not run'; + is $to_storage_ran, $expected_to, 'to did not run on re-invoked get_dirty_columns'; + + $artist->update; + is $artist->charfield, 66, 'value still there'; + + is $from_storage_ran, $expected_from, 'from did not run'; + is $to_storage_ran, $expected_to, 'to did not run '; + + $artist->discard_changes; + + is $from_storage_ran, $expected_from, 'from did not run after discard_changes'; + is $to_storage_ran, $expected_to, 'to did not run after discard_changes'; + + is $artist->charfield, 66, 'value still there post reload'; + + is $from_storage_ran, ++$expected_from, 'from did run'; + is $to_storage_ran, $expected_to, 'to did not run'; } # test in-memory operations @@ -139,6 +205,7 @@ for my $artist_maker ( sub { $schema->resultset('Artist')->new({ charfield => 42 }) }, sub { my $art = $schema->resultset('Artist')->new({}); $art->charfield(42); $art }, ) { + $schema->resultset('Artist')->delete; my $expected_from = $from_storage_ran; my $expected_to = $to_storage_ran; @@ -152,6 +219,14 @@ for my $artist_maker ( ok( $artist->has_column_loaded('charfield'), 'Filtered column marked as loaded under new' ); is( $artist->charfield, 42, 'Proper unfiltered value' ); is( $artist->get_column('charfield'), 21, 'Proper filtered value' ); + + $artist->insert; + ($raw_db_charfield) = $schema->resultset('Artist') + ->search ($artist->ident_condition) + ->get_column('charfield') + ->next; + + is $raw_db_charfield, 21, 'Proper value in database'; } # test literals diff --git a/xt/dist/pod_coverage.t b/xt/dist/pod_coverage.t index a3acbe407..97d497510 100644 --- a/xt/dist/pod_coverage.t +++ b/xt/dist/pod_coverage.t @@ -58,6 +58,7 @@ my $exceptions = { store_column get_column get_columns + get_dirty_columns has_column_loaded /], }, From e5b2f13cc43816b197496ff715acd0cc52ce83f3 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 11 Apr 2016 17:19:34 +0200 Subject: [PATCH 054/262] (travis) Enhance the 'broken compiler' test --- .travis.yml | 2 +- maint/travis-ci_scripts/30_before_script.bash | 9 +++++++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 6c63f9002..43948b168 100644 --- a/.travis.yml +++ b/.travis.yml @@ -31,7 +31,7 @@ notifications: email: recipients: - - ribasushi@cpan.org + - CPAN-CI@leporine.io on_success: change on_failure: always diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 24515a83d..9f1ebd0ba 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -36,15 +36,20 @@ if [[ "$POISON_ENV" = "true" ]] ; then # also try minimal tested installs *without* a compiler if [[ "$CLEANTEST" = "true" ]]; then - # Clone and P::S::XS are both bugs + # FIXME - working around RT#74707, https://metacpan.org/source/DOY/Package-Stash-0.37/Makefile.PL#L112-122 # List::Util can be excised after that as well (need to make my own max() routine for older perls) - installdeps Sub::Name Clone Package::Stash::XS \ $( perl -MList::Util\ 1.16 -e1 &>/dev/null || echo "List::Util" ) mkdir -p "$HOME/bin" # this is already in $PATH, just doesn't exist run_or_err "Linking ~/bin/cc to /bin/false - thus essentially BREAKING the C compiler" \ "ln -s /bin/false $HOME/bin/cc" + + # FIXME: working around RT#113682, RT#113685 + installdeps Module::Build B::Hooks::EndOfScope + + run_or_err "Linking ~/bin/cc to /bin/true - BREAKING the C compiler even harder" \ + "ln -fs /bin/true $HOME/bin/cc" fi fi From 179566f35d9aa5ad85a7516ae37e268217b88ede Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 11 Apr 2016 20:24:21 +0200 Subject: [PATCH 055/262] (travis) Reorganize POISON_ENV mode Allow MVDT and BREAK_CC to be separate settings, will make sense in further commits. This adds extra testing of DEVREL_DEPS with no compiler, which brings another round of exceptions etc... sigh Read under -w --- maint/travis-ci_scripts/20_install.bash | 11 ++++ maint/travis-ci_scripts/30_before_script.bash | 53 ++++++++++++------- maint/travis-ci_scripts/50_after_success.bash | 3 ++ 3 files changed, 47 insertions(+), 20 deletions(-) diff --git a/maint/travis-ci_scripts/20_install.bash b/maint/travis-ci_scripts/20_install.bash index 515b17651..490ceb763 100755 --- a/maint/travis-ci_scripts/20_install.bash +++ b/maint/travis-ci_scripts/20_install.bash @@ -86,6 +86,17 @@ fi # poison the environment if [[ "$POISON_ENV" = "true" ]] ; then + toggle_vars=( MVDT ) + + [[ "$CLEANTEST" == "true" ]] && toggle_vars+=( BREAK_CC ) + + for var in "${toggle_vars[@]}" ; do + if [[ -z "${!var}" ]] ; then + export $var=true + echo "POISON_ENV: setting $var to 'true'" + fi + done + # look through lib, find all mentioned DBIC* ENVvars and set them to true and see if anything explodes toggle_booleans=( $( grep -ohP '\bDBIC_[0-9_A-Z]+' -r lib/ --exclude-dir Optional | sort -u | grep -vP '^(DBIC_TRACE(_PROFILE)?|DBIC_.+_DEBUG)$' ) ) diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 9f1ebd0ba..79a360d27 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -5,16 +5,16 @@ source maint/travis-ci_scripts/common.bash if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then exit 0 ; fi -# The prereq-install stage will not work with both POISON and DEVREL +# The DEVREL_DEPS prereq-install stage won't mix with MVDT # DEVREL wins -if [[ "$DEVREL_DEPS" = "true" ]] ; then - export POISON_ENV="" +if [[ "$DEVREL_DEPS" == "true" ]] ; then + export MVDT="" fi # FIXME - this is a kludge in place of proper MDV testing. For the time # being simply use the minimum versions of our DBI/DBDstack, to avoid # fuckups like 0.08260 (went unnoticed for 5 months) -if [[ "$POISON_ENV" = "true" ]] ; then +if [[ "$MVDT" == "true" ]] ; then # use url-spec for DBI due to https://github.com/miyagawa/cpanminus/issues/328 if [[ "$CLEANTEST" != "true" ]] || perl -M5.013003 -e1 &>/dev/null ; then @@ -32,25 +32,38 @@ if [[ "$POISON_ENV" = "true" ]] ; then else parallel_installdeps_notest DBD::SQLite@1.29 fi +fi - # also try minimal tested installs *without* a compiler - if [[ "$CLEANTEST" = "true" ]]; then +# +# try minimal fully tested installs *without* a compiler (with some exceptions of course) +if [[ "$BREAK_CC" == "true" ]] ; then - # FIXME - working around RT#74707, https://metacpan.org/source/DOY/Package-Stash-0.37/Makefile.PL#L112-122 - # List::Util can be excised after that as well (need to make my own max() routine for older perls) - installdeps Sub::Name Clone Package::Stash::XS \ - $( perl -MList::Util\ 1.16 -e1 &>/dev/null || echo "List::Util" ) + [[ "$CLEANTEST" != "true" ]] && echo_err "Breaking the compiler without CLEANTEST makes no sense" && exit 1 - mkdir -p "$HOME/bin" # this is already in $PATH, just doesn't exist - run_or_err "Linking ~/bin/cc to /bin/false - thus essentially BREAKING the C compiler" \ - "ln -s /bin/false $HOME/bin/cc" + # FIXME - working around RT#74707, https://metacpan.org/source/DOY/Package-Stash-0.37/Makefile.PL#L112-122 + # List::Util can be excised after that as well (need to make my own max() routine for older perls) + # + # DEVREL_DEPS means our installer is cpanm, which will respect failures + # and the like, so stuff soft-failing (failed deps that are not in fact + # needed) will not fly. Add *EVEN MORE* stuff that needs a compiler + # + # FIXME - the PathTools 3.47 is to work around https://rt.cpan.org/Ticket/Display.html?id=107392 + # + installdeps Sub::Name Clone Package::Stash::XS \ + $( perl -MList::Util\ 1.16 -e1 &>/dev/null || echo "List::Util" ) \ + $( [[ "$DEVREL_DEPS" == "true" ]] && ( perl -MFile::Spec\ 3.13 -e1 &>/dev/null || echo "S/SM/SMUELLER/PathTools-3.47.tar.gz" ) ) \ + $( perl -MDBI -e1 &>/dev/null || echo "DBI" ) \ + $( perl -MDBD::SQLite -e1 &>/dev/null || echo "DBD::SQLite" ) - # FIXME: working around RT#113682, RT#113685 - installdeps Module::Build B::Hooks::EndOfScope + mkdir -p "$HOME/bin" # this is already in $PATH, just doesn't exist + run_or_err "Linking ~/bin/cc to /bin/false - thus essentially BREAKING the C compiler" \ + "ln -s /bin/false $HOME/bin/cc" - run_or_err "Linking ~/bin/cc to /bin/true - BREAKING the C compiler even harder" \ - "ln -fs /bin/true $HOME/bin/cc" - fi + # FIXME: working around RT#113682, RT#113685, and some other unfiled bugs + installdeps Module::Build B::Hooks::EndOfScope Devel::GlobalDestruction Class::Accessor::Grouped + + run_or_err "Linking ~/bin/cc to /bin/true - BREAKING the C compiler even harder" \ + "ln -fs /bin/true $HOME/bin/cc" fi if [[ "$CLEANTEST" = "true" ]]; then @@ -169,8 +182,8 @@ if [[ -n "$(make listdeps)" ]] ; then exit 1 fi -# check that our MDV somewhat works -if [[ "$POISON_ENV" = "true" ]] && ( perl -MDBD::SQLite\ 1.38 -e1 || perl -MDBI\ 1.615 -e1 ) &>/dev/null ; then +# check that our MVDT somewhat works +if [[ "$MVDT" == "true" ]] && ( perl -MDBD::SQLite\ 1.38 -e1 || perl -MDBI\ 1.615 -e1 ) &>/dev/null ; then echo_err "Something went wrong - higher versions of DBI and/or DBD::SQLite than we expected" exit 1 fi diff --git a/maint/travis-ci_scripts/50_after_success.bash b/maint/travis-ci_scripts/50_after_success.bash index 16c90d541..8b44371cb 100755 --- a/maint/travis-ci_scripts/50_after_success.bash +++ b/maint/travis-ci_scripts/50_after_success.bash @@ -11,6 +11,9 @@ export HARNESS_OPTIONS="j$VCPU_USE" if [[ "$DEVREL_DEPS" == "true" ]] && perl -M5.008003 -e1 &>/dev/null ; then + + [[ "$BREAK_CC" == "true" ]] && run_or_err "Unbreaking previously broken ~/bin/cc" "rm $HOME/bin/cc" + # FIXME - Devel::Cover (brought by Test::Strict, but soon needed anyway) # does not test cleanly on 5.8.7 - just get it directly if perl -M5.008007 -e1 &>/dev/null && ! perl -M5.008008 -e1 &>/dev/null; then From 3071c14a8bffa0f91945b09bbe3e88d4003387f3 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 11 Apr 2016 13:10:53 +0200 Subject: [PATCH 056/262] (travis) Add 5.22.1 with quadmath testing --- .travis.yml | 13 +++++++++++++ maint/travis-ci_scripts/20_install.bash | 8 ++++---- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/.travis.yml b/.travis.yml index 43948b168..0260450cb 100644 --- a/.travis.yml +++ b/.travis.yml @@ -204,6 +204,19 @@ matrix: - DBICTEST_VIA_REPLICATED=0 - DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1 + - perl: "5.22.1_thr_qm" + # explicit new infra spec preparing for a future forced upgrade + # also need to pull in a sufficiently new compiler for quadmath.h + sudo: required + dist: trusty + env: + - VCPU_USE=1 + - CLEANTEST=true + - POISON_ENV=true + - MVDT=false + - BREWVER=5.22.1 + - BREWOPTS="-Duseithreads -Dusequadmath" + ### # Start of the allow_failures block diff --git a/maint/travis-ci_scripts/20_install.bash b/maint/travis-ci_scripts/20_install.bash index 490ceb763..08e25c44f 100755 --- a/maint/travis-ci_scripts/20_install.bash +++ b/maint/travis-ci_scripts/20_install.bash @@ -38,10 +38,10 @@ if [[ -n "$BREWVER" ]] ; then run_or_err "Compiling/installing Perl $BREWVER (without testing, using ${perlbrew_jopt:-1} threads, may take up to 5 minutes)" \ "perlbrew install --as $BREWVER --notest --noman --verbose $BREWOPTS -j${perlbrew_jopt:-1} $BREWSRC" - # can not do 'perlbrew uss' in the run_or_err subshell above, or a $() - # furthermore `perlbrew use` returns 0 regardless of whether the perl is - # found (won't be there unless compilation suceeded, wich *ALSO* returns 0) - perlbrew use $BREWVER + # can not do 'perlbrew use' in the run_or_err subshell above, or a $() + # furthermore some versions of `perlbrew use` return 0 regardless of whether + # the perl is found (won't be there unless compilation suceeded, wich *ALSO* returns 0) + perlbrew use $BREWVER || /bin/true if [[ "$( perlbrew use | grep -oP '(?<=Currently using ).+' )" != "$BREWVER" ]] ; then echo_err "Unable to switch to $BREWVER - compilation failed...?" From 64d48e1989b06ff4cdb33eb7b16846d511168c64 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 11 Apr 2016 15:53:04 +0200 Subject: [PATCH 057/262] (travis) Add a CLEANTEST run of RURBAN's cperl in the spirit of 62f2092b Refer to the (*really* small) patchset for info on how to run the same locally TLDR: you need to activate distroprefs and use CPAN.pm --- .travis.yml | 19 +++++++++++++++++++ maint/travis-ci_scripts/20_install.bash | 6 +++++- maint/travis-ci_scripts/30_before_script.bash | 13 +++++++++++++ maint/travis-ci_scripts/common.bash | 6 ++++++ t/lib/ANFANG.pm | 7 +++++++ xt/extra/internals/optional_deps.t | 4 ++++ 6 files changed, 54 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 0260450cb..93ec06b9c 100644 --- a/.travis.yml +++ b/.travis.yml @@ -204,6 +204,8 @@ matrix: - DBICTEST_VIA_REPLICATED=0 - DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1 + # MAKE SURE TO KEEP THE FLAGS IDENTICAL TO CPERL BELOW + # allows for easier side-by-side comparison - perl: "5.22.1_thr_qm" # explicit new infra spec preparing for a future forced upgrade # also need to pull in a sufficiently new compiler for quadmath.h @@ -220,6 +222,22 @@ matrix: ### # Start of the allow_failures block + # MAKE SURE TO KEEP THE FLAGS IDENTICAL TO STOCK 5.22.1 ABOVE + # allows for easier side-by-side comparison + - perl: "cperl-5.22.1_thr_qm" + # explicit new infra spec preparing for a future forced upgrade + # also need to pull in a sufficiently new compiler for quadmath.h + sudo: required + dist: trusty + env: + # FIXME - work around https://github.com/perl11/cperl/issues/131 + - VCPU_USE=1 + - CLEANTEST=true + - POISON_ENV=true + - MVDT=false + - BREWVER=cperl-5.22.1 + - BREWOPTS="-Duseithreads -Dusequadmath" + # threaded oldest possible with blead CPAN - perl: "devcpan_5.8.1_thr_mb" sudo: false @@ -330,6 +348,7 @@ matrix: allow_failures: # these run with various dev snapshots - allowed to fail + - perl: cperl-5.22.1_thr_qm - perl: devcpan_5.8.1_thr_mb - perl: devcpan_5.8.1 - perl: devcpan_5.8.3_mb diff --git a/maint/travis-ci_scripts/20_install.bash b/maint/travis-ci_scripts/20_install.bash index 08e25c44f..7628b4a76 100755 --- a/maint/travis-ci_scripts/20_install.bash +++ b/maint/travis-ci_scripts/20_install.bash @@ -31,7 +31,11 @@ if [[ -n "$BREWVER" ]] ; then BREWSRC="$BREWVER" - if [[ "$BREWVER" == "schmorp_stableperl" ]] ; then + if is_cperl; then + # FFS perlbrew ( see http://wollmers-perl.blogspot.de/2015/10/install-cperl-with-perlbrew.html ) + wget -qO- https://github.com/perl11/cperl/archive/$BREWVER.tar.gz > /tmp/cperl-$BREWVER.tar.gz + BREWSRC="/tmp/cperl-$BREWVER.tar.gz" + elif [[ "$BREWVER" == "schmorp_stableperl" ]] ; then BREWSRC="http://stableperl.schmorp.de/dist/stableperl-5.22.0-1.001.tar.gz" fi diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 79a360d27..3965bca12 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -11,6 +11,19 @@ if [[ "$DEVREL_DEPS" == "true" ]] ; then export MVDT="" fi +# Need a shitton of patches to run on cperl (luckily all provided) +# Also need to have YAML in place, otherwise the distroprefs are not readable +if is_cperl ; then + + run_or_err "Downloading and installing cperl distroprefs" ' + wget -qO- https://github.com/rurban/distroprefs/archive/master.tar.gz |\ + tar -C $HOME/.cpan --strip-components 1 -zx distroprefs-master/prefs distroprefs-master/sources + ' + + installdeps YAML + +fi + # 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) diff --git a/maint/travis-ci_scripts/common.bash b/maint/travis-ci_scripts/common.bash index f73added4..7bbcfabc5 100755 --- a/maint/travis-ci_scripts/common.bash +++ b/maint/travis-ci_scripts/common.bash @@ -135,6 +135,8 @@ extract_prereqs() { parallel_installdeps_notest() { if [[ -z "$@" ]] ; then return; fi + is_cperl && echo_err "cpanminus is not yet usable on cperl" && exit 1 + # one module spec per line MODLIST="$(printf '%s\n' "$@" | sort -R)" @@ -194,6 +196,8 @@ installdeps() { _dep_inst_with_test() { if [[ "$DEVREL_DEPS" == "true" ]] ; then + is_cperl && echo_err "cpanminus is not yet usable on cperl" && exit 1 + # --dev is already part of CPANM_OPT LASTCMD="$TIMEOUT_CMD cpanm $@" $LASTCMD 2>&1 || return 1 @@ -328,3 +332,5 @@ CPAN_is_sane() { perl -MCPAN\ 1.94_56 -e 1 &>/dev/null ; } CPAN_supports_BUILDPL() { perl -MCPAN\ 1.9205 -e1 &>/dev/null; } have_sudo() { sudo /bin/true &>/dev/null ; } + +is_cperl() { [[ "$BREWVER" =~ $( echo -n "^cperl-" ) ]] ; } diff --git a/t/lib/ANFANG.pm b/t/lib/ANFANG.pm index 05304bf79..4e49fe05e 100644 --- a/t/lib/ANFANG.pm +++ b/t/lib/ANFANG.pm @@ -46,6 +46,13 @@ $INC{$_} ||= __FILE__ for (qw( ANFANG.pm t/lib/ANFANG.pm ./t/lib/ANFANG.pm )); and + # a ghetto way of recognizing cperl without loading Config.pm + # the $] guard is there because touching $^V on pre-5.10 loads + # the entire utf8 stack (wtf!!!) + ( "$]" < 5.010 or $^V !~ /\d+c$/ ) + + and + # just don't check anything under RELEASE_TESTING # a naive approach would be to simply whitelist both # strict and warnings, but pre 5.10 there were even diff --git a/xt/extra/internals/optional_deps.t b/xt/extra/internals/optional_deps.t index f2feb4e13..de45ae065 100644 --- a/xt/extra/internals/optional_deps.t +++ b/xt/extra/internals/optional_deps.t @@ -17,6 +17,7 @@ use Scalar::Util(); use MRO::Compat(); use Carp 'confess'; use List::Util 'shuffle'; +use Config; SKIP: { skip 'Lean load pattern testing unsafe with $ENV{PERL5OPT}', 1 @@ -28,6 +29,9 @@ SKIP: { skip 'Lean load pattern testing useless with $ENV{RELEASE_TESTING}', 1 if $ENV{RELEASE_TESTING}; + skip 'Lean load pattern testing useless under cperl', 1 + if $Config{usecperl}; + is_deeply $inc_before, [], From 4b1b44c16347a9f7a404a390983782cc5625e355 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 12 Apr 2016 13:52:04 +0200 Subject: [PATCH 058/262] Bring back constants excised in 08a8d8f1. FML. --- lib/DBIx/Class/_Util.pm | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index f07dff6d5..09fdfe95a 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -52,6 +52,24 @@ BEGIN { require mro; constant->import( OLD_MRO => 0 ); } + + # Both of these are no longer used for anything. However bring + # them back after they were purged in 08a8d8f1, as there appear + # to be outfits with *COPY PASTED* pieces of lib/DBIx/Class/Storage/* + # in their production codebases. There is no point in breaking these + # if whatever they used actually continues to work + my $warned; + my $sigh = sub { + + require Carp; + my $cluck = "The @{[ (caller(1))[3] ]} constant is no more - adjust your code" . Carp::longmess(); + + warn $cluck unless $warned->{$cluck}++; + + 0; + }; + sub DBICTEST () { &$sigh } + sub PEEPEENESS () { &$sigh } } # FIXME - this is not supposed to be here From de0edd06a26e5a5f90df64777aeba91968f06c93 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 12 Apr 2016 12:09:03 +0200 Subject: [PATCH 059/262] Harmonize DBICTEST_VIA_REPLICATED detection in tests Back in 8b60b9211a I made a number of mistakes implementing the escape checks: an envvar being set does not mean we are in fact running under replication (e.g. the user requested explicitly use_file => 0 ) Fix that and also make sure we still run when use_file => 1 (and fix a forgotten test failing this way) --- t/52leaks.t | 1 + t/admin/03data.t | 6 +++++- t/icdt/engine_specific/sqlite.t | 2 +- t/lib/DBICTest.pm | 7 +++++-- t/storage/base.t | 3 +-- t/storage/dbh_do.t | 4 +--- t/storage/error.t | 6 ++++-- 7 files changed, 18 insertions(+), 11 deletions(-) diff --git a/t/52leaks.t b/t/52leaks.t index 76fc8e6cd..fffc942d0 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -59,6 +59,7 @@ my $has_dt; # Skip the heavy-duty leak tracing when just doing an install # or when having Moose crap all over everything +# FIXME - remove when Replicated gets off Moose if ( !$ENV{DBICTEST_VIA_REPLICATED} and !DBICTest::RunMode->is_plain ) { # redefine the bless override so that we can catch each and every object created diff --git a/t/admin/03data.t b/t/admin/03data.t index 460a89e2e..4be2960cd 100644 --- a/t/admin/03data.t +++ b/t/admin/03data.t @@ -19,9 +19,13 @@ use DBIx::Class::Admin; sqlite_use_file => 1, ); + my $storage = $schema->storage; + $storage = $storage->master + if $storage->isa('DBIx::Class::Storage::DBI::Replicated'); + my $admin = DBIx::Class::Admin->new( schema_class=> "DBICTest::Schema", - connect_info => $schema->storage->connect_info(), + connect_info => $storage->connect_info(), quiet => 1, _confirm=>1, ); diff --git a/t/icdt/engine_specific/sqlite.t b/t/icdt/engine_specific/sqlite.t index 297372cdb..1bee9d646 100644 --- a/t/icdt/engine_specific/sqlite.t +++ b/t/icdt/engine_specific/sqlite.t @@ -18,7 +18,7 @@ use DBICTest; my $storage = $schema->storage; - if ($ENV{DBICTEST_VIA_REPLICATED}) { + if( $storage->isa('DBIx::Class::Storage::DBI::Replicated') ) { $storage = $storage->master; } else { diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index e4768a07b..2e265b5e4 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -349,8 +349,11 @@ sub init_schema { my $schema; if ( - $ENV{DBICTEST_VIA_REPLICATED} &&= - ( !$args{storage_type} && !defined $args{sqlite_use_file} ) + $ENV{DBICTEST_VIA_REPLICATED} &&= ( + !$args{storage_type} + && + ( ! defined $args{sqlite_use_file} or $args{sqlite_use_file} ) + ) ) { $args{storage_type} = ['::DBI::Replicated', { balancer_type => '::Random' }]; $args{sqlite_use_file} = 1; diff --git a/t/storage/base.t b/t/storage/base.t index 90cd8f7b1..df59e9127 100644 --- a/t/storage/base.t +++ b/t/storage/base.t @@ -18,7 +18,7 @@ is( ref($storage), 'DBIx::Class::Storage::DBI::SQLite', 'Storage reblessed correctly into DBIx::Class::Storage::DBI::SQLite' -) unless $ENV{DBICTEST_VIA_REPLICATED}; +) unless $storage->isa('DBIx::Class::Storage::DBI::Replicated'); throws_ok { $schema->storage->throw_exception('test_exception_42'); @@ -56,7 +56,6 @@ throws_ok { }; } - # testing various invocations of connect_info ([ ... ]) my $coderef = sub { 42 }; diff --git a/t/storage/dbh_do.t b/t/storage/dbh_do.t index 1511f82e6..07453eaf9 100644 --- a/t/storage/dbh_do.t +++ b/t/storage/dbh_do.t @@ -10,10 +10,8 @@ use DBICTest; my $schema = DBICTest->init_schema(); my $storage = $schema->storage; - $storage = $storage->master - if $ENV{DBICTEST_VIA_REPLICATED}; - + if $storage->isa('DBIx::Class::Storage::DBI::Replicated'); # test (re)connection for my $disconnect (0, 1) { diff --git a/t/storage/error.t b/t/storage/error.t index e8996fa87..710ec22ca 100644 --- a/t/storage/error.t +++ b/t/storage/error.t @@ -24,7 +24,8 @@ for my $conn_args ( ); my $storage = $s->storage; - $storage = $storage->master if $ENV{DBICTEST_VIA_REPLICATED}; + $storage = $storage->master + if $storage->isa('DBIx::Class::Storage::DBI::Replicated'); ok( ! $storage->connected, 'Starting unconnected' ); @@ -49,7 +50,8 @@ for my $conn_args ( my $s = DBICTest->init_schema( no_deploy => 1, @$conn_args ); my $storage = $s->storage; - $storage = $storage->master if $ENV{DBICTEST_VIA_REPLICATED}; + $storage = $storage->master + if $storage->isa('DBIx::Class::Storage::DBI::Replicated'); my $desc = "broken on_disconnect action @{[ explain $conn_args ]}"; From 36600771d6808d7ab45110c77a494510568ce3c7 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 12 Apr 2016 13:27:14 +0200 Subject: [PATCH 060/262] Remove dead code from DBI::Replicated This was originally introduced in fecb38cba, without tests nor justification. Subsequently it got modified a bit in 7da56142c, and then got completely broken by bbdda2810 which designated _dbh_details() as an off-limits internal method. Given nothing has been heard since (6 years), and there is no effective change of behavior (the snippet below fails identically below and after this change) go ahead and burninate. Also adjust the "can't touch this" exception text a bit. DBICTEST_VIA_REPLICATED=1 perl -Ilib -It/lib -MDBICTest -e ' eval { DBICTest->init_schema->storage->$_ }, warn $@ for qw( _dbh_details _server_info _get_server_version _describe_connection ) ' --- lib/DBIx/Class/Storage/DBI/Replicated.pm | 38 +++++------------------- 1 file changed, 7 insertions(+), 31 deletions(-) diff --git a/lib/DBIx/Class/Storage/DBI/Replicated.pm b/lib/DBIx/Class/Storage/DBI/Replicated.pm index 512c53e0b..6a2f7ad8f 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated.pm @@ -18,7 +18,7 @@ use DBIx::Class::Storage::DBI::Replicated::Types qw/BalancerClassNamePart DBICSc use MooseX::Types::Moose qw/ClassName HashRef Object/; use Scalar::Util 'reftype'; use Hash::Merge; -use List::Util qw/min max reduce/; +use List::Util qw( min max ); use Context::Preserve 'preserve_context'; use Try::Tiny; use DBIx::Class::_Util 'dbic_internal_try'; @@ -343,6 +343,8 @@ my $method_dispatch = { _dbh_details _dbh_get_info _get_rdbms_name + _get_server_version + _server_info _determine_connector_driver _extract_driver_from_connect_info @@ -406,7 +408,10 @@ if ( $INC{"t/lib/ANFANG.pm"} ) { for my $method (@{$method_dispatch->{unimplemented}}) { __PACKAGE__->meta->add_method($method, sub { my $self = shift; - $self->throw_exception("$method() must not be called on ".(blessed $self).' objects'); + $self->throw_exception( + "$method() may not be called on '@{[ blessed $self ]}' objects, " + . 'call it on a specific pool instance instead' + ); }); } @@ -1049,35 +1054,6 @@ sub _ping { return min map $_->_ping, $self->all_storages; } -# not using the normalized_version, because we want to preserve -# version numbers much longer than the conventional xxx.yyyzzz -my $numify_ver = sub { - my $ver = shift; - my @numparts = split /\D+/, $ver; - my $format = '%d.' . (join '', ('%06d') x (@numparts - 1)); - - return sprintf $format, @numparts; -}; -sub _server_info { - my $self = shift; - - if (not $self->_dbh_details->{info}) { - $self->_dbh_details->{info} = ( - reduce { $a->[0] < $b->[0] ? $a : $b } - map [ $numify_ver->($_->{dbms_version}), $_ ], - map $_->_server_info, $self->all_storages - )->[1]; - } - - return $self->next::method; -} - -sub _get_server_version { - my $self = shift; - - return $self->_server_info->{dbms_version}; -} - =head1 GOTCHAS Due to the fact that replicants can lag behind a master, you must take care to From 817ac9e927cd8e29d1bf553714379e54df5dbef7 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 11 Apr 2016 11:49:56 +0200 Subject: [PATCH 061/262] Lose another dependency: Class::Inspector It is either used in tests (where we cargocult a similar function), or in a spot where Package::Stash will do --- Makefile.PL | 1 - lib/DBIx/Class/ResultSetManager.pm | 13 ++++++++++-- t/cdbi/has_many_loads_foreign_class.t | 4 ++-- t/lib/DBICTest/Util.pm | 25 +++++++++++++++++++++++- t/resultset_class.t | 8 ++++---- xt/extra/internals/ensure_class_loaded.t | 12 ++++++------ xt/extra/internals/namespaces_cleaned.t | 4 ---- 7 files changed, 47 insertions(+), 20 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index a44941b20..ccd27697b 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -55,7 +55,6 @@ my $runtime_requires = { # pure-perl (FatPack-able) libs 'Class::Accessor::Grouped' => '0.10012', 'Class::C3::Componentised' => '1.0009', - 'Class::Inspector' => '1.24', 'Context::Preserve' => '0.01', 'Data::Page' => '2.00', 'Devel::GlobalDestruction' => '0.09', diff --git a/lib/DBIx/Class/ResultSetManager.pm b/lib/DBIx/Class/ResultSetManager.pm index bb9f3bf06..0022e8a2b 100644 --- a/lib/DBIx/Class/ResultSetManager.pm +++ b/lib/DBIx/Class/ResultSetManager.pm @@ -3,7 +3,7 @@ use strict; use warnings; use base 'DBIx::Class'; use Sub::Name (); -use Class::Inspector; +use Package::Stash (); warn "DBIx::Class::ResultSetManager never left experimental status and has now been DEPRECATED. This module will be deleted in 09000 so please @@ -53,7 +53,16 @@ sub _register_attributes { my $cache = $self->_attr_cache; return if keys %$cache == 0; - foreach my $meth (@{Class::Inspector->methods($self) || []}) { + foreach my $meth (keys %{ { map + { $_ => 1 } + map + { Package::Stash->new($_)->list_all_symbols("CODE") } + @{ mro::get_linear_isa( ref $self || $self ) } + } } ) { + # *DO NOT* rely on P::S returning crefs in reverse mro order + # but instead ask the mro to redo the lookup + # This codepath is extremely old, miht as well keep it running + # as-is with no room for surprises my $attrs = $cache->{$self->can($meth)}; next unless $attrs; if ($attrs->[0] eq 'ResultSet') { diff --git a/t/cdbi/has_many_loads_foreign_class.t b/t/cdbi/has_many_loads_foreign_class.t index a0af15abc..be5553dd9 100644 --- a/t/cdbi/has_many_loads_foreign_class.t +++ b/t/cdbi/has_many_loads_foreign_class.t @@ -7,11 +7,11 @@ use warnings; use Test::More; use lib 't/cdbi/testlib'; +use DBICTest::Util 'class_seems_loaded'; use Director; # Test that has_many() will load the foreign class -require Class::Inspector; -ok !Class::Inspector->loaded( 'Film' ); +ok ! class_seems_loaded('Film'), 'Start non-loaded'; ok eval { Director->has_many( films => 'Film' ); 1; } or diag $@; my $shan_hua = Director->create({ diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index b084560f3..3bcbe8945 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -35,7 +35,7 @@ use DBIx::Class::_Util qw( scope_guard parent_dir mkdir_p ); use base 'Exporter'; our @EXPORT_OK = qw( - dbg stacktrace + dbg stacktrace class_seems_loaded local_umask slurp_bytes tmpdir find_co_root rm_rf visit_namespaces PEEPEENESS check_customcond_args @@ -431,4 +431,27 @@ sub visit_namespaces { return $visited_count; } +# +# Replicate the *heuristic* (important!!!) implementation found in various +# forms within Class::Load / Module::Inspector / Class::C3::Componentised +# +sub class_seems_loaded ($) { + + croak "Function expects a class name as plain string (no references)" + unless defined $_[0] and not length ref $_[0]; + + no strict 'refs'; + + return 1 if defined ${"$_[0]::VERSION"}; + + return 1 if @{"$_[0]::ISA"}; + + return 1 if $INC{ (join ('/', split ('::', $_[0]) ) ) . '.pm' }; + + ( !!*{"$_[0]::$_"}{CODE} ) and return 1 + for keys %{"$_[0]::"}; + + return 0; +} + 1; diff --git a/t/resultset_class.t b/t/resultset_class.t index 43054a58f..3d7902239 100644 --- a/t/resultset_class.t +++ b/t/resultset_class.t @@ -3,18 +3,18 @@ BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use strict; use warnings; use Test::More; -use Class::Inspector (); use DBICTest; +use DBICTest::Util 'class_seems_loaded'; is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICTest::BaseResultSet', 'default resultset class'); -ok(!Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded'); +ok(! class_seems_loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded'); DBICTest::Schema->source('Artist')->resultset_class('DBICNSTest::ResultSet::A'); -ok(!Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded on SET'); +ok(! class_seems_loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded on SET'); is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICNSTest::ResultSet::A', 'custom resultset class set'); -ok(Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class loaded on GET'); +ok(class_seems_loaded('DBICNSTest::ResultSet::A'), 'custom resultset class loaded on GET'); my $schema = DBICTest->init_schema; my $resultset = $schema->resultset('Artist')->search; diff --git a/xt/extra/internals/ensure_class_loaded.t b/xt/extra/internals/ensure_class_loaded.t index 3dba83dbc..d106d3ed7 100644 --- a/xt/extra/internals/ensure_class_loaded.t +++ b/xt/extra/internals/ensure_class_loaded.t @@ -7,7 +7,7 @@ use Test::More; use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; -use Class::Inspector; +use DBICTest::Util 'class_seems_loaded'; BEGIN { package TestPackage::A; @@ -21,11 +21,11 @@ plan tests => 28; # Test ensure_class_found ok( $schema->ensure_class_found('DBIx::Class::Schema'), 'loaded package DBIx::Class::Schema was found' ); -ok( !Class::Inspector->loaded('DBICTest::FakeComponent'), +ok( ! class_seems_loaded('DBICTest::FakeComponent'), 'DBICTest::FakeComponent not loaded yet' ); ok( $schema->ensure_class_found('DBICTest::FakeComponent'), 'package DBICTest::FakeComponent was found' ); -ok( !Class::Inspector->loaded('DBICTest::FakeComponent'), +ok( ! class_seems_loaded('DBICTest::FakeComponent'), 'DBICTest::FakeComponent not loaded by ensure_class_found()' ); ok( $schema->ensure_class_found('TestPackage::A'), 'anonymous package TestPackage::A found' ); @@ -88,17 +88,17 @@ like( $@, qr/did not return a true value/, } # Test ensure_class_loaded -ok( Class::Inspector->loaded('TestPackage::A'), 'anonymous package exists' ); +ok( class_seems_loaded('TestPackage::A'), 'anonymous package exists' ); eval { $schema->ensure_class_loaded('TestPackage::A'); }; ok( !$@, 'ensure_class_loaded detected an anon. class' ); eval { $schema->ensure_class_loaded('FakePackage::B'); }; like( $@, qr/Can't locate/, 'ensure_class_loaded threw exception for nonexistent class' ); -ok( !Class::Inspector->loaded('DBICTest::FakeComponent'), +ok( ! class_seems_loaded('DBICTest::FakeComponent'), 'DBICTest::FakeComponent not loaded yet' ); eval { $schema->ensure_class_loaded('DBICTest::FakeComponent'); }; ok( !$@, 'ensure_class_loaded detected an existing but non-loaded class' ); -ok( Class::Inspector->loaded('DBICTest::FakeComponent'), +ok( class_seems_loaded('DBICTest::FakeComponent'), 'DBICTest::FakeComponent now loaded' ); { diff --git a/xt/extra/internals/namespaces_cleaned.t b/xt/extra/internals/namespaces_cleaned.t index b8b42b7d7..3f702628a 100644 --- a/xt/extra/internals/namespaces_cleaned.t +++ b/xt/extra/internals/namespaces_cleaned.t @@ -90,10 +90,6 @@ my $has_moose = eval { require Moose::Util }; Sub::Defer::undefer_all(); -# can't use Class::Inspector for the mundane parts as it does not -# distinguish imports from anything else, what a crock of... -# Moose is not always available either - hence just do it ourselves - my $seen; #inheritance means we will see the same method multiple times for my $mod (@modules) { From 87b1255103d7b8873b225416cb381c50011f4c06 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 11 Apr 2016 13:31:18 +0200 Subject: [PATCH 062/262] And lose yet another dependency: List::Util (yes, I know it's core) The main motivation for this is that first {} is an expensive subcall, whereas grep is a native fast opcode. Within the entire codebase there are pretty much no spots where we have so many elements to check, that the "check everything" of grep will overwhelm the expense of entersub (in fact 2 calls - one to first() itself, another to the block) As a side effect the removal of first(), which was the only thing we used that has known leaks prior to L::U 1.18, lets us drop the "5.8.8+ or later" List::Util dep entirely (it doesn't matter much for users, but it stresses the CI even more, which is a good thing) This cangeset should introduce 0 functional changes --- Makefile.PL | 7 ------ lib/DBIx/Class/Ordered.pm | 13 +++++----- lib/DBIx/Class/ResultSet.pm | 24 ++++++++----------- lib/DBIx/Class/ResultSetColumn.pm | 5 +--- lib/DBIx/Class/ResultSource/RowParser.pm | 4 ++-- lib/DBIx/Class/Row.pm | 6 +++-- lib/DBIx/Class/SQLMaker/LimitDialects.pm | 3 --- lib/DBIx/Class/Storage/DBI.pm | 3 +-- lib/DBIx/Class/Storage/DBI/ACCESS.pm | 4 +--- lib/DBIx/Class/Storage/DBI/Cursor.pm | 3 +-- lib/DBIx/Class/Storage/DBI/DB2.pm | 2 -- lib/DBIx/Class/Storage/DBI/Firebird/Common.pm | 4 +--- lib/DBIx/Class/Storage/DBI/IdentityInsert.pm | 2 -- lib/DBIx/Class/Storage/DBI/MSSQL.pm | 1 - lib/DBIx/Class/Storage/DBI/NoBindVars.pm | 3 --- lib/DBIx/Class/Storage/DBI/Oracle.pm | 2 -- lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm | 3 +-- lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm | 9 ++++--- lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm | 5 ++-- lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm | 22 +++++++---------- .../Storage/DBI/Sybase/ASE/NoBindVars.pm | 3 +-- lib/DBIx/Class/Storage/DBI/mysql.pm | 2 -- lib/DBIx/Class/Storage/DBIHacks.pm | 3 +-- lib/DBIx/Class/_Util.pm | 1 - maint/travis-ci_scripts/30_before_script.bash | 2 -- xt/dist/pod_coverage.t | 3 +-- 26 files changed, 47 insertions(+), 92 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index ccd27697b..9a4f07448 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -42,13 +42,6 @@ my $runtime_requires = { ### 'DBI' => '1.57', - # on older versions first() leaks - # for the time being make it a hard dep - when we get - # rid of Sub::Name will revisit this (possibility is - # to use Devel::HideXS to force the pure-perl version - # or something like that) - 'List::Util' => '1.16', - # XS (or XS-dependent) libs 'Sub::Name' => '0.04', diff --git a/lib/DBIx/Class/Ordered.pm b/lib/DBIx/Class/Ordered.pm index 4c9a14c6b..8b84bd4e4 100644 --- a/lib/DBIx/Class/Ordered.pm +++ b/lib/DBIx/Class/Ordered.pm @@ -3,9 +3,6 @@ use strict; use warnings; use base qw( DBIx::Class ); -use List::Util 'first'; -use namespace::clean; - =head1 NAME DBIx::Class::Ordered - Modify the position of objects in an ordered list. @@ -564,7 +561,7 @@ sub update { if (! keys %$changed_ordering_cols) { return $self->next::method( undef, @_ ); } - elsif (defined first { exists $changed_ordering_cols->{$_} } @group_columns ) { + elsif (grep { exists $changed_ordering_cols->{$_} } @group_columns ) { $self->move_to_group( # since the columns are already re-set the _grouping_clause is correct # move_to_group() knows how to get the original storage values @@ -614,7 +611,11 @@ sub delete { # add the current position/group to the things we track old values for sub _track_storage_value { my ($self, $col) = @_; - return $self->next::method($col) || defined first { $_ eq $col } ($self->position_column, $self->_grouping_columns); + return ( + $self->next::method($col) + || + grep { $_ eq $col } ($self->position_column, $self->_grouping_columns) + ); } =head1 METHODS FOR EXTENDING ORDERED @@ -740,7 +741,7 @@ sub _shift_siblings { local $rsrc->schema->{_ORDERED_INTERNAL_UPDATE} = 1; my @pcols = $rsrc->primary_columns; if ( - first { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) + grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) { my $clean_rs = $rsrc->resultset; diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 71ff3ab3c..b51e05cbc 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -13,9 +13,6 @@ use DBIx::Class::_Util qw( ); use Try::Tiny; -# not importing first() as it will clash with our own method -use List::Util (); - BEGIN { # De-duplication in _merge_attr() is disabled, but left in for reference # (the merger is used for other things that ought not to be de-duped) @@ -466,7 +463,7 @@ sub search_rs { # see if we can keep the cache (no $rs changes) my $cache; my %safe = (alias => 1, cache => 1); - if ( ! List::Util::first { !$safe{$_} } keys %$call_attrs and ( + if ( ! grep { !$safe{$_} } keys %$call_attrs and ( ! defined $call_cond or ref $call_cond eq 'HASH' && ! keys %$call_cond @@ -490,9 +487,8 @@ sub search_rs { my @selector_attrs = qw/select as columns cols +select +as +columns include_columns/; # reset the current selector list if new selectors are supplied - if (List::Util::first { exists $call_attrs->{$_} } qw/columns cols select as/) { - delete @{$old_attrs}{(@selector_attrs, '_dark_selector')}; - } + delete @{$old_attrs}{(@selector_attrs, '_dark_selector')} + if grep { exists $call_attrs->{$_} } qw(columns cols select as); # Normalize the new selector list (operates on the passed-in attr structure) # Need to do it on every chain instead of only once on _resolved_attrs, in @@ -1888,7 +1884,7 @@ sub _rs_update_delete { $storage->_prune_unused_joins ($attrs); # any non-pruneable non-local restricting joins imply subq - $needs_subq = defined List::Util::first { $_ ne $attrs->{alias} } keys %{ $join_classifications->{restricting} || {} }; + $needs_subq = grep { $_ ne $attrs->{alias} } keys %{ $join_classifications->{restricting} || {} }; } # check if the head is composite (by now all joins are thrown out unless $needs_subq) @@ -3531,7 +3527,7 @@ sub _resolved_attrs { # default selection list $attrs->{columns} = [ $source->columns ] - unless List::Util::first { exists $attrs->{$_} } qw/columns cols select as/; + unless grep { exists $attrs->{$_} } qw/columns cols select as/; # merge selectors together for (qw/columns select as/) { @@ -3692,7 +3688,7 @@ sub _resolved_attrs { if ( ! $attrs->{_main_source_premultiplied} and - ! List::Util::first { ! $_->[0]{-is_single} } @fromlist + ! grep { ! $_->[0]{-is_single} } @fromlist ) { $attrs->{collapse} = 0; } @@ -3922,7 +3918,7 @@ sub _merge_joinpref_attr { }, ARRAY => sub { return $_[1] if !defined $_[0]; - return $_[1] if __HM_DEDUP and List::Util::first { $_ eq $_[0] } @{$_[1]}; + return $_[1] if __HM_DEDUP and grep { $_ eq $_[0] } @{$_[1]}; return [$_[0], @{$_[1]}] }, HASH => sub { @@ -3935,7 +3931,7 @@ sub _merge_joinpref_attr { ARRAY => { SCALAR => sub { return $_[0] if !defined $_[1]; - return $_[0] if __HM_DEDUP and List::Util::first { $_ eq $_[1] } @{$_[0]}; + return $_[0] if __HM_DEDUP and grep { $_ eq $_[1] } @{$_[0]}; return [@{$_[0]}, $_[1]] }, ARRAY => sub { @@ -3948,7 +3944,7 @@ sub _merge_joinpref_attr { HASH => sub { return [ $_[1] ] if ! @{$_[0]}; return $_[0] if !keys %{$_[1]}; - return $_[0] if __HM_DEDUP and List::Util::first { $_ eq $_[1] } @{$_[0]}; + return $_[0] if __HM_DEDUP and grep { $_ eq $_[1] } @{$_[0]}; return [ @{$_[0]}, $_[1] ]; }, }, @@ -3963,7 +3959,7 @@ sub _merge_joinpref_attr { return [] if !keys %{$_[0]} and !@{$_[1]}; return [ $_[0] ] if !@{$_[1]}; return $_[1] if !keys %{$_[0]}; - return $_[1] if __HM_DEDUP and List::Util::first { $_ eq $_[0] } @{$_[1]}; + return $_[1] if __HM_DEDUP and grep { $_ eq $_[0] } @{$_[1]}; return [ $_[0], @{$_[1]} ]; }, HASH => sub { diff --git a/lib/DBIx/Class/ResultSetColumn.pm b/lib/DBIx/Class/ResultSetColumn.pm index e26b6c2f3..8d9d7a322 100644 --- a/lib/DBIx/Class/ResultSetColumn.pm +++ b/lib/DBIx/Class/ResultSetColumn.pm @@ -8,9 +8,6 @@ use DBIx::Class::Carp; use DBIx::Class::_Util 'fail_on_internal_wantarray'; use namespace::clean; -# not importing first() as it will clash with our own method -use List::Util (); - =head1 NAME DBIx::Class::ResultSetColumn - helpful methods for messing @@ -56,7 +53,7 @@ sub new { # (to create a new column definition on-the-fly). my $as_list = $orig_attrs->{as} || []; my $select_list = $orig_attrs->{select} || []; - my $as_index = List::Util::first { ($as_list->[$_] || "") eq $column } 0..$#$as_list; + my ($as_index) = grep { ($as_list->[$_] || "") eq $column } 0..$#$as_list; my $select = defined $as_index ? $select_list->[$as_index] : $column; my $colmap; diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index 12e309b11..9d41e01ef 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -7,7 +7,7 @@ use warnings; use base 'DBIx::Class'; use Try::Tiny; -use List::Util qw(first max); +use List::Util 'max'; use DBIx::Class::ResultSource::RowParser::Util qw( assemble_simple_parser @@ -452,7 +452,7 @@ sub _resolve_collapse { # if there is at least one *inner* reverse relationship which is HASH-based (equality only) # we can safely assume that the child can not exist without us - rev_rel_is_optional => ( first + rev_rel_is_optional => ( grep { ref $_->{cond} eq 'HASH' and ($_->{attrs}{join_type}||'') !~ /^left/i } values %{ $self->reverse_relationship_info($rel) }, ) ? 0 : 1, diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index daf5885d3..c8b57b696 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -6,7 +6,6 @@ use warnings; use base qw/DBIx::Class/; use Scalar::Util 'blessed'; -use List::Util 'first'; use DBIx::Class::_Util 'dbic_internal_try'; use DBIx::Class::Carp; use SQL::Abstract qw( is_literal_value is_plain_value ); @@ -1026,7 +1025,10 @@ sub _eq_column_values { # value tracked between column changes and commitment to storage sub _track_storage_value { my ($self, $col) = @_; - return defined first { $col eq $_ } ($self->result_source->primary_columns); + return scalar grep + { $col eq $_ } + $self->result_source->primary_columns + ; } =head2 set_columns diff --git a/lib/DBIx/Class/SQLMaker/LimitDialects.pm b/lib/DBIx/Class/SQLMaker/LimitDialects.pm index 0cfcd2b55..e6132d633 100644 --- a/lib/DBIx/Class/SQLMaker/LimitDialects.pm +++ b/lib/DBIx/Class/SQLMaker/LimitDialects.pm @@ -3,9 +3,6 @@ package DBIx::Class::SQLMaker::LimitDialects; use warnings; use strict; -use List::Util 'first'; -use namespace::clean; - # constants are used not only here, but also in comparison tests sub __rows_bindtype () { +{ sqlt_datatype => 'integer' } diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index adcd6b493..71c57daf7 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -9,7 +9,6 @@ use mro 'c3'; use DBIx::Class::Carp; use Scalar::Util qw/refaddr weaken reftype blessed/; -use List::Util qw/first/; use Context::Preserve 'preserve_context'; use Try::Tiny; use SQL::Abstract qw(is_plain_value is_literal_value); @@ -1743,7 +1742,7 @@ sub _gen_sql_bind { and $op eq 'select' and - first { + grep { length ref $_->[1] and blessed($_->[1]) diff --git a/lib/DBIx/Class/Storage/DBI/ACCESS.pm b/lib/DBIx/Class/Storage/DBI/ACCESS.pm index 7490d8951..2e00210b6 100644 --- a/lib/DBIx/Class/Storage/DBI/ACCESS.pm +++ b/lib/DBIx/Class/Storage/DBI/ACCESS.pm @@ -6,8 +6,6 @@ use base 'DBIx::Class::Storage::DBI::UniqueIdentifier'; use mro 'c3'; use DBI (); -use List::Util 'first'; -use namespace::clean; __PACKAGE__->sql_limit_dialect ('Top'); __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::ACCESS'); @@ -66,7 +64,7 @@ sub insert { my $columns_info = $source->columns_info; if (keys %$to_insert == 0) { - my $autoinc_col = first { + my ($autoinc_col) = grep { $columns_info->{$_}{is_auto_increment} } keys %$columns_info; diff --git a/lib/DBIx/Class/Storage/DBI/Cursor.pm b/lib/DBIx/Class/Storage/DBI/Cursor.pm index cac152926..ecd292b0f 100644 --- a/lib/DBIx/Class/Storage/DBI/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/Cursor.pm @@ -6,7 +6,6 @@ use warnings; use base 'DBIx::Class::Cursor'; use Scalar::Util qw(refaddr weaken); -use List::Util 'shuffle'; use DBIx::Class::_Util qw( detected_reinvoked_destructor dbic_internal_try ); use namespace::clean; @@ -188,7 +187,7 @@ sub all { and ! $self->{attrs}{order_by} ) - ? shuffle @{$sth->fetchall_arrayref} + ? List::Util::shuffle( @{$sth->fetchall_arrayref} ) : @{$sth->fetchall_arrayref} ; } diff --git a/lib/DBIx/Class/Storage/DBI/DB2.pm b/lib/DBIx/Class/Storage/DBI/DB2.pm index c34e641cb..2154c4565 100644 --- a/lib/DBIx/Class/Storage/DBI/DB2.pm +++ b/lib/DBIx/Class/Storage/DBI/DB2.pm @@ -5,8 +5,6 @@ use warnings; use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; -use Try::Tiny; -use namespace::clean; __PACKAGE__->datetime_parser_type('DateTime::Format::DB2'); __PACKAGE__->sql_quote_char ('"'); diff --git a/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm b/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm index 6e61ca5cb..3677ec3be 100644 --- a/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm +++ b/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm @@ -4,8 +4,6 @@ use strict; use warnings; use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; -use List::Util 'first'; -use namespace::clean; =head1 NAME @@ -80,7 +78,7 @@ EOF $generator = uc $generator unless $quoted; return $generator - if first { + if grep { $self->sql_maker->quote_char ? ($_ eq $col) : (uc($_) eq uc($col)) } @trig_cols; } diff --git a/lib/DBIx/Class/Storage/DBI/IdentityInsert.pm b/lib/DBIx/Class/Storage/DBI/IdentityInsert.pm index 8485e86fc..c66508d1a 100644 --- a/lib/DBIx/Class/Storage/DBI/IdentityInsert.pm +++ b/lib/DBIx/Class/Storage/DBI/IdentityInsert.pm @@ -5,8 +5,6 @@ use warnings; use base 'DBIx::Class::Storage::DBI'; use mro 'c3'; -use namespace::clean; - =head1 NAME DBIx::Class::Storage::DBI::IdentityInsert - Storage Component for Sybase ASE and diff --git a/lib/DBIx/Class/Storage/DBI/MSSQL.pm b/lib/DBIx/Class/Storage/DBI/MSSQL.pm index aed3689a4..f07adfdc7 100644 --- a/lib/DBIx/Class/Storage/DBI/MSSQL.pm +++ b/lib/DBIx/Class/Storage/DBI/MSSQL.pm @@ -11,7 +11,6 @@ use mro 'c3'; use Try::Tiny; use DBIx::Class::_Util qw( dbic_internal_try sigwarn_silencer ); -use List::Util 'first'; use namespace::clean; __PACKAGE__->mk_group_accessors(simple => qw/ diff --git a/lib/DBIx/Class/Storage/DBI/NoBindVars.pm b/lib/DBIx/Class/Storage/DBI/NoBindVars.pm index 2ca9939bd..495b3c85d 100644 --- a/lib/DBIx/Class/Storage/DBI/NoBindVars.pm +++ b/lib/DBIx/Class/Storage/DBI/NoBindVars.pm @@ -7,9 +7,6 @@ use base 'DBIx::Class::Storage::DBI'; use mro 'c3'; use DBIx::Class::SQLMaker::LimitDialects; -use List::Util qw/first/; - -use namespace::clean; =head1 NAME diff --git a/lib/DBIx/Class/Storage/DBI/Oracle.pm b/lib/DBIx/Class/Storage/DBI/Oracle.pm index 6dd8b724e..a0961086f 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle.pm @@ -5,8 +5,6 @@ use warnings; use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; -use Try::Tiny; -use namespace::clean; sub _rebless { my ($self) = @_; diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm index 30a9f54f3..b196b805a 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm @@ -7,7 +7,6 @@ use mro 'c3'; use DBIx::Class::Carp; use Scope::Guard (); use Context::Preserve 'preserve_context'; -use List::Util 'first'; use DBIx::Class::_Util qw( modver_gt_or_eq_and_lt dbic_internal_try ); use namespace::clean; @@ -286,7 +285,7 @@ sub _dbh_execute { my ($self, $sql, $bind) = @_[0,2,3]; # Turn off sth caching for multi-part LOBs. See _prep_for_execute below - local $self->{disable_sth_caching} = 1 if first { + local $self->{disable_sth_caching} = 1 if grep { ($_->[0]{_ora_lob_autosplit_part}||0) > (__cache_queries_with_max_lob_parts - 1) diff --git a/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm b/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm index 7c82d28c1..ed66b2840 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm @@ -2,7 +2,6 @@ package DBIx::Class::Storage::DBI::Replicated::Pool; use Moose; use DBIx::Class::Storage::DBI::Replicated::Replicant; -use List::Util 'sum'; use Scalar::Util 'reftype'; use DBI (); use MooseX::Types::Moose qw/Num Int ClassName HashRef/; @@ -323,10 +322,10 @@ is actually connected, try not to hit this 10 times a second. =cut sub connected_replicants { - my $self = shift @_; - return sum( map { - $_->connected ? 1:0 - } $self->all_replicants ); + return scalar grep + { $_->connected } + shift->all_replicants + ; } =head2 active_replicants diff --git a/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm b/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm index 3d054bb19..57687ad6a 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm @@ -4,7 +4,6 @@ use strict; use warnings; use base qw/DBIx::Class::Storage::DBI::UniqueIdentifier/; use mro 'c3'; -use List::Util 'first'; use DBIx::Class::_Util 'dbic_internal_try'; use Try::Tiny; use namespace::clean; @@ -50,8 +49,8 @@ sub _prefetch_autovalues { my $values = $self->next::method(@_); - my $identity_col = - first { $colinfo->{$_}{is_auto_increment} } keys %$colinfo; + my ($identity_col) = + grep { $colinfo->{$_}{is_auto_increment} } keys %$colinfo; # user might have an identity PK without is_auto_increment # diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm index 3d66fa169..204ce124b 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm @@ -11,7 +11,6 @@ use base qw/ use mro 'c3'; use DBIx::Class::Carp; use Scalar::Util qw/blessed weaken/; -use List::Util 'first'; use Sub::Name(); use Try::Tiny; use Context::Preserve 'preserve_context'; @@ -447,10 +446,10 @@ sub update { if (keys %$fields) { # Now set the identity update flags for the actual update - local $self->{_autoinc_supplied_for_op} = (first + local $self->{_autoinc_supplied_for_op} = grep { $_->{is_auto_increment} } values %{ $source->columns_info([ keys %$fields ]) } - ) ? 1 : 0; + ; my $next = $self->next::can; my $args = \@_; @@ -465,10 +464,10 @@ sub update { } else { # Set the identity update flags for the actual update - local $self->{_autoinc_supplied_for_op} = (first + local $self->{_autoinc_supplied_for_op} = grep { $_->{is_auto_increment} } values %{ $source->columns_info([ keys %$fields ]) } - ) ? 1 : 0; + ; return $self->next::method(@_); } @@ -480,17 +479,14 @@ sub _insert_bulk { my $columns_info = $source->columns_info; - my $identity_col = - first { $columns_info->{$_}{is_auto_increment} } + my ($identity_col) = + grep { $columns_info->{$_}{is_auto_increment} } keys %$columns_info; # FIXME - this is duplication from DBI.pm. When refactored towards # the LobWriter this can be folded back where it belongs. - local $self->{_autoinc_supplied_for_op} = - (first { $_ eq $identity_col } @$cols) - ? 1 - : 0 - ; + local $self->{_autoinc_supplied_for_op} + = grep { $_ eq $identity_col } @$cols; my $use_bulk_api = $self->_bulk_storage && @@ -553,7 +549,7 @@ sub _insert_bulk { my @source_columns = $source->columns; # bcp identity index is 1-based - my $identity_idx = first { $source_columns[$_] eq $identity_col } (0..$#source_columns); + my ($identity_idx) = grep { $source_columns[$_] eq $identity_col } (0..$#source_columns); $identity_idx = defined $identity_idx ? $identity_idx + 1 : 0; my @new_data; diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm index ffd72c4be..3ee6cdbef 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE/NoBindVars.pm @@ -8,7 +8,6 @@ use base qw/ DBIx::Class::Storage::DBI::Sybase::ASE /; use mro 'c3'; -use List::Util 'first'; use Scalar::Util 'looks_like_number'; use namespace::clean; @@ -42,7 +41,7 @@ sub interpolate_unquoted { return $self->next::method(@_) if not defined $value or not defined $type; - if (my $key = first { $type =~ /$_/i } keys %noquote) { + if (my ($key) = grep { $type =~ /$_/i } keys %noquote) { return 1 if $noquote{$key}->($value); } elsif ($self->is_datatype_numeric($type) && $number->($value)) { diff --git a/lib/DBIx/Class/Storage/DBI/mysql.pm b/lib/DBIx/Class/Storage/DBI/mysql.pm index 1e76d6bcb..7d0ad04f9 100644 --- a/lib/DBIx/Class/Storage/DBI/mysql.pm +++ b/lib/DBIx/Class/Storage/DBI/mysql.pm @@ -5,8 +5,6 @@ use warnings; use base qw/DBIx::Class::Storage::DBI/; -use namespace::clean; - __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::MySQL'); __PACKAGE__->sql_limit_dialect ('LimitXY'); __PACKAGE__->sql_quote_char ('`'); diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm index e98bc4948..305e7688a 100644 --- a/lib/DBIx/Class/Storage/DBIHacks.pm +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -28,7 +28,6 @@ use warnings; use base 'DBIx::Class::Storage'; use mro 'c3'; -use List::Util 'first'; use Scalar::Util 'blessed'; use DBIx::Class::_Util qw(UNRESOLVABLE_CONDITION serialize dump_value); use SQL::Abstract qw(is_plain_value is_literal_value); @@ -344,7 +343,7 @@ sub _adjust_select_args_for_complex_prefetch { ) { push @outer_from, $j } - elsif (first { $_->{$alias} } @outer_nonselecting_chains ) { + elsif (grep { $_->{$alias} } @outer_nonselecting_chains ) { push @outer_from, $j; $may_need_outer_group_by ||= $outer_aliastypes->{multiplying}{$alias} ? 1 : 0; } diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 09fdfe95a..4ff698de0 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -80,7 +80,6 @@ use B (); use Carp 'croak'; use Storable 'nfreeze'; use Scalar::Util qw(weaken blessed reftype refaddr); -use List::Util qw(first); use Sub::Quote qw(qsub quote_sub); # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone' diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 3965bca12..eb65015b7 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -54,7 +54,6 @@ if [[ "$BREAK_CC" == "true" ]] ; then [[ "$CLEANTEST" != "true" ]] && echo_err "Breaking the compiler without CLEANTEST makes no sense" && exit 1 # FIXME - working around RT#74707, https://metacpan.org/source/DOY/Package-Stash-0.37/Makefile.PL#L112-122 - # List::Util can be excised after that as well (need to make my own max() routine for older perls) # # DEVREL_DEPS means our installer is cpanm, which will respect failures # and the like, so stuff soft-failing (failed deps that are not in fact @@ -63,7 +62,6 @@ if [[ "$BREAK_CC" == "true" ]] ; then # FIXME - the PathTools 3.47 is to work around https://rt.cpan.org/Ticket/Display.html?id=107392 # installdeps Sub::Name Clone Package::Stash::XS \ - $( perl -MList::Util\ 1.16 -e1 &>/dev/null || echo "List::Util" ) \ $( [[ "$DEVREL_DEPS" == "true" ]] && ( perl -MFile::Spec\ 3.13 -e1 &>/dev/null || echo "S/SM/SMUELLER/PathTools-3.47.tar.gz" ) ) \ $( perl -MDBI -e1 &>/dev/null || echo "DBI" ) \ $( perl -MDBD::SQLite -e1 &>/dev/null || echo "DBD::SQLite" ) diff --git a/xt/dist/pod_coverage.t b/xt/dist/pod_coverage.t index 97d497510..a86c4d8fd 100644 --- a/xt/dist/pod_coverage.t +++ b/xt/dist/pod_coverage.t @@ -5,7 +5,6 @@ use warnings; use strict; use Test::More; -use List::Util 'first'; use Module::Runtime 'require_module'; use lib 'maint/.Generated_Pod/lib'; use DBICTest; @@ -167,7 +166,7 @@ foreach my $module (@modules) { SKIP: { my ($match) = - first { $module =~ $_ } + grep { $module =~ $_ } (sort { length $b <=> length $a || $b cmp $a } (keys %$ex_lookup) ) ; From f967004237e287bab2d2b05401dcff06d89ad4b8 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 12 Apr 2016 16:25:58 +0200 Subject: [PATCH 063/262] Fix forgotten finally{} in Sybase::ASE (missed in ddcc02d14) I guess my grep-fu failed me, the finally is right there... As per the comment nothing seems to fail if I just remove this, but ASE is so fragile that I'll just play it safe... --- lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm index 204ce124b..a6ff2c7be 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm @@ -14,7 +14,7 @@ use Scalar::Util qw/blessed weaken/; use Sub::Name(); use Try::Tiny; use Context::Preserve 'preserve_context'; -use DBIx::Class::_Util qw( sigwarn_silencer dbic_internal_try dump_value ); +use DBIx::Class::_Util qw( sigwarn_silencer dbic_internal_try dump_value scope_guard ); use namespace::clean; __PACKAGE__->sql_limit_dialect ('GenericSubQ'); @@ -780,6 +780,12 @@ sub _insert_blobs { ); } + # FIXME - it is not clear if this is needed at all. But it's been + # there since 2009 ( d867eedaa ), might as well let sleeping dogs + # lie... sigh. + weaken( my $wsth = $sth ); + my $g = scope_guard { $wsth->finish if $wsth }; + dbic_internal_try { do { $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr; @@ -808,9 +814,6 @@ sub _insert_blobs { else { $self->throw_exception($_); } - } - finally { - $sth->finish if $sth; }; } } From 8b16ef4e820ac2e747bbb639614bd9405c6b735c Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 12 Apr 2016 16:28:25 +0200 Subject: [PATCH 064/262] Fix t/746sybase.t failing under -T --- t/746sybase.t | 2 ++ 1 file changed, 2 insertions(+) diff --git a/t/746sybase.t b/t/746sybase.t index 818ed26a9..74587afef 100644 --- a/t/746sybase.t +++ b/t/746sybase.t @@ -5,6 +5,7 @@ use strict; use warnings; no warnings 'uninitialized'; +use Config; use Test::More; use Test::Exception; use DBIx::Class::_Util 'sigwarn_silencer'; @@ -627,6 +628,7 @@ if (Test::Builder->new->is_passing and $ENV{LC_ALL} and $ENV{LC_ALL} ne 'C') { local $ENV{DBICTEST_SYBASE_SUBTEST_RERUN} = 1; local $ENV{PATH}; + local $ENV{PERL5LIB} = join ($Config{path_sep}, @INC); my @cmd = map { $_ =~ /(.+)/ } ($^X, __FILE__); # this is cheating, and may even hang here and there (testing on windows passed fine) From 11f335cd8c3310770f6c8d0724a54dd528119734 Mon Sep 17 00:00:00 2001 From: Tina Mueller Date: Fri, 14 Aug 2015 13:51:53 +0200 Subject: [PATCH 065/262] Add a proof of concept test for copy() with assymetric IC::DT What a mess. The core of the problem is that some of our IC::DT in/deflator pairs are *not* symmetric. That is for things to roundtrip one needs values to pass through the database, which is configured "just properly wrong" to perform the second half of this evil dance. Of course this break copy() and likely other things I do not know about. Given there is nothing one can do about the core problem (huge install base) a minimally invasive workaround has been devised and tested here. Refer to `git show 993fa9b | perl -ne 'print if 110..134'` for the exact snippet you need to place in your base result class to make everything work again. This is terrible. -- ribasushi For completeness: here is a full list of individual inflators (as of Apr 2016) and which ones are broken beyond repair: ACCESS 2016-04-13 07:42:58 2016-04-13T07:42:58 2016-04-13 07:42:58 (via DateTime::Format::MySQL) DB2 2016-04-13-07.42.58 2016-04-13T07:42:58 2016-04-13-07.42.58 (via DateTime::Format::DB2) MSSQL 2016-04-13 07:42:58.000 2016-04-13T07:42:58 2016-04-13 07:42:58.000 (via DBIx::Class::Storage::DBI::MSSQL::DateTime::Format) Pg 2016-04-13 07:42:58+0000 2016-04-13T07:42:58 2016-04-13 07:42:58+0000 (via DateTime::Format::Pg) ADO 2016-04-13 07:42:58 2016-04-13T07:42:58 2016-04-13 07:42:58 (via DateTime::Format::MySQL) NoBindVars 2016-04-13 07:42:58 2016-04-13T07:42:58 2016-04-13 07:42:58 (via DateTime::Format::MySQL) SQLAnywhere 2016-04-13 07:42:58.000000 2016-04-13T07:42:58 2016-04-13 07:42:58.000000 (via DateTime::Format::Strptime) AutoCast 2016-04-13 07:42:58 2016-04-13T07:42:58 2016-04-13 07:42:58 (via DateTime::Format::MySQL) Firebird 2016-04-13 07:42:58.0000 2016-04-13T07:42:58 2016-04-13 07:42:58.0000 (via DBIx::Class::Storage::DBI::InterBase::DateTime::Format) Informix 2016-04-13 07:42:58.00000 2016-04-13T07:42:58 2016-04-13 07:42:58.00000 (via DBIx::Class::Storage::DBI::Informix::DateTime::Format) ODBC 2016-04-13 07:42:58 2016-04-13T07:42:58 2016-04-13 07:42:58 (via DateTime::Format::MySQL) Sybase 2016-04-13 07:42:58 2016-04-13T07:42:58 2016-04-13 07:42:58 (via DateTime::Format::MySQL) mysql 2016-04-13 07:42:58 2016-04-13T07:42:58 2016-04-13 07:42:58 (via DateTime::Format::MySQL) InterBase 2016-04-13 07:42:58.0000 2016-04-13T07:42:58 2016-04-13 07:42:58.0000 (via DBIx::Class::Storage::DBI::InterBase::DateTime::Format) Oracle 2016-04-13 07:42:58 2016-04-13T07:42:58 2016-04-13 07:42:58 (via DateTime::Format::MySQL) SQLite 2016-04-13 07:42:58 2016-04-13T07:42:58 2016-04-13 07:42:58 (via DateTime::Format::SQLite) Firebird::Common 2016-04-13 07:42:58.0000 2016-04-13T07:42:58 2016-04-13 07:42:58.0000 (via DBIx::Class::Storage::DBI::InterBase::DateTime::Format) Sybase::FreeTDS 2016-04-13 07:42:58 2016-04-13T07:42:58 2016-04-13 07:42:58 (via DateTime::Format::MySQL) Sybase::MSSQL 2016-04-13 07:42:58.000 Your datetime does not match your pattern. at (via DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::DateTime::Format) Sybase::Microsoft_SQL_Server 2016-04-13 07:42:58.000 Your datetime does not match your pattern. at (via DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::DateTime::Format) Sybase::ASE 04/13/2016 07:42:58.000 Your datetime does not match your pattern. at (via DBIx::Class::Storage::DBI::Sybase::ASE::DateTime::Format) Sybase::Microsoft_SQL_Server::NoBindVars 2016-04-13 07:42:59.000 Your datetime does not match your pattern. at (via DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::DateTime::Format) Sybase::ASE::NoBindVars 04/13/2016 07:42:59.000 Your datetime does not match your pattern. at (via DBIx::Class::Storage::DBI::Sybase::ASE::DateTime::Format) Oracle::WhereJoins 2016-04-13 07:42:59 2016-04-13T07:42:59 2016-04-13 07:42:59 (via DateTime::Format::Oracle) Oracle::Generic 2016-04-13 07:42:59 2016-04-13T07:42:59 2016-04-13 07:42:59 (via DateTime::Format::Oracle) ODBC::ACCESS 2016-04-13 07:42:59 2016-04-13T07:42:59 2016-04-13 07:42:59 (via DBIx::Class::Storage::DBI::ODBC::ACCESS::DateTime::Format) ODBC::DB2_400_SQL 2016-04-13-07.42.59 2016-04-13T07:42:59 2016-04-13-07.42.59 (via DateTime::Format::DB2) ODBC::SQL_Anywhere 2016-04-13 07:42:59.000000 2016-04-13T07:42:59 2016-04-13 07:42:59.000000 (via DateTime::Format::Strptime) ODBC::Firebird 2016-04-13 07:42:59.0000 2016-04-13T07:42:59 2016-04-13 07:42:59.0000 (via DBIx::Class::Storage::DBI::InterBase::DateTime::Format) ODBC::Microsoft_SQL_Server 2016-04-13 07:42:59.000 2016-04-13T07:42:59 2016-04-13 07:42:59.000 (via DBIx::Class::Storage::DBI::MSSQL::DateTime::Format) ADO::MS_Jet 04/13/2016 07:42:59 AM 2016-04-13T07:42:59 04/13/2016 07:42:59 AM (via DBIx::Class::Storage::DBI::ADO::MS_Jet::DateTime::Format) ADO::Microsoft_SQL_Server 04/13/2016 07:42:59 AM 2016-04-13T07:42:59 04/13/2016 07:42:59 AM (via DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::DateTime::Format) ... and the program that produces the above ... ~$ perl -I lib -MDateTime -MFile::Find -e ' find({ no_chdir => 1, follow_fast => 1, wanted => sub { -f _ or next; $_ =~ m{DBIx/Class/Storage/DBI/(?!Replicated|IdentityInsert|.*?Cursor|UniqueIdentifier)(.+)\.pm} or next; list_dt_state($1); }}, "lib" ); sub list_dt_state { ( my $id = shift ) =~ s|/|::|g; my $s = "DBIx::Class::Storage::DBI::$id"; my $p = eval "local \$SIG{__WARN__} = sub {}; require $s; $s->build_datetime_parser" or ( printf "%s: %s\n", $id, substr $@, 0, 45 and next ); my $as_string = $p->format_datetime( DateTime->now ); my $half_trip = eval { $p->parse_datetime( $as_string ) } || substr $@, 0, 45; my $full_trip = $@ ? "" : eval { $p->format_datetime( $half_trip ) } || substr $@, 0, 45; printf "%-30s %-26s %-20s %-26s (via %s)\n", $id, $as_string, $half_trip, $full_trip, ( ref $p || $p ), ; } ' --- Changes | 2 ++ t/icdt/engine_specific/sybase.t | 43 ++++++++++++++++++++++++++++++++- 2 files changed, 44 insertions(+), 1 deletion(-) diff --git a/Changes b/Changes index 2fc18e9e9..9f8ec8594 100644 --- a/Changes +++ b/Changes @@ -62,6 +62,8 @@ Revision history for DBIx::Class autoinc value when inserting rows containing blobs (GH#82) * Misc + - Add explicit test for pathological example of asymmetric IC::DT setup + working with copy() in t/icdt/engine_specific/sybase.t (GH#84) - Fix invalid variable names in ResultSource::View examples - Typo fixes from downstream debian packagers (RT#112007) - Skip tests in a way more intelligent and speedy manner when optional diff --git a/t/icdt/engine_specific/sybase.t b/t/icdt/engine_specific/sybase.t index 72a8bdb9c..993fa9bce 100644 --- a/t/icdt/engine_specific/sybase.t +++ b/t/icdt/engine_specific/sybase.t @@ -7,6 +7,7 @@ use warnings; use Test::More; use Test::Exception; use DBIx::Class::_Util 'scope_guard'; +use Sub::Name; use DBICTest; @@ -94,7 +95,7 @@ SQL %$create_extra, })); ok( $row = $schema->resultset($source) - ->search({ $pk => $row->$pk }, { select => [$col] }) + ->search({ $pk => $row->$pk }, { select => [$pk, $col] }) ->first ); is( $row->$col, $dt, "$type roundtrip" ); @@ -102,6 +103,46 @@ SQL cmp_ok( $row->$col->nanosecond, '==', $sample_dt->{nanosecond}, 'DateTime fractional portion roundtrip' ) if exists $sample_dt->{nanosecond}; + + # Testing an ugly half-solution + # + # copy() uses get_columns() + # + # The values should survive a roundtrip also, but they don't + # because the Sybase ICDT setup is asymmetric + # One *has* to force an inflation/deflation cycle to make the + # values usable to the database + # + # This can be done by marking the columns as dirty, and there + # are tests for this already in t/inflate/serialize.t + # + # But even this isn't enough - one has to reload the RDBMS-formatted + # values once done, otherwise the copy is just as useless... sigh + # + # Adding the test here to validate the technique works + # UGH! + { + no warnings 'once'; + local *DBICTest::BaseResult::copy = subname 'DBICTest::BaseResult::copy' => sub { + my $self = shift; + + $self->make_column_dirty($_) for keys %{{ $self->get_inflated_columns }}; + + my $cp = $self->next::method(@_); + + $cp->discard_changes({ columns => [ keys %{{ $cp->get_columns }} ] }); + }; + Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; + + my $cp = $row->copy; + ok( $cp->in_storage ); + is( $cp->$col, $dt, "$type copy logical roundtrip" ); + + $cp->discard_changes({ select => [ $pk, $col ] }); + is( $cp->$col, $dt, "$type copy server roundtrip" ); + } + + Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; } # test a computed datetime column From ef25a42942e8454e0285a9f42a567327fbd96496 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 13 Apr 2016 19:43:30 +0200 Subject: [PATCH 066/262] Fix thinko from 10dd5c05 - make sure we actually sleep Under very tight concurrency it is possible that the test will not be given sufficient timeshare before the scheduled 'point in the future', which would result in us asking Time::HiRes to sleep for a negative amount of time, which it "helpfully" converts to an obnoxious exception. --- t/50fork.t | 3 ++- t/51threads.t | 3 ++- t/51threadtxn.t | 3 ++- xt/extra/internals/ithread_stress.t | 3 ++- 4 files changed, 8 insertions(+), 4 deletions(-) diff --git a/t/50fork.t b/t/50fork.t index 244bf2af6..229a4f249 100644 --- a/t/50fork.t +++ b/t/50fork.t @@ -6,6 +6,7 @@ use warnings; use Test::More; use Test::Exception; use Time::HiRes qw(time sleep); +use List::Util 'max'; use DBICTest; @@ -107,7 +108,7 @@ while(@pids < $num_children) { $pid = $$; - sleep ( $t - time ); + sleep( max( 0.1, $t - time ) ); note ("Child process $pid starting work at " . time() ); my $work = sub { diff --git a/t/51threads.t b/t/51threads.t index be0b1d670..d5cd0d5bc 100644 --- a/t/51threads.t +++ b/t/51threads.t @@ -22,6 +22,7 @@ use warnings; use Test::More; use Test::Exception; use Time::HiRes qw(time sleep); +use List::Util 'max'; plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' if "$]" < 5.008005; @@ -115,7 +116,7 @@ while(@children < $num_children) { my $newthread = async { my $tid = threads->tid; - sleep ($t - time); + sleep( max( 0.1, $t - time ) ); # FIXME if we do not stagger the threads, sparks fly due to CXSA sleep ( $tid / 10 ) if "$]" < 5.012; diff --git a/t/51threadtxn.t b/t/51threadtxn.t index 52a6966e2..6c781e562 100644 --- a/t/51threadtxn.t +++ b/t/51threadtxn.t @@ -29,6 +29,7 @@ plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' use Scalar::Util 'weaken'; use Time::HiRes qw(time sleep); +use List::Util 'max'; use DBICTest; @@ -70,7 +71,7 @@ while(@children < $num_children) { my $newthread = async { my $tid = threads->tid; - sleep ($t - time); + sleep( max( 0.1, $t - time ) ); # FIXME if we do not stagger the threads, sparks fly due to CXSA sleep ( $tid / 10 ) if "$]" < 5.012; diff --git a/xt/extra/internals/ithread_stress.t b/xt/extra/internals/ithread_stress.t index c1d46f2a8..0b1602f67 100644 --- a/xt/extra/internals/ithread_stress.t +++ b/xt/extra/internals/ithread_stress.t @@ -54,6 +54,7 @@ use Test::More; use Errno (); use DBIx::Class::_Util 'sigwarn_silencer'; use Time::HiRes qw(time sleep); +use List::Util 'max'; # README: If you set the env var to a number greater than 5, # we will use that many children @@ -78,7 +79,7 @@ SKIP: { push @threads, threads->create(sub { my $tid = threads->tid; - sleep ($t - time); + sleep( max( 0.1, $t - time ) ); note ("Thread $tid starting work at " . time() ); my $rsrc = $schema->source('Artist'); From 29211e0358e2a7dbd69f68c1e10879c05fd8cdcc Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 14 Apr 2016 09:19:15 +0200 Subject: [PATCH 067/262] Add a weaken() cycle forgotten in d63c9e64 The reason this has not been a problem is because thread spawn in DESTROY is practically unheard of. Nevertheless if one throws the following in, the problem becomes apparent: ( not committing this test, because... just no. ) --- a/t/storage/txn_scope_guard.t +++ b/t/storage/txn_scope_guard.t @@ -247,5 +247,7 @@ require DBICTest::AntiPattern::NullObject; my @arg_capture; { + use threads; local $SIG{__WARN__} = sub { + threads->new(sub { sleep 1})->join; package DB; --- lib/DBIx/Class/_Util.pm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 4ff698de0..6f6ac4650 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -366,6 +366,9 @@ sub is_exception ($) { values %$destruction_registry }; + weaken( $destruction_registry->{$_} ) + for keys %$destruction_registry; + # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage # collected before leaving this scope. Depending on the code above, this # may very well be just a preventive measure guarding future modifications From f03d3e5d811528804fb55d900eff059760b8b8cc Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 14 Apr 2016 10:34:30 +0200 Subject: [PATCH 068/262] Remove one level of indirection in Versioned on_connect No functional changes --- lib/DBIx/Class/Schema/Versioned.pm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/DBIx/Class/Schema/Versioned.pm b/lib/DBIx/Class/Schema/Versioned.pm index c1553601d..eb4fe6515 100644 --- a/lib/DBIx/Class/Schema/Versioned.pm +++ b/lib/DBIx/Class/Schema/Versioned.pm @@ -589,10 +589,10 @@ sub _on_connect { my ($self) = @_; - weaken (my $w_self = $self ); + weaken (my $w_storage = $self->storage ); - $self->{vschema} = DBIx::Class::Version->connect(sub { $w_self->storage->dbh }); - my $conn_attrs = $self->storage->_dbic_connect_attributes || {}; + $self->{vschema} = DBIx::Class::Version->connect(sub { $w_storage->dbh }); + my $conn_attrs = $w_storage->_dbic_connect_attributes || {}; my $vtable = $self->{vschema}->resultset('Table'); @@ -601,11 +601,11 @@ sub _on_connect # check for legacy versions table and move to new if exists unless ($self->_source_exists($vtable)) { - my $vtable_compat = DBIx::Class::VersionCompat->connect(sub { $w_self->storage->dbh })->resultset('TableCompat'); + my $vtable_compat = DBIx::Class::VersionCompat->connect(sub { $w_storage->dbh })->resultset('TableCompat'); if ($self->_source_exists($vtable_compat)) { $self->{vschema}->deploy; map { $vtable->new_result({ installed => $_->Installed, version => $_->Version })->insert } $vtable_compat->all; - $self->storage->_get_dbh->do("DROP TABLE " . $vtable_compat->result_source->from); + $w_storage->_get_dbh->do("DROP TABLE " . $vtable_compat->result_source->from); } } From e7dcdf69fd96a9a50696607171defaf03075592f Mon Sep 17 00:00:00 2001 From: Fabrice Gabolde Date: Wed, 13 Apr 2016 15:42:38 +0200 Subject: [PATCH 069/262] Proxy the 'unsafe' attribute to the internal ::Versioned storage --- Changes | 2 ++ lib/DBIx/Class/Schema/Versioned.pm | 7 ++++++- t/94versioning.t | 29 +++++++++++++++++++++++++++++ 3 files changed, 37 insertions(+), 1 deletion(-) diff --git a/Changes b/Changes index 9f8ec8594..f71dec55c 100644 --- a/Changes +++ b/Changes @@ -51,6 +51,8 @@ Revision history for DBIx::Class - Fix spurious ROLLBACK statements when a TxnScopeGuard fails a commit of a transaction with deferred FK checks: a guard is now inactivated immediately before the commit is attempted (RT#107159) + - Fix use of ::Schema::Versioned combined with a user-supplied + $dbh->{HandleError} (GH#101) - Fix spurious warning on MSSQL cursor invalidation retries (RT#102166) - Fix parsing of DSNs containing driver arguments (GH#99) - Work around unreliable $sth->finish() on INSERT ... RETURNING within diff --git a/lib/DBIx/Class/Schema/Versioned.pm b/lib/DBIx/Class/Schema/Versioned.pm index eb4fe6515..013cbc4f3 100644 --- a/lib/DBIx/Class/Schema/Versioned.pm +++ b/lib/DBIx/Class/Schema/Versioned.pm @@ -591,7 +591,12 @@ sub _on_connect weaken (my $w_storage = $self->storage ); - $self->{vschema} = DBIx::Class::Version->connect(sub { $w_storage->dbh }); + $self->{vschema} = DBIx::Class::Version->connect( + sub { $w_storage->dbh }, + + # proxy some flags from the main storage + { map { $_ => $w_storage->$_ } qw( unsafe ) }, + ); my $conn_attrs = $w_storage->_dbic_connect_attributes || {}; my $vtable = $self->{vschema}->resultset('Table'); diff --git a/t/94versioning.t b/t/94versioning.t index ab9d2613e..117f02a51 100644 --- a/t/94versioning.t +++ b/t/94versioning.t @@ -281,6 +281,35 @@ is ), 3, "Expected number of connections at end of script" ; +# Test custom HandleError setting on an in-memory instance +{ + my $custom_handler = sub { die $_[0] }; + + # try to setup a custom error handle without unsafe set -- should + # fail, same behavior as regular Schema + throws_ok { + DBICVersion::Schema->connect( 'dbi:SQLite::memory:', undef, undef, { + HandleError => $custom_handler, + ignore_version => 1, + })->deploy; + } + qr/Refusing clobbering of \{HandleError\} installed on externally supplied DBI handle/, + 'HandleError with unsafe not set causes an exception' + ; + + # now try it with unsafe set -- should work (see RT #113741) + my $s = DBICVersion::Schema->connect( 'dbi:SQLite::memory:', undef, undef, { + unsafe => 1, + HandleError => $custom_handler, + ignore_version => 1, + }); + + $s->deploy; + + is $s->storage->dbh->{HandleError}, $custom_handler, 'Handler properly set on main schema'; + is $s->{vschema}->storage->dbh->{HandleError}, $custom_handler, 'Handler properly set on version subschema'; +} + END { rm_rf $ddl_dir unless $ENV{DBICTEST_KEEP_VERSIONING_DDL}; } From d098704fa2e7e92b3a6cdf0a251f3e725623f9a4 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 14 Apr 2016 14:56:00 +0200 Subject: [PATCH 070/262] Slightly golf ::ResultSource::DESTROY and several weaken() calls No functional changes --- lib/DBIx/Class/ResultSet.pm | 2 +- lib/DBIx/Class/ResultSource.pm | 13 +++++++++---- lib/DBIx/Class/Storage/TxnScopeGuard.pm | 8 +++----- lib/DBIx/Class/_Util.pm | 16 ++++++++-------- 4 files changed, 21 insertions(+), 18 deletions(-) diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index b51e05cbc..0b1f9fab3 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -6,7 +6,7 @@ use base qw/DBIx::Class/; use DBIx::Class::Carp; use DBIx::Class::ResultSetColumn; use DBIx::Class::ResultClass::HashRefInflator; -use Scalar::Util qw/blessed weaken reftype/; +use Scalar::Util qw( blessed reftype ); use DBIx::Class::_Util qw( dbic_internal_try dump_value fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 847cecb98..6fd80d7fb 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -2366,10 +2366,15 @@ sub DESTROY { # if schema is still there reintroduce ourselves with strong refs back to us if ($_[0]->{schema}) { my $srcregs = $_[0]->{schema}->source_registrations; - for (keys %$srcregs) { - next unless $srcregs->{$_}; - $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0]; - } + + defined $srcregs->{$_} + and + $srcregs->{$_} == $_[0] + and + $srcregs->{$_} = $_[0] + and + last + for keys %$srcregs; } 1; diff --git a/lib/DBIx/Class/Storage/TxnScopeGuard.pm b/lib/DBIx/Class/Storage/TxnScopeGuard.pm index 31a2d5bea..f961c4e44 100644 --- a/lib/DBIx/Class/Storage/TxnScopeGuard.pm +++ b/lib/DBIx/Class/Storage/TxnScopeGuard.pm @@ -26,11 +26,9 @@ sub new { # # Deliberately *NOT* using is_exception - if someone left a misbehaving # antipattern value in $@, it's not our business to whine about it - if( defined $@ and length $@ ) { - weaken( - $guard->{existing_exception_ref} = (length ref $@) ? $@ : \$@ - ); - } + weaken( + $guard->{existing_exception_ref} = (length ref $@) ? $@ : \$@ + ) if( defined $@ and length $@ ); $storage->txn_begin; diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 6f6ac4650..be899eeb1 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -361,13 +361,13 @@ sub is_exception ($) { my $destruction_registry = {}; sub CLONE { - $destruction_registry = { map - { defined $_ ? ( refaddr($_) => $_ ) : () } - values %$destruction_registry - }; + %$destruction_registry = map { + (defined $_) + ? ( refaddr($_) => $_ ) + : () + } values %$destruction_registry; - weaken( $destruction_registry->{$_} ) - for keys %$destruction_registry; + weaken($_) for values %$destruction_registry; # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage # collected before leaving this scope. Depending on the code above, this @@ -553,8 +553,8 @@ sub mkdir_p ($) { ), 'with_stacktrace'); } - my $mark = []; - weaken ( $list_ctx_ok_stack_marker = $mark ); + weaken( $list_ctx_ok_stack_marker = my $mark = [] ); + $mark; } } From 7cdad662d84d7987b5ebfb7d132b78005878fb8a Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 15 Dec 2015 22:30:10 +0100 Subject: [PATCH 071/262] This was commented out in 2008 (5b0b4df8) and never used --- lib/DBIx/Class/Schema.pm | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index f8179fb65..fc9c49932 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -865,25 +865,6 @@ will produce the output =cut -# this might be oversimplified -# sub compose_namespace { -# my ($self, $target, $base) = @_; - -# my $schema = $self->clone; -# foreach my $source_name ($schema->sources) { -# my $source = $schema->source($source_name); -# my $target_class = "${target}::${source_name}"; -# $self->inject_base( -# $target_class => $source->result_class, ($base ? $base : ()) -# ); -# $source->result_class($target_class); -# $target_class->result_source_instance($source) -# if $target_class->can('result_source_instance'); -# $schema->register_source($source_name, $source); -# } -# return $schema; -# } - sub compose_namespace { my ($self, $target, $base) = @_; From 5567c8f84ba0c2d620191cc8ac956b0b5630ca00 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 15 Dec 2015 23:22:51 +0100 Subject: [PATCH 072/262] Reduce duplicate ->result_source calls where sensible No functional changes --- lib/DBIx/Class/Ordered.pm | 11 ++++++----- lib/DBIx/Class/Relationship/Accessor.pm | 6 ++++-- lib/DBIx/Class/ResultSet.pm | 13 +++++++------ lib/DBIx/Class/Row.pm | 12 +++++++----- 4 files changed, 24 insertions(+), 18 deletions(-) diff --git a/lib/DBIx/Class/Ordered.pm b/lib/DBIx/Class/Ordered.pm index 8b84bd4e4..0c572e8c4 100644 --- a/lib/DBIx/Class/Ordered.pm +++ b/lib/DBIx/Class/Ordered.pm @@ -364,8 +364,10 @@ sub move_to { my $position_column = $self->position_column; + my $rsrc = $self->result_source; + my $is_txn; - if ($is_txn = $self->result_source->schema->storage->transaction_depth) { + if ($is_txn = $rsrc->schema->storage->transaction_depth) { # Reload position state from storage # The thinking here is that if we are in a transaction, it is # *more likely* the object went out of sync due to resultset @@ -375,8 +377,7 @@ sub move_to { $self->store_column( $position_column, - ( $self->result_source - ->resultset + ( $rsrc->resultset ->search($self->_storage_ident_condition, { rows => 1, columns => $position_column }) ->cursor ->next @@ -400,7 +401,7 @@ sub move_to { return 0; } - my $guard = $is_txn ? undef : $self->result_source->schema->txn_scope_guard; + my $guard = $is_txn ? undef : $rsrc->schema->txn_scope_guard; my ($direction, @between); if ( $from_position < $to_position ) { @@ -415,7 +416,7 @@ sub move_to { my $new_pos_val = $self->_position_value ($to_position); # record this before the shift # we need to null-position the moved row if the position column is part of a constraint - if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $self->result_source->unique_constraints }} ) ) ) { + if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) { $self->_ordered_internal_update({ $position_column => $self->null_position_value }); } diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index 40deeafa4..e34294d1d 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -35,7 +35,9 @@ sub add_relationship_accessor { return $self->{_relationship_data}{%1$s}; } else { - my $relcond = $self->result_source->_resolve_relationship_condition( + my $rsrc = $self->result_source; + + my $relcond = $rsrc->_resolve_relationship_condition( rel_name => %1$s, foreign_alias => %1$s, self_alias => 'me', @@ -49,7 +51,7 @@ sub add_relationship_accessor { and scalar grep { not defined $_ } values %%{ $relcond->{join_free_condition} || {} } and - $self->result_source->relationship_info(%1$s)->{attrs}{undef_on_null_fk} + $rsrc->relationship_info(%1$s)->{attrs}{undef_on_null_fk} ); my $val = $self->search_related( %1$s )->single; diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 0b1f9fab3..9030712a4 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -838,7 +838,7 @@ sub find { if (defined $constraint_name) { $final_cond = $self->_qualify_cond_columns ( - $self->result_source->_minimal_valueset_satisfying_constraint( + $rsrc->_minimal_valueset_satisfying_constraint( constraint_name => $constraint_name, values => ($self->_merge_with_rscond($call_cond))[0], carp_on_nulls => 1, @@ -875,10 +875,10 @@ sub find { dbic_internal_try { push @unique_queries, $self->_qualify_cond_columns( - $self->result_source->_minimal_valueset_satisfying_constraint( + $rsrc->_minimal_valueset_satisfying_constraint( constraint_name => $c_name, values => ($self->_merge_with_rscond($call_cond))[0], - columns_info => ($ci ||= $self->result_source->columns_info), + columns_info => ($ci ||= $rsrc->columns_info), ), $alias ); @@ -2215,6 +2215,8 @@ sub populate { # FIXME - no cref handling # At this point assume either hashes or arrays + my $rsrc = $self->result_source; + if(defined wantarray) { my (@results, $guard); @@ -2222,7 +2224,7 @@ sub populate { # column names only, nothing to do return if @$data == 1; - $guard = $self->result_source->schema->storage->txn_scope_guard + $guard = $rsrc->schema->storage->txn_scope_guard if @$data > 2; @results = map @@ -2232,7 +2234,7 @@ sub populate { } else { - $guard = $self->result_source->schema->storage->txn_scope_guard + $guard = $rsrc->schema->storage->txn_scope_guard if @$data > 1; @results = map { $self->new_result($_)->insert } @$data; @@ -2246,7 +2248,6 @@ sub populate { # this means we have to walk the data structure twice # whether we want this or not # jnap, I hate you ;) - my $rsrc = $self->result_source; my $rel_info = { map { $_ => $rsrc->relationship_info($_) } $rsrc->relationships }; my ($colinfo, $colnames, $slices_with_rels); diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index c8b57b696..8ce93108e 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -372,8 +372,7 @@ sub insert { my $existing; # if there are no keys - nothing to search for - if (keys %$them and $existing = $self->result_source - ->related_source($rel_name) + if (keys %$them and $existing = $rsrc->related_source($rel_name) ->resultset ->find($them) ) { @@ -891,15 +890,18 @@ sub get_inflated_columns { sub _is_column_numeric { my ($self, $column) = @_; - return undef unless $self->result_source->has_column($column); + my $rsrc; - my $colinfo = $self->result_source->column_info ($column); + return undef + unless ( $rsrc = $self->result_source )->has_column($column); + + my $colinfo = $rsrc->column_info ($column); # cache for speed (the object may *not* have a resultsource instance) if ( ! defined $colinfo->{is_numeric} and - my $storage = dbic_internal_try { $self->result_source->schema->storage } + my $storage = dbic_internal_try { $rsrc->schema->storage } ) { $colinfo->{is_numeric} = $storage->is_datatype_numeric ($colinfo->{data_type}) From 78de6edd28ca54c3025eb1b7407f2cb43865ce18 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 8 Apr 2016 16:36:22 +0200 Subject: [PATCH 073/262] Augment the infinite loop fix 4f52479b with the infra of ddcc02d1 This also fixes a manifestation (but not the cause, this comes later) of a bug where $result->result_source != $result->result_source_instance. This commit is made early as it is rather efficient anyway, and it allows me to test Handel (which was broken by 4f52479b) to validate subsequent rsrc rewritering --- lib/DBIx/Class/Row.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 8ce93108e..5c4cead70 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -1585,9 +1585,9 @@ sub throw_exception { my $self=shift; if ( - ref $self + ! DBIx::Class::_Util::in_internal_try and - my $rsrc = dbic_internal_try { $self->result_source_instance } + my $rsrc = dbic_internal_try { $self->result_source } ) { $rsrc->throw_exception(@_) } From 1e0233457be7f60bc0a35a4913eecd7f7b7b15e8 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 20 Apr 2016 12:31:23 +0200 Subject: [PATCH 074/262] Fix obscure failure of CDBICompat accessor install on 5.8 CDBICompat has a bizarre override of the CAG logic, in a way that only works reliably at compiletime due to Class::C3 "cache" slots A test implicitly starts covering this failcase once Class::Data::Inheritable is removed sever commits later --- lib/DBIx/Class/CDBICompat/ColumnGroups.pm | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm index f4c8ac80a..44a60107b 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm @@ -83,7 +83,23 @@ sub _register_column_group { no strict 'refs'; my $existing_accessor = *{$class .'::'. $name}{CODE}; - return $existing_accessor && !$our_accessors{$existing_accessor}; + + return( + defined $existing_accessor + and + ! $our_accessors{$existing_accessor} + and + # under 5.8 mro the CODE slot may simply be a "cached method" + ! ( + DBIx::Class::_ENV_::OLD_MRO + and + grep { + $_ ne $class + and + ($_->can($name)||0) == $existing_accessor + } @{mro::get_linear_isa($class)} + ) + ) } sub _deploy_accessor { From cb421b66e82092e8fab0ed3a002061f7a4b9a641 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 20 Apr 2016 08:02:29 +0200 Subject: [PATCH 075/262] Reorder a couple stray loads in ResultSource.pm --- lib/DBIx/Class/ResultSource.pm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 6fd80d7fb..b6fb310da 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -5,9 +5,6 @@ use warnings; use base qw/DBIx::Class::ResultSource::RowParser DBIx::Class/; -use DBIx::Class::ResultSet; -use DBIx::Class::ResultSourceHandle; - use DBIx::Class::Carp; use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try ); use SQL::Abstract 'is_literal_value'; @@ -2318,6 +2315,7 @@ relationship definitions. =cut sub handle { + require DBIx::Class::ResultSourceHandle; return DBIx::Class::ResultSourceHandle->new({ source_moniker => $_[0]->source_name, From d009cb7d393292037eff527a9f8bab93860224fb Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 19 Apr 2016 14:13:03 +0200 Subject: [PATCH 076/262] Start setting the 'c3' mro unambiguously everywhere This is a necessary part of the rsrc refactor, which there is no way around. And yes - it is extremely invasive and dangerous, with very high chance of fallout. Given the situation there is no other way :/ The implementation itself is rather simple: all we need to do is hook inject_base (which is called by load_components via several levels of indirection), and also (as a precaution) we set the mro on anything loaded via a component-group accessor. This seems to nicely cover pretty much all of the hierarchy (except ::Storage, but that is another matter/rewrite) Also move the CAG compat pieces where they belong --- Changes | 5 +++ lib/DBIx/Class.pm | 20 +++++---- lib/DBIx/Class/AccessorGroup.pm | 12 ++++++ lib/DBIx/Class/ResultSet.pm | 5 ++- lib/DBIx/Class/ResultSource.pm | 5 ++- lib/DBIx/Class/ResultSourceProxy.pm | 1 + lib/DBIx/Class/Schema.pm | 1 + xt/dist/pod_coverage.t | 1 + xt/extra/c3_mro.t | 67 +++++++++++++++++++++++++---- 9 files changed, 98 insertions(+), 19 deletions(-) diff --git a/Changes b/Changes index f71dec55c..318a4b2f4 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,11 @@ Revision history for DBIx::Class * Notable Changes and Deprecations + - The entire class hierarchy now explicitly sets the 'c3' mro, even + in cases where load_components was not used. Extensive testing led + the maintainer believe this is safe, but this is a very complex + area and reality may turn out to be different. If **ANYHTING** at + all seems out of place, please file a report at once - Neither exception_action() nor $SIG{__DIE__} handlers are invoked on recoverable errors. This ensures that the retry logic is fully insulated from changes in control flow, as the handlers are only diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index cec52f755..79d763081 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -37,17 +37,19 @@ BEGIN { sub DESTROY { &DBIx::Class::_Util::detected_reinvoked_destructor }; } -sub mk_classdata { - shift->mk_classaccessor(@_); -} +sub component_base_class { 'DBIx::Class' } -sub mk_classaccessor { - my $self = shift; - $self->mk_group_accessors('inherited', $_[0]); - $self->set_inherited(@_) if @_ > 1; -} +my $mro_already_set; +sub inject_base { -sub component_base_class { 'DBIx::Class' } + # only examine from $_[2] onwards + # C::C3::C already sets c3 on $_[1] and $_[0] is irrelevant + mro::set_mro( $_ => 'c3' ) for grep { + $mro_already_set->{$_} ? 0 : ( $mro_already_set->{$_} = 1 ) + } @_[2 .. $#_]; + + shift->next::method(@_); +} sub MODIFY_CODE_ATTRIBUTES { my ($class,$code,@attrs) = @_; diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index ea25e4f79..12a8744b2 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -7,6 +7,16 @@ use base qw/Class::Accessor::Grouped/; use Scalar::Util qw/weaken blessed/; use namespace::clean; +sub mk_classdata { + shift->mk_classaccessor(@_); +} + +sub mk_classaccessor { + my $self = shift; + $self->mk_group_accessors('inherited', $_[0]); + $self->set_inherited(@_) if @_ > 1; +} + my $successfully_loaded_components; sub get_component_class { @@ -18,6 +28,8 @@ sub get_component_class { if (defined $class and ! $successfully_loaded_components->{$class} ) { $_[0]->ensure_class_loaded($class); + mro::set_mro( $class, 'c3' ); + no strict 'refs'; $successfully_loaded_components->{$class} = ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 9030712a4..1231a07c1 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -2,7 +2,10 @@ package DBIx::Class::ResultSet; use strict; use warnings; -use base qw/DBIx::Class/; + +use base 'DBIx::Class'; +use mro 'c3'; + use DBIx::Class::Carp; use DBIx::Class::ResultSetColumn; use DBIx::Class::ResultClass::HashRefInflator; diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index b6fb310da..d2cc10f6a 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -3,7 +3,10 @@ package DBIx::Class::ResultSource; use strict; use warnings; -use base qw/DBIx::Class::ResultSource::RowParser DBIx::Class/; +use base 'DBIx::Class'; +__PACKAGE__->load_components(qw( + ResultSource::RowParser +)); use DBIx::Class::Carp; use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try ); diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm index 1e1f307d3..62c056428 100644 --- a/lib/DBIx/Class/ResultSourceProxy.pm +++ b/lib/DBIx/Class/ResultSourceProxy.pm @@ -5,6 +5,7 @@ use strict; use warnings; use base 'DBIx::Class'; +use mro 'c3'; use Scalar::Util 'blessed'; use DBIx::Class::_Util 'quote_sub'; diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index fc9c49932..04f92ccf1 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -4,6 +4,7 @@ use strict; use warnings; use base 'DBIx::Class'; +use mro 'c3'; use DBIx::Class::Carp; use Try::Tiny; diff --git a/xt/dist/pod_coverage.t b/xt/dist/pod_coverage.t index a86c4d8fd..4505af4b1 100644 --- a/xt/dist/pod_coverage.t +++ b/xt/dist/pod_coverage.t @@ -31,6 +31,7 @@ my $exceptions = { ignore => [qw/ MODIFY_CODE_ATTRIBUTES component_base_class + inject_base mk_classdata mk_classaccessor /] diff --git a/xt/extra/c3_mro.t b/xt/extra/c3_mro.t index ae404043c..1c5001a6a 100644 --- a/xt/extra/c3_mro.t +++ b/xt/extra/c3_mro.t @@ -4,9 +4,21 @@ use warnings; use strict; use Test::More; +use DBICTest; + +my @global_ISA_tail = qw( + DBIx::Class + DBIx::Class::Componentised + Class::C3::Componentised + DBIx::Class::AccessorGroup + Class::Accessor::Grouped +); - -use DBICTest; # do not remove even though it is not used (pulls in MRO::Compat if needed) +is( + mro::get_mro('DBIx::Class'), + 'c3', + 'Correct mro on base class DBIx::Class', +); { package AAA; @@ -38,6 +50,17 @@ ok (! $@, "Correctly skipped injecting a direct parent of class BBB"); eval { mro::get_linear_isa('CCC'); }; ok (! $@, "Correctly skipped injecting an indirect parent of class BBB"); + +my $art = DBICTest->init_schema->resultset("Artist")->next; + +check_ancestry($_) for ( + ref( $art ), + ref( $art->result_source ), + ref( $art->result_source->resultset ), + ref( $art->result_source->schema ), + qw( AAA BBB CCC ), +); + use DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server; is_deeply ( @@ -51,12 +74,7 @@ is_deeply ( DBIx::Class::Storage::DBI DBIx::Class::Storage::DBIHacks DBIx::Class::Storage - DBIx::Class - DBIx::Class::Componentised - Class::C3::Componentised - DBIx::Class::AccessorGroup - Class::Accessor::Grouped - /], + /, @global_ISA_tail], 'Correctly ordered ISA of DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server' ); @@ -77,4 +95,37 @@ if ( "$]" >= 5.010 ) { #ok (! $INC{'MRO/Compat.pm'}, 'No MRO::Compat loaded on perl 5.10+'); } +sub check_ancestry { + my $class = shift; + + die "Expecting classname" if length ref $class; + + my @linear_ISA = @{ mro::get_linear_isa($class) }; + + # something is *VERY* wrong, the splice below won't make it + unless (@linear_ISA > @global_ISA_tail) { + fail( + "Unexpectedly shallow \@ISA for class '$class': " + . join ', ', map { "'$_'" } @linear_ISA + ); + return; + } + + is_deeply ( + [ splice @linear_ISA, ($#linear_ISA - $#global_ISA_tail) ], + \@global_ISA_tail, + "Correct end of \@ISA for '$class'" + ); + + # check the remainder + for my $c (@linear_ISA) { + # nothing to see there + next if $c =~ /^DBICTest::/; + + next if mro::get_mro($c) eq 'c3'; + + fail( "Incorrect mro '@{[ mro::get_mro($c) ]}' on '$c' (parent of '$class')" ); + } +} + done_testing; From 5e0eea3522876a30453af24097507198bbbc9409 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 19 Apr 2016 10:04:26 +0200 Subject: [PATCH 077/262] Remove Class::Data::Inheritable and use CAG 'inherited' style accessors This *is* a subtle change in behavior, as the CAG accessors could be overriden by a rogue get/set_inherited in the stack. However keeping CDI in-place while satisfying the requirements of the rsrc refactor is just too much work for a miniscule risk avoidance. If something blows up - we'll think then. --- lib/DBIx/Class/CDBICompat/AbstractSearch.pm | 2 ++ lib/DBIx/Class/CDBICompat/AccessorMapping.pm | 2 ++ lib/DBIx/Class/CDBICompat/AttributeAPI.pm | 2 ++ lib/DBIx/Class/CDBICompat/AutoUpdate.pm | 2 +- lib/DBIx/Class/CDBICompat/ColumnCase.pm | 2 ++ lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm | 1 + lib/DBIx/Class/CDBICompat/Constraints.pm | 2 ++ lib/DBIx/Class/CDBICompat/Copy.pm | 2 ++ lib/DBIx/Class/CDBICompat/DestroyWarning.pm | 3 +++ lib/DBIx/Class/CDBICompat/GetSet.pm | 2 +- lib/DBIx/Class/CDBICompat/ImaDBI.pm | 2 +- lib/DBIx/Class/CDBICompat/Iterator.pm | 1 + lib/DBIx/Class/CDBICompat/LazyLoading.pm | 2 ++ lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm | 2 +- lib/DBIx/Class/CDBICompat/NoObjectIndex.pm | 2 ++ lib/DBIx/Class/CDBICompat/Pager.pm | 2 ++ lib/DBIx/Class/CDBICompat/ReadOnly.pm | 2 ++ lib/DBIx/Class/CDBICompat/Relationship.pm | 2 ++ lib/DBIx/Class/CDBICompat/Relationships.pm | 2 +- lib/DBIx/Class/CDBICompat/Retrieve.pm | 2 ++ lib/DBIx/Class/CDBICompat/SQLTransformer.pm | 2 ++ lib/DBIx/Class/CDBICompat/Stringify.pm | 2 +- lib/DBIx/Class/CDBICompat/TempColumns.pm | 2 +- lib/DBIx/Class/CDBICompat/Triggers.pm | 3 +++ lib/DBIx/Class/Optional/Dependencies.pm | 1 - xt/extra/c3_mro.t | 7 +++++++ 26 files changed, 48 insertions(+), 8 deletions(-) diff --git a/lib/DBIx/Class/CDBICompat/AbstractSearch.pm b/lib/DBIx/Class/CDBICompat/AbstractSearch.pm index 8f5910614..23c009e1b 100644 --- a/lib/DBIx/Class/CDBICompat/AbstractSearch.pm +++ b/lib/DBIx/Class/CDBICompat/AbstractSearch.pm @@ -4,6 +4,8 @@ package # hide form PAUSE use strict; use warnings; +use base 'DBIx::Class'; + =head1 NAME DBIx::Class::CDBICompat::AbstractSearch - Emulates Class::DBI::AbstractSearch diff --git a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm index 15559371c..e235440ec 100644 --- a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm +++ b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm @@ -4,6 +4,8 @@ package # hide from PAUSE Indexer use strict; use warnings; +use base 'DBIx::Class'; + use Scalar::Util 'blessed'; use namespace::clean; diff --git a/lib/DBIx/Class/CDBICompat/AttributeAPI.pm b/lib/DBIx/Class/CDBICompat/AttributeAPI.pm index abf9ac09b..c847a3913 100644 --- a/lib/DBIx/Class/CDBICompat/AttributeAPI.pm +++ b/lib/DBIx/Class/CDBICompat/AttributeAPI.pm @@ -4,6 +4,8 @@ package # hide from PAUSE use strict; use warnings; +use base 'DBIx::Class'; + sub _attrs { my ($self, @atts) = @_; return @{$self->{_column_data}}{@atts}; diff --git a/lib/DBIx/Class/CDBICompat/AutoUpdate.pm b/lib/DBIx/Class/CDBICompat/AutoUpdate.pm index c32c12520..16f2164eb 100644 --- a/lib/DBIx/Class/CDBICompat/AutoUpdate.pm +++ b/lib/DBIx/Class/CDBICompat/AutoUpdate.pm @@ -4,7 +4,7 @@ package # hide from PAUSE use strict; use warnings; -use base qw/Class::Data::Inheritable/; +use base 'DBIx::Class'; __PACKAGE__->mk_classdata('__AutoCommit'); diff --git a/lib/DBIx/Class/CDBICompat/ColumnCase.pm b/lib/DBIx/Class/CDBICompat/ColumnCase.pm index 13bec9cbe..56bef61b3 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnCase.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnCase.pm @@ -4,6 +4,8 @@ package # hide from PAUSE use strict; use warnings; +use base 'DBIx::Class'; + sub _register_column_group { my ($class, $group, @cols) = @_; return $class->next::method($group => map lc, @cols); diff --git a/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm b/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm index c5c1fe179..51b6e0baa 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnsAsHash.pm @@ -4,6 +4,7 @@ package use strict; use warnings; +use base 'DBIx::Class'; =head1 NAME diff --git a/lib/DBIx/Class/CDBICompat/Constraints.pm b/lib/DBIx/Class/CDBICompat/Constraints.pm index 1014886be..f77db5222 100644 --- a/lib/DBIx/Class/CDBICompat/Constraints.pm +++ b/lib/DBIx/Class/CDBICompat/Constraints.pm @@ -1,6 +1,8 @@ package # hide from PAUSE DBIx::Class::CDBICompat::Constraints; +use base 'DBIx::Class'; + use strict; use warnings; diff --git a/lib/DBIx/Class/CDBICompat/Copy.pm b/lib/DBIx/Class/CDBICompat/Copy.pm index 77e7b5be7..ec2e9ca8c 100644 --- a/lib/DBIx/Class/CDBICompat/Copy.pm +++ b/lib/DBIx/Class/CDBICompat/Copy.pm @@ -4,6 +4,8 @@ package # hide from PAUSE use strict; use warnings; +use base 'DBIx::Class'; + use Carp; =head1 NAME diff --git a/lib/DBIx/Class/CDBICompat/DestroyWarning.pm b/lib/DBIx/Class/CDBICompat/DestroyWarning.pm index 61d243c42..998bc5d15 100644 --- a/lib/DBIx/Class/CDBICompat/DestroyWarning.pm +++ b/lib/DBIx/Class/CDBICompat/DestroyWarning.pm @@ -3,6 +3,9 @@ package # hide from PAUSE use strict; use warnings; + +use base 'DBIx::Class'; + use DBIx::Class::_Util 'detected_reinvoked_destructor'; use namespace::clean; diff --git a/lib/DBIx/Class/CDBICompat/GetSet.pm b/lib/DBIx/Class/CDBICompat/GetSet.pm index dd621f27d..e9480488c 100644 --- a/lib/DBIx/Class/CDBICompat/GetSet.pm +++ b/lib/DBIx/Class/CDBICompat/GetSet.pm @@ -4,7 +4,7 @@ package # hide from PAUSE use strict; use warnings; -#use base qw/Class::Accessor/; +use base 'DBIx::Class'; sub get { my ($self, @cols) = @_; diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm index 0ec699386..7a88d155a 100644 --- a/lib/DBIx/Class/CDBICompat/ImaDBI.pm +++ b/lib/DBIx/Class/CDBICompat/ImaDBI.pm @@ -6,7 +6,7 @@ use warnings; use DBIx::ContextualFetch; use DBIx::Class::_Util qw(quote_sub perlstring); -use base qw(Class::Data::Inheritable); +use base 'DBIx::Class'; __PACKAGE__->mk_classdata('sql_transformer_class' => 'DBIx::Class::CDBICompat::SQLTransformer'); diff --git a/lib/DBIx/Class/CDBICompat/Iterator.pm b/lib/DBIx/Class/CDBICompat/Iterator.pm index 86a3838c4..499583718 100644 --- a/lib/DBIx/Class/CDBICompat/Iterator.pm +++ b/lib/DBIx/Class/CDBICompat/Iterator.pm @@ -3,6 +3,7 @@ package DBIx::Class::CDBICompat::Iterator; use strict; use warnings; +use base 'DBIx::Class'; =head1 NAME diff --git a/lib/DBIx/Class/CDBICompat/LazyLoading.pm b/lib/DBIx/Class/CDBICompat/LazyLoading.pm index 798fcd39d..a9e41af51 100644 --- a/lib/DBIx/Class/CDBICompat/LazyLoading.pm +++ b/lib/DBIx/Class/CDBICompat/LazyLoading.pm @@ -4,6 +4,8 @@ package # hide from PAUSE use strict; use warnings; +use base 'DBIx::Class'; + sub resultset_instance { my $self = shift; my $rs = $self->next::method(@_); diff --git a/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm b/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm index f05eff7d0..970b2d9e0 100644 --- a/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm +++ b/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm @@ -6,7 +6,7 @@ use warnings; use Scalar::Util qw/weaken/; -use base qw/Class::Data::Inheritable/; +use base 'DBIx::Class'; __PACKAGE__->mk_classdata('purge_object_index_every' => 1000); __PACKAGE__->mk_classdata('live_object_index' => { }); diff --git a/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm b/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm index f3c472da4..e98e5eb4b 100644 --- a/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm +++ b/lib/DBIx/Class/CDBICompat/NoObjectIndex.pm @@ -4,6 +4,8 @@ package # hide from PAUSE use strict; use warnings; +use base 'DBIx::Class'; + =head1 NAME DBIx::Class::CDBICompat::NoObjectIndex - Defines empty methods for object indexing. They do nothing diff --git a/lib/DBIx/Class/CDBICompat/Pager.pm b/lib/DBIx/Class/CDBICompat/Pager.pm index 203b59855..c8f76feee 100644 --- a/lib/DBIx/Class/CDBICompat/Pager.pm +++ b/lib/DBIx/Class/CDBICompat/Pager.pm @@ -8,6 +8,8 @@ use strict; # leaving the compat layer as-is, something may in fact depend on that use warnings FATAL => 'all'; +use base 'DBIx::Class'; + *pager = \&page; sub page { diff --git a/lib/DBIx/Class/CDBICompat/ReadOnly.pm b/lib/DBIx/Class/CDBICompat/ReadOnly.pm index 669a76d7f..9bab1f4c8 100644 --- a/lib/DBIx/Class/CDBICompat/ReadOnly.pm +++ b/lib/DBIx/Class/CDBICompat/ReadOnly.pm @@ -4,6 +4,8 @@ package # hide from PAUSE use strict; use warnings; +use base 'DBIx::Class'; + sub make_read_only { my $proto = shift; $proto->add_trigger("before_$_" => sub { shift->throw_exception("$proto is read only") }) diff --git a/lib/DBIx/Class/CDBICompat/Relationship.pm b/lib/DBIx/Class/CDBICompat/Relationship.pm index 95e414d1c..f9d0769e2 100644 --- a/lib/DBIx/Class/CDBICompat/Relationship.pm +++ b/lib/DBIx/Class/CDBICompat/Relationship.pm @@ -4,6 +4,8 @@ package use strict; use warnings; +use base 'DBIx::Class'; + use DBIx::Class::_Util 'quote_sub'; =head1 NAME diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm index 8d923b318..abd67830d 100644 --- a/lib/DBIx/Class/CDBICompat/Relationships.pm +++ b/lib/DBIx/Class/CDBICompat/Relationships.pm @@ -3,7 +3,7 @@ package # hide from PAUSE use strict; use warnings; -use base 'Class::Data::Inheritable'; +use base 'DBIx::Class'; use Clone; use DBIx::Class::CDBICompat::Relationship; diff --git a/lib/DBIx/Class/CDBICompat/Retrieve.pm b/lib/DBIx/Class/CDBICompat/Retrieve.pm index 87f531818..2ddd4b297 100644 --- a/lib/DBIx/Class/CDBICompat/Retrieve.pm +++ b/lib/DBIx/Class/CDBICompat/Retrieve.pm @@ -8,6 +8,8 @@ use strict; # leaving the compat layer as-is, something may in fact depend on that use warnings FATAL => 'all'; +use base 'DBIx::Class'; + sub retrieve { my $self = shift; die "No args to retrieve" unless @_ > 0; diff --git a/lib/DBIx/Class/CDBICompat/SQLTransformer.pm b/lib/DBIx/Class/CDBICompat/SQLTransformer.pm index fd54b7e21..cc9d9f069 100644 --- a/lib/DBIx/Class/CDBICompat/SQLTransformer.pm +++ b/lib/DBIx/Class/CDBICompat/SQLTransformer.pm @@ -3,6 +3,8 @@ package DBIx::Class::CDBICompat::SQLTransformer; use strict; use warnings; +use base 'DBIx::Class'; + =head1 NAME DBIx::Class::CDBICompat::SQLTransformer - Transform SQL diff --git a/lib/DBIx/Class/CDBICompat/Stringify.pm b/lib/DBIx/Class/CDBICompat/Stringify.pm index 4d13171e8..e1c9a36a5 100644 --- a/lib/DBIx/Class/CDBICompat/Stringify.pm +++ b/lib/DBIx/Class/CDBICompat/Stringify.pm @@ -4,7 +4,7 @@ package # hide from PAUSE use strict; use warnings; -use Scalar::Util; +use base 'DBIx::Class'; use overload '""' => sub { return shift->stringify_self; }, diff --git a/lib/DBIx/Class/CDBICompat/TempColumns.pm b/lib/DBIx/Class/CDBICompat/TempColumns.pm index 428719ed2..3a111ee9c 100644 --- a/lib/DBIx/Class/CDBICompat/TempColumns.pm +++ b/lib/DBIx/Class/CDBICompat/TempColumns.pm @@ -3,7 +3,7 @@ package # hide from PAUSE use strict; use warnings; -use base qw/Class::Data::Inheritable/; +use base 'DBIx::Class'; use Carp; diff --git a/lib/DBIx/Class/CDBICompat/Triggers.pm b/lib/DBIx/Class/CDBICompat/Triggers.pm index 3f6aef7a4..0428b6acc 100644 --- a/lib/DBIx/Class/CDBICompat/Triggers.pm +++ b/lib/DBIx/Class/CDBICompat/Triggers.pm @@ -3,6 +3,9 @@ package # hide from PAUSE use strict; use warnings; + +use base 'DBIx::Class'; + use Class::Trigger; sub insert { diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm index 43790b247..4bb44ff7f 100644 --- a/lib/DBIx/Class/Optional/Dependencies.pm +++ b/lib/DBIx/Class/Optional/Dependencies.pm @@ -178,7 +178,6 @@ my $dbic_reqs = { cdbicompat => { req => { - 'Class::Data::Inheritable' => '0', 'Class::Trigger' => '0', 'DBIx::ContextualFetch' => '0', 'Clone' => '0.32', diff --git a/xt/extra/c3_mro.t b/xt/extra/c3_mro.t index 1c5001a6a..27a034145 100644 --- a/xt/extra/c3_mro.t +++ b/xt/extra/c3_mro.t @@ -5,6 +5,7 @@ use strict; use Test::More; use DBICTest; +use DBIx::Class::Optional::Dependencies; my @global_ISA_tail = qw( DBIx::Class @@ -59,6 +60,12 @@ check_ancestry($_) for ( ref( $art->result_source->resultset ), ref( $art->result_source->schema ), qw( AAA BBB CCC ), + ((! DBIx::Class::Optional::Dependencies->req_ok_for('cdbicompat') ) ? () : do { + unshift @INC, 't/cdbi/testlib'; + map { eval "require $_" or die $@; $_ } qw( + Film Lazy Actor ActorAlias ImplicitInflate + ); + }), ); use DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server; From 51ec03826afb5b20a686a7303bc55c42f4715945 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 19 Apr 2016 12:54:46 +0200 Subject: [PATCH 078/262] After 5e0eea35 we can actually test for cleaned namespaces within CDBI --- lib/DBIx/Class/CDBICompat/AttributeAPI.pm | 2 +- lib/DBIx/Class/CDBICompat/ColumnGroups.pm | 14 +++++--------- lib/DBIx/Class/CDBICompat/Constructor.pm | 1 + lib/DBIx/Class/CDBICompat/Copy.pm | 1 + lib/DBIx/Class/CDBICompat/ImaDBI.pm | 4 +++- lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm | 1 + lib/DBIx/Class/CDBICompat/Pager.pm | 2 +- lib/DBIx/Class/CDBICompat/Relationship.pm | 1 + lib/DBIx/Class/CDBICompat/Relationships.pm | 1 + lib/DBIx/Class/CDBICompat/TempColumns.pm | 1 + xt/extra/internals/namespaces_cleaned.t | 6 ++++-- 11 files changed, 20 insertions(+), 14 deletions(-) diff --git a/lib/DBIx/Class/CDBICompat/AttributeAPI.pm b/lib/DBIx/Class/CDBICompat/AttributeAPI.pm index c847a3913..1e7618638 100644 --- a/lib/DBIx/Class/CDBICompat/AttributeAPI.pm +++ b/lib/DBIx/Class/CDBICompat/AttributeAPI.pm @@ -11,7 +11,7 @@ sub _attrs { return @{$self->{_column_data}}{@atts}; } -*_attr = \&_attrs; +sub _attr { shift->_attrs(@_) } sub _attribute_store { my $self = shift; diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm index 44a60107b..c5623ca95 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm @@ -137,15 +137,11 @@ sub _mk_group_accessors { ($name, $field) = @$field if ref $field; - my $accessor = $class->$maker($group, $field); - my $alias = "_${name}_accessor"; - - # warn " $field $alias\n"; - { - no strict 'refs'; - - $class->_deploy_accessor($name, $accessor); - $class->_deploy_accessor($alias, $accessor); + for( $name, "_${name}_accessor" ) { + $class->_deploy_accessor( + $_, + $class->$maker($group, $field, $_) + ); } } } diff --git a/lib/DBIx/Class/CDBICompat/Constructor.pm b/lib/DBIx/Class/CDBICompat/Constructor.pm index 65ce576f1..78c6d333a 100644 --- a/lib/DBIx/Class/CDBICompat/Constructor.pm +++ b/lib/DBIx/Class/CDBICompat/Constructor.pm @@ -8,6 +8,7 @@ use base 'DBIx::Class::CDBICompat::ImaDBI'; use Carp; use DBIx::Class::_Util qw(quote_sub perlstring); +use namespace::clean; __PACKAGE__->set_sql(Retrieve => <<''); SELECT __ESSENTIAL__ diff --git a/lib/DBIx/Class/CDBICompat/Copy.pm b/lib/DBIx/Class/CDBICompat/Copy.pm index ec2e9ca8c..59780e650 100644 --- a/lib/DBIx/Class/CDBICompat/Copy.pm +++ b/lib/DBIx/Class/CDBICompat/Copy.pm @@ -7,6 +7,7 @@ use warnings; use base 'DBIx::Class'; use Carp; +use namespace::clean; =head1 NAME diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm index 7a88d155a..ee9aae0c6 100644 --- a/lib/DBIx/Class/CDBICompat/ImaDBI.pm +++ b/lib/DBIx/Class/CDBICompat/ImaDBI.pm @@ -4,10 +4,12 @@ package # hide from PAUSE use strict; use warnings; use DBIx::ContextualFetch; -use DBIx::Class::_Util qw(quote_sub perlstring); use base 'DBIx::Class'; +use DBIx::Class::_Util qw(quote_sub perlstring); +use namespace::clean; + __PACKAGE__->mk_classdata('sql_transformer_class' => 'DBIx::Class::CDBICompat::SQLTransformer'); diff --git a/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm b/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm index 970b2d9e0..de17f97ed 100644 --- a/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm +++ b/lib/DBIx/Class/CDBICompat/LiveObjectIndex.pm @@ -5,6 +5,7 @@ use strict; use warnings; use Scalar::Util qw/weaken/; +use namespace::clean; use base 'DBIx::Class'; diff --git a/lib/DBIx/Class/CDBICompat/Pager.pm b/lib/DBIx/Class/CDBICompat/Pager.pm index c8f76feee..7316d9d11 100644 --- a/lib/DBIx/Class/CDBICompat/Pager.pm +++ b/lib/DBIx/Class/CDBICompat/Pager.pm @@ -10,7 +10,7 @@ use warnings FATAL => 'all'; use base 'DBIx::Class'; -*pager = \&page; +sub pager { shift->page(@_) } sub page { my $class = shift; diff --git a/lib/DBIx/Class/CDBICompat/Relationship.pm b/lib/DBIx/Class/CDBICompat/Relationship.pm index f9d0769e2..54962cd51 100644 --- a/lib/DBIx/Class/CDBICompat/Relationship.pm +++ b/lib/DBIx/Class/CDBICompat/Relationship.pm @@ -7,6 +7,7 @@ use warnings; use base 'DBIx::Class'; use DBIx::Class::_Util 'quote_sub'; +use namespace::clean; =head1 NAME diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm index abd67830d..658305dcc 100644 --- a/lib/DBIx/Class/CDBICompat/Relationships.pm +++ b/lib/DBIx/Class/CDBICompat/Relationships.pm @@ -9,6 +9,7 @@ use Clone; use DBIx::Class::CDBICompat::Relationship; use Scalar::Util 'blessed'; use DBIx::Class::_Util qw(quote_sub perlstring); +use namespace::clean; __PACKAGE__->mk_classdata('__meta_info' => {}); diff --git a/lib/DBIx/Class/CDBICompat/TempColumns.pm b/lib/DBIx/Class/CDBICompat/TempColumns.pm index 3a111ee9c..9783d6ae7 100644 --- a/lib/DBIx/Class/CDBICompat/TempColumns.pm +++ b/lib/DBIx/Class/CDBICompat/TempColumns.pm @@ -6,6 +6,7 @@ use warnings; use base 'DBIx::Class'; use Carp; +use namespace::clean; __PACKAGE__->mk_classdata('_temp_columns' => { }); diff --git a/xt/extra/internals/namespaces_cleaned.t b/xt/extra/internals/namespaces_cleaned.t index 3f702628a..01650d50d 100644 --- a/xt/extra/internals/namespaces_cleaned.t +++ b/xt/extra/internals/namespaces_cleaned.t @@ -65,8 +65,7 @@ my @modules = grep { # have an exception table for old and/or weird code we are not sure # we *want* to clean in the first place my $skip_idx = { map { $_ => 1 } ( - (grep { /^DBIx::Class::CDBICompat/ } @modules), # too crufty to touch - 'SQL::Translator::Producer::DBIx::Class::File', # ditto + 'SQL::Translator::Producer::DBIx::Class::File', # too crufty to touch # not sure how to handle type libraries 'DBIx::Class::Storage::DBI::Replicated::Types', @@ -146,6 +145,9 @@ for my $mod (@modules) { # exception time if ( ( $name eq 'import' and $via = 'Exporter' ) + or + # jesus christ nobody had any idea how to design an interface back then + ( $name =~ /_trigger/ and $via = 'Class::Trigger' ) ) { pass("${mod}::${name} is a valid uncleaned import from ${name}"); } From 7b731f1eca0005daa869c61a96e48434af5635dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= Date: Wed, 20 Apr 2016 17:20:26 +0100 Subject: [PATCH 079/262] Fix Oracle _dbh_execute_for_fetch warning suppression Commit 52cef7e3 changed from using execute_array to execute_for_fetch, but didn't update the signature of the override in Storage::DBI::Oracle::Generic, so it was setting ->{PrintWarn} 0 on the result source, not the statement handle. The reason it was not detected since is that DBD::Oracle 1.28+ already fixed the underlying warning. --- lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm index b196b805a..838c8daa6 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm @@ -7,7 +7,7 @@ use mro 'c3'; use DBIx::Class::Carp; use Scope::Guard (); use Context::Preserve 'preserve_context'; -use DBIx::Class::_Util qw( modver_gt_or_eq_and_lt dbic_internal_try ); +use DBIx::Class::_Util qw( modver_gt_or_eq modver_gt_or_eq_and_lt dbic_internal_try ); use namespace::clean; __PACKAGE__->sql_limit_dialect ('RowNum'); @@ -325,10 +325,12 @@ sub _dbh_execute { } sub _dbh_execute_for_fetch { - #my ($self, $sth, $tuple_status, @extra) = @_; + #my ($self, $source, $sth, $proto_bind, $cols, $data) = @_; - # DBD::Oracle warns loudly on partial execute_for_fetch failures - local $_[1]->{PrintWarn} = 0; + # Older DBD::Oracle warns loudly on partial execute_for_fetch failures + # before https://metacpan.org/source/PYTHIAN/DBD-Oracle-1.28/Changes#L7-9 + local $_[2]->{PrintWarn} = 0 + unless modver_gt_or_eq( 'DBD::Oracle', '1.28' ); shift->next::method(@_); } From 22030f6f3e5ace15060ba1233682dfcfdfb318a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= Date: Wed, 20 Apr 2016 17:23:46 +0100 Subject: [PATCH 080/262] Use prepared statement from the start for populate on PostgreSQL DBD::Pg since version 3.0.0 by default only starts using server-side prepared statements the second time ->execute is called on a given statement handle. Unless server-side prepared statements have been disabled (by setting the threshold to zero), make it use them immediately to avoid parsing the statement twice. --- lib/DBIx/Class/Storage/DBI/Pg.pm | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/lib/DBIx/Class/Storage/DBI/Pg.pm b/lib/DBIx/Class/Storage/DBI/Pg.pm index 87a237d66..88df494c4 100644 --- a/lib/DBIx/Class/Storage/DBI/Pg.pm +++ b/lib/DBIx/Class/Storage/DBI/Pg.pm @@ -157,6 +157,19 @@ EOS return $seq_expr; } +sub _dbh_execute_for_fetch { + #my ($self, $source, $sth, $tuple_status, @extra) = @_; + + # This is used for bulk insert, so make sure we use a server-side + # prepared statement from the start, unless it's disabled + local $_[2]->{pg_switch_prepared} = 1 if + modver_gt_or_eq( 'DBD::Pg', '3.0.0' ) + and + $_[2]->FETCH('pg_switch_prepared') > 0 + ; + + shift->next::method(@_); +} sub sqlt_type { return 'PostgreSQL'; From 7fe322c8d2a911e986b0fc2a753b023d63940bcb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= Date: Wed, 10 Dec 2014 18:04:06 +0000 Subject: [PATCH 081/262] Fix ordering by 1:M prefetched boolean columns in Pg PostgreSQL doesn't have min/max aggregates for the boolean type, but it has and/or, which are equivalent. So, allow the storage to override the aggregate used for constructing the order by clause based on the column info. --- Changes | 2 + lib/DBIx/Class/Storage/DBI/Pg.pm | 16 ++++++ lib/DBIx/Class/Storage/DBIHacks.pm | 10 +++- t/sqlmaker/pg.t | 78 ++++++++++++++++++++++++++++++ 4 files changed, 105 insertions(+), 1 deletion(-) create mode 100644 t/sqlmaker/pg.t diff --git a/Changes b/Changes index 318a4b2f4..f3bd7539c 100644 --- a/Changes +++ b/Changes @@ -45,6 +45,8 @@ Revision history for DBIx::Class - Make sure exception objects stringifying to '' are properly handled and warned about (GH#15) - Fix silencing of exceptions thrown by custom inflate_result() methods + - Fix complex prefetch when ordering over foreign boolean columns + ( Pg can't MAX(boolcol) despite being able to ORDER BY boolcol ) - Fix incorrect data returned in a corner case of partial-select HRI invocation (no known manifestations of this bug in the field, see commit message for description of exact failure scenario) diff --git a/lib/DBIx/Class/Storage/DBI/Pg.pm b/lib/DBIx/Class/Storage/DBI/Pg.pm index 88df494c4..a8fd85bc2 100644 --- a/lib/DBIx/Class/Storage/DBI/Pg.pm +++ b/lib/DBIx/Class/Storage/DBI/Pg.pm @@ -175,6 +175,22 @@ sub sqlt_type { return 'PostgreSQL'; } +# Pg is not able to MAX(boolean_column), sigh... +# +# Generally it would make more sense to have this in the SQLMaker hierarchy, +# so that eventually { -max => ... } DTRT, but plans going forward are +# murky at best +# --ribasushi +# +sub _minmax_operator_for_datatype { + #my ($self, $datatype, $want_max) = @_; + + return ($_[2] ? 'BOOL_OR' : 'BOOL_AND') + if ($_[1] || '') =~ /\Abool(?:ean)?\z/i; + + shift->next::method(@_); +} + sub bind_attribute_by_data_type { my ($self,$data_type) = @_; diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm index 305e7688a..26cc4c88b 100644 --- a/lib/DBIx/Class/Storage/DBIHacks.pm +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -719,6 +719,8 @@ sub _group_over_selection { # for DESC, and group_by the root columns. The end result should be # exactly what we expect # + + # both populated on the first loop over $o_idx $sql_maker ||= $self->sql_maker; $order_chunks ||= [ map { ref $_ eq 'ARRAY' ? $_ : [ $_ ] } $sql_maker->_order_by_chunks($attrs->{order_by}) @@ -730,7 +732,7 @@ sub _group_over_selection { # to an ordering alias into a MIN/MAX $new_order_by[$o_idx] = \[ sprintf( '%s( %s )%s', - ($is_desc ? 'MAX' : 'MIN'), + $self->_minmax_operator_for_datatype($chunk_ci->{data_type}, $is_desc), $chunk, ($is_desc ? ' DESC' : ''), ), @@ -758,6 +760,12 @@ sub _group_over_selection { ); } +sub _minmax_operator_for_datatype { + #my ($self, $datatype, $want_max) = @_; + + $_[2] ? 'MAX' : 'MIN'; +} + sub _resolve_ident_sources { my ($self, $ident) = @_; diff --git a/t/sqlmaker/pg.t b/t/sqlmaker/pg.t new file mode 100644 index 000000000..83a6fe950 --- /dev/null +++ b/t/sqlmaker/pg.t @@ -0,0 +1,78 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; + +use DBICTest ':DiffSQL'; + +my $schema = DBICTest->init_schema( + no_deploy => 1, + quote_names => 1, + storage_type => 'DBIx::Class::Storage::DBI::Pg' +); + +my $rs = $schema->resultset('Artist')->search_related('cds_unordered', + { "me.rank" => 13 }, + { + prefetch => 'tracks', + join => 'genre', + order_by => [ 'genre.name', { -desc => \ 'tracks.title' }, { -asc => "me.name" }, { -desc => [qw(year cds_unordered.title)] } ], # me. is the artist, *NOT* the cd + rows => 1, + }, +); + +{ + # THIS IS AN OFFLINE TEST + # We only need this so that the thing can be verified to work without PG_DSN + # Executing it while "lying" this way won't work + local $rs->result_source->related_source('tracks')->column_info('title')->{data_type} = 'bool'; + local $rs->result_source->related_source('genre')->column_info('name')->{data_type} = 'BOOLEAN'; + + is_same_sql_bind( + $rs->as_query, + q{( + SELECT "cds_unordered"."cdid", "cds_unordered"."artist", "cds_unordered"."title", "cds_unordered"."year", "cds_unordered"."genreid", "cds_unordered"."single_track", + "tracks"."trackid", "tracks"."cd", "tracks"."position", "tracks"."title", "tracks"."last_updated_on", "tracks"."last_updated_at" + FROM "artist" "me" + JOIN ( + SELECT "cds_unordered"."cdid", "cds_unordered"."artist", "cds_unordered"."title", "cds_unordered"."year", "cds_unordered"."genreid", "cds_unordered"."single_track" + FROM "artist" "me" + JOIN cd "cds_unordered" + ON "cds_unordered"."artist" = "me"."artistid" + LEFT JOIN "genre" "genre" + ON "genre"."genreid" = "cds_unordered"."genreid" + LEFT JOIN "track" "tracks" + ON "tracks"."cd" = "cds_unordered"."cdid" + WHERE "me"."rank" = ? + GROUP BY "cds_unordered"."cdid", "cds_unordered"."artist", "cds_unordered"."title", "cds_unordered"."year", "cds_unordered"."genreid", "cds_unordered"."single_track", "me"."name" + ORDER BY BOOL_AND("genre"."name"), + BOOL_OR( tracks.title ) DESC, + "me"."name" ASC, + "year" DESC, + "cds_unordered"."title" DESC + LIMIT ? + ) "cds_unordered" + ON "cds_unordered"."artist" = "me"."artistid" + LEFT JOIN "genre" "genre" + ON "genre"."genreid" = "cds_unordered"."genreid" + LEFT JOIN "track" "tracks" + ON "tracks"."cd" = "cds_unordered"."cdid" + WHERE "me"."rank" = ? + ORDER BY "genre"."name", + tracks.title DESC, + "me"."name" ASC, + "year" DESC, + "cds_unordered"."title" DESC + )}, + [ + [ { sqlt_datatype => 'integer', dbic_colname => 'me.rank' } => 13 ], + [ DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype => 1 ], + [ { sqlt_datatype => 'integer', dbic_colname => 'me.rank' } => 13 ], + ], + 'correct SQL with aggregate boolean order on Pg', + ); +} + +done_testing; From 652d9b762d7b6d36c7dcc396e2cee5264c6d0a95 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 24 Apr 2016 15:49:30 +0200 Subject: [PATCH 082/262] Fix last remaining tests with -T under < 5.10 Model on https://github.com/p5sagit/namespace-clean/commit/acb1d694, this is still a mega-kludge, as the FIXME in the file says --- maint/travis-ci_scripts/40_script.bash | 7 +------ t/94versioning.t | 5 +++++ xt/extra/internals/namespaces_cleaned.t | 26 +++++++++++++++++++++++-- 3 files changed, 30 insertions(+), 8 deletions(-) diff --git a/maint/travis-ci_scripts/40_script.bash b/maint/travis-ci_scripts/40_script.bash index 25a35ff67..0a6ecd541 100755 --- a/maint/travis-ci_scripts/40_script.bash +++ b/maint/travis-ci_scripts/40_script.bash @@ -28,12 +28,7 @@ if [[ "$CLEANTEST" = "true" ]] ; then run_or_err "Prepare blib" "make pure_all" run_harness_tests else - PROVECMD="prove -lrswj$VCPU_USE xt t" - - # FIXME - temporary, until Package::Stash is fixed - if perl -M5.010 -e 1 &>/dev/null ; then - PROVECMD="$PROVECMD -T" - fi + PROVECMD="prove -lrswTj$VCPU_USE xt t" # List every single SKIP/TODO when they are visible if [[ "$VCPU_USE" == 1 ]] ; then diff --git a/t/94versioning.t b/t/94versioning.t index 117f02a51..af46ef768 100644 --- a/t/94versioning.t +++ b/t/94versioning.t @@ -24,6 +24,11 @@ my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}; # in case it came from the env $ENV{DBIC_NO_VERSION_CHECK} = 0; +# FIXME - work around RT#113965 in combination with -T on older perls: +# the non-deparsing XS portion of D::D gets confused by some of the IO +# handles trapped in the debug object of DBIC. What a mess. +$Data::Dumper::Deparse = 1; + use_ok('DBICVersion_v1'); my $version_table_name = 'dbix_class_schema_versions'; diff --git a/xt/extra/internals/namespaces_cleaned.t b/xt/extra/internals/namespaces_cleaned.t index 01650d50d..36e12b1dc 100644 --- a/xt/extra/internals/namespaces_cleaned.t +++ b/xt/extra/internals/namespaces_cleaned.t @@ -35,13 +35,35 @@ BEGIN { use strict; use warnings; +# FIXME This is a crock of shit, needs to go away +# currently here to work around https://rt.cpan.org/Ticket/Display.html?id=74151 +# kill with fire when PS::XS / RT#74151 is *finally* fixed +BEGIN { + my $PS_provider; + + if ( "$]" < 5.010 ) { + require Package::Stash::PP; + $PS_provider = 'Package::Stash::PP'; + } + else { + require Package::Stash; + $PS_provider = 'Package::Stash'; + } + eval <<"EOS" or die $@; + +sub stash_for (\$) { + $PS_provider->new(\$_[0]); +} +1; +EOS +} + use Test::More; use DBICTest; use File::Find; use File::Spec; use B qw/svref_2object/; -use Package::Stash; # makes sure we can load at least something use DBIx::Class; @@ -96,7 +118,7 @@ for my $mod (@modules) { skip "$mod exempt from namespace checks",1 if $skip_idx->{$mod}; my %all_method_like = (map - { %{Package::Stash->new($_)->get_all_symbols('CODE')} } + { %{stash_for($_)->get_all_symbols('CODE')} } (reverse @{mro::get_linear_isa($mod)}) ); From a107d8dee2d3efea39f6fe83ff76747f31464621 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 24 Apr 2016 13:36:47 +0200 Subject: [PATCH 083/262] (travis) Make more helper functions available to subexecs --- maint/travis-ci_scripts/common.bash | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/maint/travis-ci_scripts/common.bash b/maint/travis-ci_scripts/common.bash index 7bbcfabc5..3f7c976eb 100755 --- a/maint/travis-ci_scripts/common.bash +++ b/maint/travis-ci_scripts/common.bash @@ -15,6 +15,14 @@ fi tstamp() { echo -n "[$(date '+%H:%M:%S')]" ; } +CPAN_is_sane() { perl -MCPAN\ 1.94_56 -e 1 &>/dev/null ; } + +CPAN_supports_BUILDPL() { perl -MCPAN\ 1.9205 -e1 &>/dev/null; } + +have_sudo() { sudo /bin/true &>/dev/null ; } + +is_cperl() { [[ "$BREWVER" =~ $( echo -n "^cperl-" ) ]] ; } + ci_vm_state_text() { echo " ========================== CI System information ============================ @@ -167,7 +175,7 @@ parallel_installdeps_notest() { " } -export -f parallel_installdeps_notest run_or_err echo_err tstamp +export -f parallel_installdeps_notest run_or_err echo_err tstamp is_cperl have_sudo CPAN_is_sane CPAN_supports_BUILDPL installdeps() { if [[ -z "$@" ]] ; then return; fi @@ -325,12 +333,3 @@ purge_sitelib() { fi } - - -CPAN_is_sane() { perl -MCPAN\ 1.94_56 -e 1 &>/dev/null ; } - -CPAN_supports_BUILDPL() { perl -MCPAN\ 1.9205 -e1 &>/dev/null; } - -have_sudo() { sudo /bin/true &>/dev/null ; } - -is_cperl() { [[ "$BREWVER" =~ $( echo -n "^cperl-" ) ]] ; } From 67f5d3f20045f28bf551e1fd9fd315dd2041d596 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 24 Apr 2016 18:49:46 +0200 Subject: [PATCH 084/262] (travis) Work around RT#113740 --- maint/travis-ci_scripts/50_after_success.bash | 3 +++ 1 file changed, 3 insertions(+) diff --git a/maint/travis-ci_scripts/50_after_success.bash b/maint/travis-ci_scripts/50_after_success.bash index 8b44371cb..3d3451f8b 100755 --- a/maint/travis-ci_scripts/50_after_success.bash +++ b/maint/travis-ci_scripts/50_after_success.bash @@ -27,6 +27,9 @@ if [[ "$DEVREL_DEPS" == "true" ]] && perl -M5.008003 -e1 &>/dev/null ; then parallel_installdeps_notest YAML Lexical::SealRequireHints fi + # FIXME - workaround for RT#113740 + parallel_installdeps_notest List::AllUtils + # FIXME Change when Moose goes away installdeps Moose $(perl -Ilib -MDBIx::Class::Optional::Dependencies=-list_missing,dist_dir) From cab79c9109be9fbbde85f32506b5e390b5fec5dd Mon Sep 17 00:00:00 2001 From: Sebastian Riedel Date: Wed, 27 Apr 2016 00:04:38 +0200 Subject: [PATCH 085/262] Silly GitHub, Perl6 is not a real language :trollface: Port of https://github.com/kraih/mojo/commit/19cdf772 Before this clarification the project listed as 7% Perl6 code >.< The explicit listing is needed, as there apparently won't be a fix within Github itself any time soon: https://github.com/github/linguist/issues/2149#issuecomment-108954064 https://github.com/github/linguist/issues/2781#issuecomment-167095903 https://github.com/github/linguist/issues/2074#issue-56431157 Language names sourced from: https://github.com/github/linguist/blob/master/lib/linguist/languages.yml --- .gitattributes | 22 +++++++++++----------- AUTHORS | 1 + 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/.gitattributes b/.gitattributes index db6df22a4..e72001e52 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1,15 +1,15 @@ -*.pm eol=lf -*.t eol=lf -*.pod eol=lf -*.pod.proto eol=lf -*.pl eol=lf -*.PL eol=lf -*.bash eol=lf -*.json eol=lf -*.yml eol=lf -*.sql eol=lf +*.pm eol=lf linguist-language=Perl +*.t eol=lf linguist-language=Perl +*.pod eol=lf linguist-language=Pod +*.pod.proto eol=lf linguist-language=Pod +*.pl eol=lf linguist-language=Perl +*.PL eol=lf linguist-language=Perl +*.bash eol=lf linguist-language=Shell +*.json eol=lf linguist-language=JSON +*.yml eol=lf linguist-language=YAML +*.sql eol=lf linguist-language=SQL /* eol=lf -/script/* eol=lf +/script/* eol=lf linguist-language=Perl /maint/* eol=lf * text=auto diff --git a/AUTHORS b/AUTHORS index f4f97f1b3..3fbf27ae9 100644 --- a/AUTHORS +++ b/AUTHORS @@ -195,6 +195,7 @@ solomon: Jared Johnson spb: Stephen Bennett Squeeks srezic: Slaven Rezic +sri: Sebastian Riedel sszabo: Stephan Szabo Stephen Peters stonecolddevin: Devin Austin From a33a40dee2fb4cdcc5fb1da76c66498cbf36e8e8 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 28 Apr 2016 09:07:08 +0200 Subject: [PATCH 086/262] Missed test spewing odd debug after fd2c6658f (slave-less replication) Disabling VIA_REPLICATED as it makes no sense here anyway --- t/storage/dbi_coderef.t | 2 ++ 1 file changed, 2 insertions(+) diff --git a/t/storage/dbi_coderef.t b/t/storage/dbi_coderef.t index 4bbae78e0..9408417b5 100644 --- a/t/storage/dbi_coderef.t +++ b/t/storage/dbi_coderef.t @@ -3,6 +3,8 @@ BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use strict; use warnings; +BEGIN { $ENV{DBICTEST_VIA_REPLICATED} = 0 } + use Test::More; use DBICTest; From 514b84f6b60b566d75d2ff2ddd08659c4cf7b427 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 27 Apr 2016 14:57:40 +0200 Subject: [PATCH 087/262] Centralize remaining uses of Sub::Name within _Util No functional changes --- lib/DBIx/Class/CDBICompat/ColumnGroups.pm | 8 +++++--- lib/DBIx/Class/ResultSetManager.pm | 6 ++++-- lib/DBIx/Class/SQLMaker.pm | 6 +++--- lib/DBIx/Class/Storage/DBI/ADO.pm | 5 ++--- lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm | 7 +++---- lib/DBIx/Class/_Util.pm | 13 ++++++++++++- t/72pg.t | 5 ++--- t/73oracle.t | 4 ++-- t/73oracle_blob.t | 1 - t/icdt/engine_specific/sybase.t | 5 ++--- 10 files changed, 35 insertions(+), 25 deletions(-) diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm index c5623ca95..47eefd5dd 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm @@ -3,11 +3,13 @@ package # hide from PAUSE use strict; use warnings; -use Sub::Name (); -use List::Util (); use base qw/DBIx::Class::Row/; +use List::Util (); +use DBIx::Class::_Util 'set_subname'; +use namespace::clean; + __PACKAGE__->mk_classdata('_column_groups' => { }); sub columns { @@ -111,7 +113,7 @@ sub _register_column_group { no strict 'refs'; no warnings 'redefine'; my $fullname = join '::', $class, $name; - *$fullname = Sub::Name::subname $fullname, $accessor; + *$fullname = set_subname $fullname, $accessor; } $our_accessors{$accessor}++; diff --git a/lib/DBIx/Class/ResultSetManager.pm b/lib/DBIx/Class/ResultSetManager.pm index 0022e8a2b..1c7cf45aa 100644 --- a/lib/DBIx/Class/ResultSetManager.pm +++ b/lib/DBIx/Class/ResultSetManager.pm @@ -2,9 +2,11 @@ package DBIx::Class::ResultSetManager; use strict; use warnings; use base 'DBIx::Class'; -use Sub::Name (); use Package::Stash (); +use DBIx::Class::_Util 'set_subname'; +use namespace::clean; + warn "DBIx::Class::ResultSetManager never left experimental status and has now been DEPRECATED. This module will be deleted in 09000 so please migrate any and all code using it to explicit resultset classes using either @@ -69,7 +71,7 @@ sub _register_attributes { no strict 'refs'; my $resultset_class = $self->_setup_resultset_class; my $name = join '::',$resultset_class, $meth; - *$name = Sub::Name::subname $name, $self->can($meth); + *$name = set_subname $name, $self->can($meth); delete ${"${self}::"}{$meth}; } } diff --git a/lib/DBIx/Class/SQLMaker.pm b/lib/DBIx/Class/SQLMaker.pm index 31e39a796..ea69e076a 100644 --- a/lib/DBIx/Class/SQLMaker.pm +++ b/lib/DBIx/Class/SQLMaker.pm @@ -130,8 +130,8 @@ use base qw/ /; use mro 'c3'; -use Sub::Name 'subname'; use DBIx::Class::Carp; +use DBIx::Class::_Util 'set_subname'; use namespace::clean; __PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/); @@ -161,12 +161,12 @@ BEGIN { # that use DBIx::Class::Carp/DBIx::Class::Exception instead of plain Carp no warnings qw/redefine/; - *SQL::Abstract::belch = subname 'SQL::Abstract::belch' => sub (@) { + *SQL::Abstract::belch = set_subname 'SQL::Abstract::belch' => sub (@) { my($func) = (caller(1))[3]; carp "[$func] Warning: ", @_; }; - *SQL::Abstract::puke = subname 'SQL::Abstract::puke' => sub (@) { + *SQL::Abstract::puke = set_subname 'SQL::Abstract::puke' => sub (@) { my($func) = (caller(1))[3]; __PACKAGE__->throw_exception("[$func] Fatal: " . join ('', @_)); }; diff --git a/lib/DBIx/Class/Storage/DBI/ADO.pm b/lib/DBIx/Class/Storage/DBI/ADO.pm index cfabc731f..c7c0621fd 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO.pm @@ -6,8 +6,7 @@ use strict; use base 'DBIx::Class::Storage::DBI'; use mro 'c3'; -use Sub::Name; -use DBIx::Class::_Util qw( sigwarn_silencer modver_gt_or_eq ); +use DBIx::Class::_Util qw( sigwarn_silencer modver_gt_or_eq set_subname ); use namespace::clean; =head1 NAME @@ -48,7 +47,7 @@ sub _init { no warnings 'redefine'; my $disconnect = *DBD::ADO::db::disconnect{CODE}; - *DBD::ADO::db::disconnect = subname 'DBD::ADO::db::disconnect' => sub { + *DBD::ADO::db::disconnect = set_subname 'DBD::ADO::db::disconnect' => sub { local $SIG{__WARN__} = sigwarn_silencer( qr/Not a Win32::OLE object|uninitialized value/ ); diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm index a6ff2c7be..017709c99 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm @@ -11,10 +11,9 @@ use base qw/ use mro 'c3'; use DBIx::Class::Carp; use Scalar::Util qw/blessed weaken/; -use Sub::Name(); use Try::Tiny; use Context::Preserve 'preserve_context'; -use DBIx::Class::_Util qw( sigwarn_silencer dbic_internal_try dump_value scope_guard ); +use DBIx::Class::_Util qw( sigwarn_silencer dbic_internal_try dump_value scope_guard set_subname ); use namespace::clean; __PACKAGE__->sql_limit_dialect ('GenericSubQ'); @@ -164,7 +163,7 @@ for my $method (@also_proxy_to_extra_storages) { my $replaced = __PACKAGE__->can($method); - *{$method} = Sub::Name::subname $method => sub { + *{$method} = set_subname $method => sub { my $self = shift; $self->_writer_storage->$replaced(@_) if $self->_writer_storage; $self->_bulk_storage->$replaced(@_) if $self->_bulk_storage; @@ -576,7 +575,7 @@ sub _insert_bulk { # This ignores any data conversion errors detected by the client side libs, as # they are usually harmless. my $orig_cslib_cb = DBD::Sybase::set_cslib_cb( - Sub::Name::subname _insert_bulk_cslib_errhandler => sub { + set_subname _insert_bulk_cslib_errhandler => sub { my ($layer, $origin, $severity, $errno, $errmsg, $osmsg, $blkmsg) = @_; return 1 if $errno == 36; diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index be899eeb1..f64e04b8e 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -81,6 +81,7 @@ use Carp 'croak'; use Storable 'nfreeze'; use Scalar::Util qw(weaken blessed reftype refaddr); use Sub::Quote qw(qsub quote_sub); +use Sub::Name (); # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone' BEGIN { *deep_clone = \&Storable::dclone } @@ -89,7 +90,7 @@ use base 'Exporter'; our @EXPORT_OK = qw( sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt fail_on_internal_wantarray fail_on_internal_call - refdesc refcount hrefaddr + refdesc refcount hrefaddr set_subname scope_guard detected_reinvoked_destructor is_exception dbic_internal_try quote_sub qsub perlstring serialize deep_clone dump_value @@ -133,6 +134,16 @@ sub refcount ($) { B::svref_2object($_[0])->REFCNT; } +# FIXME In another life switch this to a polyfill like the one in namespace::clean +sub set_subname ($$) { + + # fully qualify name + splice @_, 0, 1, caller(0) . "::$_[0]" + if $_[0] !~ /::|'/; + + &Sub::Name::subname; +} + sub serialize ($) { local $Storable::canonical = 1; nfreeze($_[0]); diff --git a/t/72pg.t b/t/72pg.t index eda3e03d4..6c2545f3d 100644 --- a/t/72pg.t +++ b/t/72pg.t @@ -7,11 +7,10 @@ use warnings; use Test::More; use Test::Exception; use Test::Warn; -use Sub::Name; use Config; use DBICTest; use SQL::Abstract 'is_literal_value'; -use DBIx::Class::_Util 'is_exception'; +use DBIx::Class::_Util qw( is_exception set_subname ); my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; @@ -82,7 +81,7 @@ for my $use_insert_returning ($test_server_supports_insert_returning no warnings qw/once redefine/; my $old_connection = DBICTest::Schema->can('connection'); - local *DBICTest::Schema::connection = subname 'DBICTest::Schema::connection' => sub { + local *DBICTest::Schema::connection = set_subname 'DBICTest::Schema::connection' => sub { my $s = shift->$old_connection(@_); $s->storage->_use_insert_returning ($use_insert_returning); $s; diff --git a/t/73oracle.t b/t/73oracle.t index 7d6c79016..b61a6a805 100644 --- a/t/73oracle.t +++ b/t/73oracle.t @@ -6,8 +6,8 @@ use warnings; use Test::Exception; use Test::More; -use Sub::Name; use Try::Tiny; +use DBIx::Class::_Util 'set_subname'; use DBICTest; @@ -111,7 +111,7 @@ for my $use_insert_returning ($test_server_supports_insert_returning ? (1,0) : ( no warnings qw/once redefine/; my $old_connection = DBICTest::Schema->can('connection'); - local *DBICTest::Schema::connection = subname 'DBICTest::Schema::connection' => sub { + local *DBICTest::Schema::connection = set_subname 'DBICTest::Schema::connection' => sub { my $s = shift->$old_connection (@_); $s->storage->_use_insert_returning ($use_insert_returning); $s->storage->sql_maker_class('DBIx::Class::SQLMaker::OracleJoins') if $force_ora_joins; diff --git a/t/73oracle_blob.t b/t/73oracle_blob.t index a6f6a4ea0..d067c2b61 100644 --- a/t/73oracle_blob.t +++ b/t/73oracle_blob.t @@ -6,7 +6,6 @@ use warnings; use Test::Exception; use Test::More; -use Sub::Name; use Try::Tiny; use DBICTest::Schema::BindType; diff --git a/t/icdt/engine_specific/sybase.t b/t/icdt/engine_specific/sybase.t index 993fa9bce..f4b8c7bb3 100644 --- a/t/icdt/engine_specific/sybase.t +++ b/t/icdt/engine_specific/sybase.t @@ -6,8 +6,7 @@ use warnings; use Test::More; use Test::Exception; -use DBIx::Class::_Util 'scope_guard'; -use Sub::Name; +use DBIx::Class::_Util qw( scope_guard set_subname ); use DBICTest; @@ -123,7 +122,7 @@ SQL # UGH! { no warnings 'once'; - local *DBICTest::BaseResult::copy = subname 'DBICTest::BaseResult::copy' => sub { + local *DBICTest::BaseResult::copy = set_subname 'DBICTest::BaseResult::copy' => sub { my $self = shift; $self->make_column_dirty($_) for keys %{{ $self->get_inflated_columns }}; From e50536940adf2ebaef907a0c29ae37fbd5ce95b1 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 15 Apr 2016 16:24:33 +0200 Subject: [PATCH 088/262] More indirect call removals: the second part of 77c3a5dc This may see like a random thing to do, especially given the late dev stage, but it is needed for the clean fix of rsrc duality several commits later. The spots were audited via "list all subs 10 lines or less": ~/devel/dbic$ find lib \ -name '*.pod' -prune \ -o -path lib/DBIx/Class/CDBICompat -prune \ -o -path lib/DBIx/Class/Admin -prune \ -o -path lib/DBIx/Class/Storage -prune \ -o -path lib/DBIx/Class/SQLMaker -prune \ -o -type f -exec perl -0777 -e ' $_ =~ /\S/ and $_ !~ /ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call/ and print "\n=====\n$ARGV\n=====\n\n$_\n\n\n" for (<> =~ / ( ^ (\s*) sub \s+ \w+ \s* \{ (?: [^\n]+? \} \s*? \n | (?: [^\n]* \n ){0,10}? ^ \2 \} ) ) /xmg) ' {} \; \ | less --- lib/DBIx/Class.pm | 2 +- lib/DBIx/Class/AccessorGroup.pm | 7 +++- lib/DBIx/Class/Admin.pm | 2 +- lib/DBIx/Class/CDBICompat/AutoUpdate.pm | 2 +- lib/DBIx/Class/CDBICompat/LazyLoading.pm | 2 +- lib/DBIx/Class/CDBICompat/Relationships.pm | 4 +- lib/DBIx/Class/DB.pm | 6 +-- lib/DBIx/Class/FilterColumn.pm | 4 +- lib/DBIx/Class/InflateColumn.pm | 4 +- lib/DBIx/Class/InflateColumn/DateTime.pm | 2 +- lib/DBIx/Class/Ordered.pm | 8 ++-- lib/DBIx/Class/Relationship/Accessor.pm | 16 ++++---- lib/DBIx/Class/Relationship/Base.pm | 34 +++++++++------- lib/DBIx/Class/Relationship/BelongsTo.pm | 4 +- lib/DBIx/Class/Relationship/CascadeActions.pm | 2 +- lib/DBIx/Class/Relationship/HasOne.pm | 4 +- lib/DBIx/Class/Relationship/ManyToMany.pm | 32 +++++++-------- lib/DBIx/Class/Relationship/ProxyMethods.pm | 2 +- lib/DBIx/Class/ResultSet.pm | 39 ++++++++++--------- lib/DBIx/Class/ResultSetColumn.pm | 30 +++++++++----- lib/DBIx/Class/ResultSetManager.pm | 5 ++- lib/DBIx/Class/ResultSource.pm | 27 ++++++++----- lib/DBIx/Class/ResultSource/Table.pm | 2 +- lib/DBIx/Class/ResultSourceProxy.pm | 12 ++++-- lib/DBIx/Class/ResultSourceProxy/Table.pm | 16 ++++---- lib/DBIx/Class/Row.pm | 15 ++++--- lib/DBIx/Class/SQLMaker/LimitDialects.pm | 4 +- lib/DBIx/Class/Schema.pm | 31 ++++++++------- lib/DBIx/Class/Schema/Versioned.pm | 20 +++++----- lib/DBIx/Class/Storage.pm | 7 +++- lib/DBIx/Class/UTF8Columns.pm | 4 +- lib/DBIx/Class/_Util.pm | 4 +- t/cdbi/02-Film.t | 2 +- t/cdbi/09-has_many.t | 2 +- 34 files changed, 206 insertions(+), 151 deletions(-) diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index 79d763081..f1c80aea2 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -53,7 +53,7 @@ sub inject_base { sub MODIFY_CODE_ATTRIBUTES { my ($class,$code,@attrs) = @_; - $class->mk_classdata('__attr_cache' => {}) + $class->mk_classaccessor('__attr_cache' => {}) unless $class->can('__attr_cache'); $class->__attr_cache->{$code} = [@attrs]; return (); diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index 12a8744b2..01a5559d1 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -5,16 +5,21 @@ use warnings; use base qw/Class::Accessor::Grouped/; use Scalar::Util qw/weaken blessed/; +use DBIx::Class::_Util 'fail_on_internal_call'; use namespace::clean; sub mk_classdata { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->mk_classaccessor(@_); } sub mk_classaccessor { my $self = shift; $self->mk_group_accessors('inherited', $_[0]); - $self->set_inherited(@_) if @_ > 1; + (@_ > 1) + ? $self->set_inherited(@_) + : ( DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call ) + ; } my $successfully_loaded_components; diff --git a/lib/DBIx/Class/Admin.pm b/lib/DBIx/Class/Admin.pm index f3e6b5876..ed8ae7d3f 100644 --- a/lib/DBIx/Class/Admin.pm +++ b/lib/DBIx/Class/Admin.pm @@ -92,7 +92,7 @@ sub _build_schema { my ($self) = @_; $self->connect_info->[3]{ignore_version} = 1; - return $self->schema_class->connect(@{$self->connect_info}); + return $self->schema_class->clone->connection(@{$self->connect_info}); } =head2 resultset diff --git a/lib/DBIx/Class/CDBICompat/AutoUpdate.pm b/lib/DBIx/Class/CDBICompat/AutoUpdate.pm index 16f2164eb..f7ba08500 100644 --- a/lib/DBIx/Class/CDBICompat/AutoUpdate.pm +++ b/lib/DBIx/Class/CDBICompat/AutoUpdate.pm @@ -6,7 +6,7 @@ use warnings; use base 'DBIx::Class'; -__PACKAGE__->mk_classdata('__AutoCommit'); +__PACKAGE__->mk_group_accessors( inherited => '__AutoCommit' ); sub set_column { my $self = shift; diff --git a/lib/DBIx/Class/CDBICompat/LazyLoading.pm b/lib/DBIx/Class/CDBICompat/LazyLoading.pm index a9e41af51..b79a096a5 100644 --- a/lib/DBIx/Class/CDBICompat/LazyLoading.pm +++ b/lib/DBIx/Class/CDBICompat/LazyLoading.pm @@ -98,7 +98,7 @@ sub _flesh { my %want; $want{$_} = 1 for map { keys %{$self->_column_groups->{$_}} } @groups; if (my @want = grep { !exists $self->{'_column_data'}{$_} } keys %want) { - my $cursor = $self->result_source->storage->select( + my $cursor = $self->result_source->schema->storage->select( $self->result_source->name, \@want, \$self->_ident_cond, { bind => [ $self->_ident_values ] }); #my $sth = $self->storage->select($self->_table_name, \@want, diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm index 658305dcc..a5bfa5e5c 100644 --- a/lib/DBIx/Class/CDBICompat/Relationships.pm +++ b/lib/DBIx/Class/CDBICompat/Relationships.pm @@ -129,7 +129,7 @@ sub has_many { if (@f_method) { quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel), { '$rf' => \sub { my $o = shift; $o = $o->$_ for @f_method; $o } }; - my $rs = shift->search_related( %s => @_); + my $rs = shift->related_resultset(%s)->search_rs( @_); $rs->{attrs}{record_filter} = $rf; return (wantarray ? $rs->all : $rs); EOC @@ -213,7 +213,7 @@ sub search { } sub new_related { - return shift->search_related(shift)->new_result(shift); + return shift->search_related(shift)->new_result(@_); } =head1 FURTHER QUESTIONS? diff --git a/lib/DBIx/Class/DB.pm b/lib/DBIx/Class/DB.pm index b7e539473..235b6bf8e 100644 --- a/lib/DBIx/Class/DB.pm +++ b/lib/DBIx/Class/DB.pm @@ -61,7 +61,7 @@ it. See resolve_class below. =cut -__PACKAGE__->mk_classdata('class_resolver' => +__PACKAGE__->mk_classaccessor('class_resolver' => 'DBIx::Class::ClassResolver::PassThrough'); =begin hidden @@ -101,7 +101,7 @@ sub setup_schema_instance { my $class = shift; my $schema = {}; bless $schema, 'DBIx::Class::Schema'; - $class->mk_classdata('schema_instance' => $schema); + $class->mk_classaccessor('schema_instance' => $schema); } =begin hidden @@ -189,7 +189,7 @@ Returns an instance of the result source for this class =cut -__PACKAGE__->mk_classdata('_result_source_instance' => []); +__PACKAGE__->mk_classaccessor('_result_source_instance' => []); # Yep. this is horrific. Basically what's happening here is that # (with good reason) DBIx::Class::Schema copies the result source for diff --git a/lib/DBIx/Class/FilterColumn.pm b/lib/DBIx/Class/FilterColumn.pm index b7860c95a..18f99a821 100644 --- a/lib/DBIx/Class/FilterColumn.pm +++ b/lib/DBIx/Class/FilterColumn.pm @@ -9,13 +9,13 @@ use namespace::clean; sub filter_column { my ($self, $col, $attrs) = @_; - my $colinfo = $self->column_info($col); + my $colinfo = $self->result_source_instance->column_info($col); $self->throw_exception("FilterColumn can not be used on a column with a declared InflateColumn inflator") if defined $colinfo->{_inflate_info} and $self->isa('DBIx::Class::InflateColumn'); $self->throw_exception("No such column $col to filter") - unless $self->has_column($col); + unless $self->result_source_instance->has_column($col); $self->throw_exception('filter_column expects a hashref of filter specifications') unless ref $attrs eq 'HASH'; diff --git a/lib/DBIx/Class/InflateColumn.pm b/lib/DBIx/Class/InflateColumn.pm index 27bde589e..08b1b54b6 100644 --- a/lib/DBIx/Class/InflateColumn.pm +++ b/lib/DBIx/Class/InflateColumn.pm @@ -87,13 +87,13 @@ L sub inflate_column { my ($self, $col, $attrs) = @_; - my $colinfo = $self->column_info($col); + my $colinfo = $self->result_source_instance->column_info($col); $self->throw_exception("InflateColumn can not be used on a column with a declared FilterColumn filter") if defined $colinfo->{_filter_info} and $self->isa('DBIx::Class::FilterColumn'); $self->throw_exception("No such column $col to inflate") - unless $self->has_column($col); + unless $self->result_source_instance->has_column($col); $self->throw_exception("inflate_column needs attr hashref") unless ref $attrs eq 'HASH'; $colinfo->{_inflate_info} = $attrs; diff --git a/lib/DBIx/Class/InflateColumn/DateTime.pm b/lib/DBIx/Class/InflateColumn/DateTime.pm index 8ccdf7ab1..bb6223d69 100644 --- a/lib/DBIx/Class/InflateColumn/DateTime.pm +++ b/lib/DBIx/Class/InflateColumn/DateTime.pm @@ -219,7 +219,7 @@ sub _deflate_from_datetime { } sub _datetime_parser { - shift->result_source->storage->datetime_parser (@_); + shift->result_source->schema->storage->datetime_parser (@_); } sub _post_inflate_datetime { diff --git a/lib/DBIx/Class/Ordered.pm b/lib/DBIx/Class/Ordered.pm index 0c572e8c4..bf7f954ff 100644 --- a/lib/DBIx/Class/Ordered.pm +++ b/lib/DBIx/Class/Ordered.pm @@ -106,7 +106,7 @@ positional value of each record. Defaults to "position". =cut -__PACKAGE__->mk_classdata( 'position_column' => 'position' ); +__PACKAGE__->mk_classaccessor( 'position_column' => 'position' ); =head2 grouping_column @@ -118,7 +118,7 @@ ordered lists within the same table. =cut -__PACKAGE__->mk_classdata( 'grouping_column' ); +__PACKAGE__->mk_group_accessors( inherited => 'grouping_column' ); =head2 null_position_value @@ -133,7 +133,7 @@ indeed start from 0. =cut -__PACKAGE__->mk_classdata( 'null_position_value' => 0 ); +__PACKAGE__->mk_classaccessor( 'null_position_value' => 0 ); =head2 siblings @@ -680,7 +680,7 @@ L below. Defaults to 1. =cut -__PACKAGE__->mk_classdata( '_initial_position_value' => 1 ); +__PACKAGE__->mk_classaccessor( '_initial_position_value' => 1 ); =head2 _next_position_value diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index e34294d1d..fae251ee6 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -54,7 +54,7 @@ sub add_relationship_accessor { $rsrc->relationship_info(%1$s)->{attrs}{undef_on_null_fk} ); - my $val = $self->search_related( %1$s )->single; + my $val = $self->related_resultset( %1$s )->single; return $val unless $val; # $val instead of undef so that null-objects can go through return $self->{_relationship_data}{%1$s} = $val; @@ -63,14 +63,16 @@ EOC } elsif ($acc_type eq 'filter') { $class->throw_exception("No such column '$rel' to filter") - unless $class->has_column($rel); + unless $class->result_source_instance->has_column($rel); - my $f_class = $class->relationship_info($rel)->{class}; + my $f_class = $class->result_source_instance + ->relationship_info($rel) + ->{class}; $class->inflate_column($rel, { inflate => sub { my ($val, $self) = @_; - return $self->find_or_new_related($rel, {}, {}); + return $self->find_or_new_related($rel, {}); }, deflate => sub { my ($val, $self) = @_; @@ -98,11 +100,11 @@ EOC } elsif ($acc_type eq 'multi') { - quote_sub "${class}::${rel}_rs", "shift->search_related_rs( $rel => \@_ )"; - quote_sub "${class}::add_to_${rel}", "shift->create_related( $rel => \@_ )"; + quote_sub "${class}::${rel}_rs", "shift->related_resultset('$rel')->search_rs( \@_ )"; + quote_sub "${class}::add_to_${rel}", "shift->related_resultset('$rel')->new_result( \@_ )->insert"; quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel ); DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; - shift->search_related( %s => @_ ) + shift->related_resultset(%s)->search( @_ ) EOC } else { diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index f5d34f81d..323c31ea8 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -7,7 +7,7 @@ use base qw/DBIx::Class/; use Scalar::Util qw/weaken blessed/; use Try::Tiny; -use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION'; +use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION fail_on_internal_call ); use namespace::clean; =head1 NAME @@ -565,7 +565,7 @@ sub related_resultset { $rsrc->resultset->search( $self->ident_condition($obj_table_alias), { alias => $obj_table_alias }, - )->search_related('me', undef, $rel_info->{attrs}) + )->related_resultset('me')->search(undef, $rel_info->{attrs}) } else { @@ -612,7 +612,8 @@ See L for more information. =cut sub search_related { - return shift->related_resultset(shift)->search(@_); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->related_resultset(shift)->search(@_); } =head2 search_related_rs @@ -623,7 +624,8 @@ it guarantees a resultset, even in list context. =cut sub search_related_rs { - return shift->related_resultset(shift)->search_rs(@_); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->related_resultset(shift)->search_rs(@_) } =head2 count_related @@ -642,7 +644,8 @@ current result or where conditions. =cut sub count_related { - shift->search_related(@_)->count; + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->related_resultset(shift)->search_rs(@_)->count; } =head2 new_related @@ -665,7 +668,7 @@ your storage until you call L on it. sub new_related { my ($self, $rel, $data) = @_; - return $self->search_related($rel)->new_result( $self->result_source->_resolve_relationship_condition ( + $self->related_resultset($rel)->new_result( $self->result_source->_resolve_relationship_condition ( infer_values_based_on => $data, rel_name => $rel, self_result_object => $self, @@ -719,7 +722,8 @@ See L for details. sub find_related { #my ($self, $rel, @args) = @_; - return shift->search_related(shift)->find(@_); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + return shift->related_resultset(shift)->find(@_); } =head2 find_or_new_related @@ -739,8 +743,9 @@ for details. sub find_or_new_related { my $self = shift; - my $obj = $self->find_related(@_); - return defined $obj ? $obj : $self->new_related(@_); + my $rel = shift; + my $obj = $self->related_resultset($rel)->find(@_); + return defined $obj ? $obj : $self->related_resultset($rel)->new_result(@_); } =head2 find_or_create_related @@ -760,8 +765,9 @@ L for details. sub find_or_create_related { my $self = shift; - my $obj = $self->find_related(@_); - return (defined($obj) ? $obj : $self->create_related(@_)); + my $rel = shift; + my $obj = $self->related_resultset($rel)->find(@_); + return (defined($obj) ? $obj : $self->related_resultset($rel)->new_result(@_)->insert); } =head2 update_or_create_related @@ -781,6 +787,7 @@ L for details. sub update_or_create_related { #my ($self, $rel, @args) = @_; + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->related_resultset(shift)->update_or_create(@_); } @@ -868,8 +875,9 @@ And returns the result of that. sub delete_related { my $self = shift; - my $obj = $self->search_related(@_)->delete; - delete $self->{related_resultsets}->{$_[0]}; + my $rel = shift; + my $obj = $self->related_resultset($rel)->search_rs(@_)->delete; + delete $self->{related_resultsets}->{$rel}; return $obj; } diff --git a/lib/DBIx/Class/Relationship/BelongsTo.pm b/lib/DBIx/Class/Relationship/BelongsTo.pm index a3e7dbc16..cadca9297 100644 --- a/lib/DBIx/Class/Relationship/BelongsTo.pm +++ b/lib/DBIx/Class/Relationship/BelongsTo.pm @@ -39,7 +39,7 @@ sub belongs_to { $class->throw_exception( "No such column '$f_key' declared yet on ${class} ($guess)" - ) unless $class->has_column($f_key); + ) unless $class->result_source_instance->has_column($f_key); $class->ensure_class_loaded($f_class); my $f_rsrc = dbic_internal_try { @@ -81,7 +81,7 @@ sub belongs_to { and (keys %$cond)[0] =~ /^foreign\./ and - $class->has_column($rel) + $class->result_source_instance->has_column($rel) ) ? 'filter' : 'single'; my $fk_columns = ($acc_type eq 'single' and ref $cond eq 'HASH') diff --git a/lib/DBIx/Class/Relationship/CascadeActions.pm b/lib/DBIx/Class/Relationship/CascadeActions.pm index 59aefc12e..6fcfbe600 100644 --- a/lib/DBIx/Class/Relationship/CascadeActions.pm +++ b/lib/DBIx/Class/Relationship/CascadeActions.pm @@ -29,7 +29,7 @@ sub delete { my $ret = $self->next::method(@rest); foreach my $rel (@cascade) { - if( my $rel_rs = dbic_internal_try { $self->search_related($rel) } ) { + if( my $rel_rs = dbic_internal_try { $self->related_resultset($rel) } ) { $rel_rs->delete_all; } else { carp "Skipping cascade delete on relationship '$rel' - related resultsource '$rels{$rel}{class}' is not registered with this schema"; diff --git a/lib/DBIx/Class/Relationship/HasOne.pm b/lib/DBIx/Class/Relationship/HasOne.pm index 3141259fd..665d13190 100644 --- a/lib/DBIx/Class/Relationship/HasOne.pm +++ b/lib/DBIx/Class/Relationship/HasOne.pm @@ -98,8 +98,8 @@ sub _validate_has_one_condition { my $key = $1; $class->throw_exception("Defining rel on ${class} that includes '$key' but no such column defined here yet") - unless $class->has_column($key); - my $column_info = $class->column_info($key); + unless $class->result_source_instance->has_column($key); + my $column_info = $class->result_source_instance->column_info($key); if ( $column_info->{is_nullable} ) { carp(qq'"might_have/has_one" must not be on columns with is_nullable set to true ($class/$key). This might indicate an incorrect use of those relationship helpers instead of belongs_to.'); } diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm index c000a84bd..1cf6b0278 100644 --- a/lib/DBIx/Class/Relationship/ManyToMany.pm +++ b/lib/DBIx/Class/Relationship/ManyToMany.pm @@ -65,14 +65,14 @@ EOW # this little horror is there replicating a deprecation from # within search_rs() itself - shift->search_related_rs( q{%1$s} ) - ->search_related_rs( - q{%2$s}, - undef, - ( @_ > 1 and ref $_[-1] eq 'HASH' ) - ? { %%$rel_attrs, %%{ pop @_ } } - : $rel_attrs - )->search_rs(@_) + shift->related_resultset( q{%1$s} ) + ->related_resultset( q{%2$s} ) + ->search_rs ( + undef, + ( @_ > 1 and ref $_[-1] eq 'HASH' ) + ? { %%$rel_attrs, %%{ pop @_ } } + : $rel_attrs + )->search_rs(@_) ; EOC @@ -164,13 +164,13 @@ EOC # if there is a where clause in the attributes, ensure we only delete # rows that are within the where restriction - $self->search_related( - q{%3$s}, - ( $rel_attrs->{where} - ? ( $rel_attrs->{where}, { join => q{%4$s} } ) - : () - ) - )->delete; + $self->related_resultset( q{%3$s} ) + ->search_rs( + ( $rel_attrs->{where} + ? ( $rel_attrs->{where}, { join => q{%4$s} } ) + : () + ) + )->delete; # add in the set rel objects $self->%2$s( @@ -187,7 +187,7 @@ EOC $_[0]->throw_exception("'%1$s' expects an object") unless defined Scalar::Util::blessed( $_[1] ); - $_[0]->search_related_rs( q{%2$s} ) + $_[0]->related_resultset( q{%2$s} ) ->search_rs( $_[1]->ident_condition( q{%3$s} ), { join => q{%3$s} } ) ->delete; EOC diff --git a/lib/DBIx/Class/Relationship/ProxyMethods.pm b/lib/DBIx/Class/Relationship/ProxyMethods.pm index 0db5780da..f7585a7db 100644 --- a/lib/DBIx/Class/Relationship/ProxyMethods.pm +++ b/lib/DBIx/Class/Relationship/ProxyMethods.pm @@ -28,7 +28,7 @@ sub proxy_to_related { my $self = shift; my $relobj = $self->%1$s; if (@_ && !defined $relobj) { - $relobj = $self->create_related( %1$s => { %2$s => $_[0] } ); + $relobj = $self->related_resultset(q{%1$s})->new_result({ %2$s => $_[0] })->insert; @_ = (); } $relobj ? $relobj->%2$s(@_) : undef; diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 1231a07c1..6dbc7caec 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -988,6 +988,7 @@ See also L. =cut sub search_related { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return shift->related_resultset(shift)->search(@_); } @@ -999,6 +1000,7 @@ it guarantees a resultset, even in list context. =cut sub search_related_rs { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return shift->related_resultset(shift)->search_rs(@_); } @@ -1022,7 +1024,7 @@ sub cursor { return $self->{cursor} ||= do { my $attrs = $self->_resolved_attrs; - $self->result_source->storage->select( + $self->result_source->schema->storage->select( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs ); }; @@ -1095,7 +1097,7 @@ sub single { } } - my $data = [ $self->result_source->storage->select_single( + my $data = [ $self->result_source->schema->storage->select_single( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs )]; @@ -1122,9 +1124,7 @@ Returns a L instance for a column of the ResultSet =cut sub get_column { - my ($self, $column) = @_; - my $new = DBIx::Class::ResultSetColumn->new($self, $column); - return $new; + DBIx::Class::ResultSetColumn->new(@_); } =head2 search_like @@ -1649,7 +1649,7 @@ sub _count_rs { # overwrite the selector (supplied by the storage) $rsrc->resultset_class->new($rsrc, { %$tmp_attrs, - select => $rsrc->storage->_count_select ($rsrc, $attrs), + select => $rsrc->schema->storage->_count_select ($rsrc, $attrs), as => 'count', })->get_column ('count'); } @@ -1680,7 +1680,7 @@ sub _count_subq_rs { # Calculate subquery selector if (my $g = $sub_attrs->{group_by}) { - my $sql_maker = $rsrc->storage->sql_maker; + my $sql_maker = $rsrc->schema->storage->sql_maker; # necessary as the group_by may refer to aliased functions my $sel_index; @@ -1747,7 +1747,7 @@ sub _count_subq_rs { return $rsrc->resultset_class ->new ($rsrc, $sub_attrs) ->as_subselect_rs - ->search ({}, { columns => { count => $rsrc->storage->_count_select ($rsrc, $attrs) } }) + ->search ({}, { columns => { count => $rsrc->schema->storage->_count_select ($rsrc, $attrs) } }) ->get_column ('count'); } @@ -1770,7 +1770,10 @@ with the passed arguments, then L. =cut -sub count_literal { shift->search_literal(@_)->count; } +sub count_literal { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->search_literal(@_)->count +} =head2 all @@ -1848,6 +1851,7 @@ an object for the first result (or C if the resultset is empty). =cut sub first { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return $_[0]->reset->next; } @@ -1904,7 +1908,7 @@ sub _rs_update_delete { # a condition containing 'me' or other table prefixes will not work # at all. Tell SQLMaker to dequalify idents via a gross hack. $cond = do { - my $sqla = $rsrc->storage->sql_maker; + my $sqla = $rsrc->schema->storage->sql_maker; local $sqla->{_dequalify_idents} = 1; \[ $sqla->_recurse_where($self->{cond}) ]; }; @@ -2413,7 +2417,7 @@ sub populate { ### main source data # FIXME - need to switch entirely to a coderef-based thing, # so that large sets aren't copied several times... I think - $rsrc->storage->_insert_bulk( + $rsrc->schema->storage->_insert_bulk( $rsrc, [ @$colnames, sort keys %$rs_data ], [ map { @@ -2564,11 +2568,8 @@ Passes the hashref of input on to L. sub new_result { my ($self, $values) = @_; - $self->throw_exception( "new_result takes only one argument - a hashref of values" ) - if @_ > 2; - - $self->throw_exception( "Result object instantiation requires a hashref as argument" ) - unless (ref $values eq 'HASH'); + $self->throw_exception( "Result object instantiation requires a single hashref argument" ) + if @_ > 2 or ref $values ne 'HASH'; my ($merged_cond, $cols_from_relations) = $self->_merge_with_rscond($values); @@ -2732,7 +2733,7 @@ sub as_query { my $attrs = { %{ $self->_resolved_attrs } }; - my $aq = $self->result_source->storage->_select_args_to_query ( + my $aq = $self->result_source->schema->storage->_select_args_to_query ( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs ); @@ -3185,7 +3186,7 @@ sub is_paged { sub is_ordered { my ($self) = @_; - return scalar $self->result_source->storage->_extract_order_criteria($self->{attrs}{order_by}); + return scalar $self->result_source->schema->storage->_extract_order_criteria($self->{attrs}{order_by}); } =head2 related_resultset @@ -3714,7 +3715,7 @@ sub _resolved_attrs { else { $attrs->{_grouped_by_distinct} = 1; # distinct affects only the main selection part, not what prefetch may add below - ($attrs->{group_by}, my $new_order) = $source->storage->_group_over_selection($attrs); + ($attrs->{group_by}, my $new_order) = $source->schema->storage->_group_over_selection($attrs); # FIXME possibly ignore a rewritten order_by (may turn out to be an issue) # The thinking is: if we are collapsing the subquerying prefetch engine will diff --git a/lib/DBIx/Class/ResultSetColumn.pm b/lib/DBIx/Class/ResultSetColumn.pm index 8d9d7a322..71cd52c8c 100644 --- a/lib/DBIx/Class/ResultSetColumn.pm +++ b/lib/DBIx/Class/ResultSetColumn.pm @@ -5,7 +5,7 @@ use warnings; use base 'DBIx::Class'; use DBIx::Class::Carp; -use DBIx::Class::_Util 'fail_on_internal_wantarray'; +use DBIx::Class::_Util qw( fail_on_internal_wantarray fail_on_internal_call ); use namespace::clean; =head1 NAME @@ -254,7 +254,7 @@ sub single { my $self = shift; my $attrs = $self->_resultset->_resolved_attrs; - my ($row) = $self->_resultset->result_source->storage->select_single( + my ($row) = $self->_resultset->result_source->schema->storage->select_single( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs ); @@ -279,7 +279,8 @@ resultset (or C if there are none). =cut sub min { - return shift->func('MIN'); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->func('MIN'); } =head2 min_rs @@ -298,7 +299,10 @@ Wrapper for ->func_rs for function MIN(). =cut -sub min_rs { return shift->func_rs('MIN') } +sub min_rs { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->func_rs('MIN') +} =head2 max @@ -318,7 +322,8 @@ resultset (or C if there are none). =cut sub max { - return shift->func('MAX'); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->func('MAX'); } =head2 max_rs @@ -337,7 +342,10 @@ Wrapper for ->func_rs for function MAX(). =cut -sub max_rs { return shift->func_rs('MAX') } +sub max_rs { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->func_rs('MAX') +} =head2 sum @@ -357,7 +365,8 @@ the resultset. Use on varchar-like columns at your own risk. =cut sub sum { - return shift->func('SUM'); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->func('SUM'); } =head2 sum_rs @@ -376,7 +385,10 @@ Wrapper for ->func_rs for function SUM(). =cut -sub sum_rs { return shift->func_rs('SUM') } +sub sum_rs { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->func_rs('SUM') +} =head2 func @@ -491,7 +503,7 @@ sub _resultset { # collapse the selector to a literal so that it survives the distinct parse # if it turns out to be an aggregate - at least the user will get a proper exception # instead of silent drop of the group_by altogether - $select = \[ $rsrc->storage->sql_maker->_recurse_fields($select) ]; + $select = \[ $rsrc->schema->storage->sql_maker->_recurse_fields($select) ]; } } diff --git a/lib/DBIx/Class/ResultSetManager.pm b/lib/DBIx/Class/ResultSetManager.pm index 1c7cf45aa..3ae9502c7 100644 --- a/lib/DBIx/Class/ResultSetManager.pm +++ b/lib/DBIx/Class/ResultSetManager.pm @@ -29,8 +29,9 @@ appropriate My::Schema::ResultSet::* classes for it to pick up."; =cut -__PACKAGE__->mk_classdata($_) - for qw/ base_resultset_class table_resultset_class_suffix /; +__PACKAGE__->mk_group_accessors(inherited => qw( + base_resultset_class table_resultset_class_suffix +)); __PACKAGE__->base_resultset_class('DBIx::Class::ResultSet'); __PACKAGE__->table_resultset_class_suffix('::_resultset'); diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index d2cc10f6a..aacf1258f 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -9,7 +9,7 @@ __PACKAGE__->load_components(qw( )); use DBIx::Class::Carp; -use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try ); +use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try fail_on_internal_call ); use SQL::Abstract 'is_literal_value'; use Devel::GlobalDestruction; use Scalar::Util qw/blessed weaken isweak/; @@ -28,7 +28,7 @@ __PACKAGE__->mk_group_accessors(component_class => qw/ result_class /); -__PACKAGE__->mk_classdata( sqlt_deploy_callback => 'default_sqlt_deploy_hook' ); +__PACKAGE__->mk_classaccessor( sqlt_deploy_callback => 'default_sqlt_deploy_hook' ); =head1 NAME @@ -402,7 +402,7 @@ sub column_info { if ( ! $self->_columns->{$column}{data_type} and ! $self->{_columns_info_loaded} and $self->column_info_from_storage - and my $stor = dbic_internal_try { $self->storage } ) + and my $stor = dbic_internal_try { $self->schema->storage } ) { $self->{_columns_info_loaded}++; @@ -480,7 +480,7 @@ sub columns_info { and grep { ! $_->{data_type} } values %$colinfo and - my $stor = dbic_internal_try { $self->storage } + my $stor = dbic_internal_try { $self->schema->storage } ) { $self->{_columns_info_loaded}++; @@ -578,7 +578,11 @@ sub remove_columns { $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]); } -sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB +# DO NOT CHANGE THIS TO A GLOB +sub remove_column { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->remove_columns(@_) +} =head2 set_primary_key @@ -1254,7 +1258,10 @@ Returns the L for the current schema. =cut -sub storage { shift->schema->storage; } +sub storage { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->schema->storage +} =head2 add_relationship @@ -1377,7 +1384,7 @@ Returns all relationship names for this source. =cut sub relationships { - return keys %{shift->_relationships}; + keys %{$_[0]->_relationships}; } =head2 relationship_info @@ -1559,7 +1566,7 @@ sub _minimal_valueset_satisfying_constraint { $args->{columns_info} ||= $self->columns_info; - my $vals = $self->storage->_extract_fixed_condition_columns( + my $vals = $self->schema->storage->_extract_fixed_condition_columns( $args->{values}, ($args->{carp_on_nulls} ? 'consider_nulls' : undef ), ); @@ -1648,7 +1655,7 @@ sub _resolve_join { $force_left ||= lc($rel_info->{attrs}{join_type}||'') eq 'left'; # the actual seen value will be incremented by the recursion - my $as = $self->storage->relname_to_table_alias( + my $as = $self->schema->storage->relname_to_table_alias( $rel, ($seen->{$rel} && $seen->{$rel} + 1) ); @@ -1667,7 +1674,7 @@ sub _resolve_join { } else { my $count = ++$seen->{$join}; - my $as = $self->storage->relname_to_table_alias( + my $as = $self->schema->storage->relname_to_table_alias( $join, ($count > 1 && $count) ); diff --git a/lib/DBIx/Class/ResultSource/Table.pm b/lib/DBIx/Class/ResultSource/Table.pm index ac7d30886..b6add2ae0 100644 --- a/lib/DBIx/Class/ResultSource/Table.pm +++ b/lib/DBIx/Class/ResultSource/Table.pm @@ -26,7 +26,7 @@ Returns the FROM entry for the table (i.e. the table name) =cut -sub from { shift->name; } +sub from { $_[0]->name } =head1 FURTHER QUESTIONS? diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm index 62c056428..94009a5a0 100644 --- a/lib/DBIx/Class/ResultSourceProxy.pm +++ b/lib/DBIx/Class/ResultSourceProxy.pm @@ -8,7 +8,7 @@ use base 'DBIx::Class'; use mro 'c3'; use Scalar::Util 'blessed'; -use DBIx::Class::_Util 'quote_sub'; +use DBIx::Class::_Util qw( quote_sub fail_on_internal_call ); use namespace::clean; __PACKAGE__->mk_group_accessors('inherited_ro_instance' => 'source_name'); @@ -37,7 +37,10 @@ sub add_columns { } } -sub add_column { shift->add_columns(@_) } +sub add_column { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->add_columns(@_) +} sub add_relationship { @@ -49,7 +52,10 @@ sub add_relationship { # legacy resultset_class accessor, seems to be used by cdbi only -sub iterator_class { shift->result_source_instance->resultset_class(@_) } +sub iterator_class { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->result_source_instance->resultset_class(@_) +} for my $method_to_proxy (qw/ source_info diff --git a/lib/DBIx/Class/ResultSourceProxy/Table.pm b/lib/DBIx/Class/ResultSourceProxy/Table.pm index 647a4089c..d6bac68f4 100644 --- a/lib/DBIx/Class/ResultSourceProxy/Table.pm +++ b/lib/DBIx/Class/ResultSourceProxy/Table.pm @@ -9,20 +9,20 @@ use DBIx::Class::ResultSource::Table; use Scalar::Util 'blessed'; use namespace::clean; -__PACKAGE__->mk_classdata(table_class => 'DBIx::Class::ResultSource::Table'); +__PACKAGE__->mk_classaccessor(table_class => 'DBIx::Class::ResultSource::Table'); -__PACKAGE__->mk_classdata('table_alias'); # FIXME: Doesn't actually do - # anything yet! +# FIXME: Doesn't actually do anything yet! +__PACKAGE__->mk_group_accessors( inherited => 'table_alias' ); sub _init_result_source_instance { my $class = shift; - $class->mk_classdata('result_source_instance') - unless $class->can('result_source_instance'); + $class->mk_group_accessors( inherited => 'result_source_instance' ) + unless $class->can('result_source_instance'); my $table = $class->result_source_instance; - my $class_has_table_instance = ($table and $table->result_class eq $class); - return $table if $class_has_table_instance; + return $table + if $table and $table->result_class eq $class; my $table_class = $class->table_class; $class->ensure_class_loaded($table_class); @@ -96,7 +96,7 @@ sub table { }); } - $class->mk_classdata('result_source_instance') + $class->mk_group_accessors(inherited => 'result_source_instance') unless $class->can('result_source_instance'); $class->result_source_instance($table); diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 5c4cead70..f42092a37 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -6,7 +6,7 @@ use warnings; use base qw/DBIx::Class/; use Scalar::Util 'blessed'; -use DBIx::Class::_Util 'dbic_internal_try'; +use DBIx::Class::_Util qw( dbic_internal_try fail_on_internal_call ); use DBIx::Class::Carp; use SQL::Abstract qw( is_literal_value is_plain_value ); @@ -343,7 +343,7 @@ sub insert { $self->throw_exception("No result_source set on this object; can't insert") unless $rsrc; - my $storage = $rsrc->storage; + my $storage = $rsrc->schema->storage; my $rollback_guard; @@ -549,7 +549,7 @@ sub update { $self->throw_exception( "Not in database" ) unless $self->in_storage; - my $rows = $self->result_source->storage->update( + my $rows = $self->result_source->schema->storage->update( $self->result_source, \%to_update, $self->_storage_ident_condition ); if ($rows == 0) { @@ -611,7 +611,7 @@ sub delete { if (ref $self) { $self->throw_exception( "Not in database" ) unless $self->in_storage; - $self->result_source->storage->delete( + $self->result_source->schema->storage->delete( $self->result_source, $self->_storage_ident_condition ); @@ -1192,7 +1192,7 @@ sub copy { foreign_alias => "\xFF", # irrelevant, )->{inferred_values} - ) for $self->search_related($rel_name)->all; + ) for $self->related_resultset($rel_name)->all; } return $new; } @@ -1356,7 +1356,10 @@ Alias for L =cut -sub insert_or_update { shift->update_or_insert(@_) } +sub insert_or_update { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->update_or_insert(@_); +} sub update_or_insert { my $self = shift; diff --git a/lib/DBIx/Class/SQLMaker/LimitDialects.pm b/lib/DBIx/Class/SQLMaker/LimitDialects.pm index e6132d633..89e63e092 100644 --- a/lib/DBIx/Class/SQLMaker/LimitDialects.pm +++ b/lib/DBIx/Class/SQLMaker/LimitDialects.pm @@ -275,7 +275,7 @@ EOS if ( $rs_attrs->{order_by} and - $rs_attrs->{result_source}->storage->_order_by_is_stable( + $rs_attrs->{result_source}->schema->storage->_order_by_is_stable( @{$rs_attrs}{qw/from order_by where/} ) ) { @@ -540,7 +540,7 @@ sub _GenericSubQ { . 'main-table-based order criteria.' ) unless $rs_attrs->{order_by}; - my $usable_order_colinfo = $main_rsrc->storage->_extract_colinfo_of_stable_main_source_order_by_portion( + my $usable_order_colinfo = $main_rsrc->schema->storage->_extract_colinfo_of_stable_main_source_order_by_portion( $rs_attrs ); diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 04f92ccf1..c0cba10c2 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -12,17 +12,17 @@ use Scalar::Util qw/weaken blessed/; use DBIx::Class::_Util qw( refcount quote_sub scope_guard is_exception dbic_internal_try + fail_on_internal_call ); use Devel::GlobalDestruction; use namespace::clean; -__PACKAGE__->mk_classdata('class_mappings' => {}); -__PACKAGE__->mk_classdata('source_registrations' => {}); -__PACKAGE__->mk_classdata('storage_type' => '::DBI'); -__PACKAGE__->mk_classdata('storage'); -__PACKAGE__->mk_classdata('exception_action'); -__PACKAGE__->mk_classdata('stacktrace' => $ENV{DBIC_TRACE} || 0); -__PACKAGE__->mk_classdata('default_resultset_attributes' => {}); +__PACKAGE__->mk_group_accessors( inherited => qw( storage exception_action ) ); +__PACKAGE__->mk_classaccessor('class_mappings' => {}); +__PACKAGE__->mk_classaccessor('source_registrations' => {}); +__PACKAGE__->mk_classaccessor('storage_type' => '::DBI'); +__PACKAGE__->mk_classaccessor('stacktrace' => $ENV{DBIC_TRACE} || 0); +__PACKAGE__->mk_classaccessor('default_resultset_attributes' => {}); =head1 NAME @@ -525,7 +525,10 @@ version, overload L instead. =cut -sub connect { shift->clone->connection(@_) } +sub connect { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->clone->connection(@_); +} =head2 resultset @@ -769,6 +772,8 @@ those values. =cut sub populate { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + my ($self, $name, $data) = @_; my $rs = $self->resultset($name) or $self->throw_exception("'$name' is not a resultset"); @@ -1517,8 +1522,8 @@ sub compose_connection { my $source = $self->source($source_name); my $class = $source->result_class; $self->inject_base($class, 'DBIx::Class::ResultSetProxy'); - $class->mk_classdata(resultset_instance => $source->resultset); - $class->mk_classdata(class_resolver => $self); + $class->mk_classaccessor(resultset_instance => $source->resultset); + $class->mk_classaccessor(class_resolver => $self); } $self->connection(@info); return $self; @@ -1532,9 +1537,9 @@ sub compose_connection { my $source = $schema->source($source_name); my $class = $source->result_class; #warn "$source_name $class $source ".$source->storage; - $class->mk_classdata(result_source_instance => $source); - $class->mk_classdata(resultset_instance => $source->resultset); - $class->mk_classdata(class_resolver => $schema); + $class->mk_classaccessor(result_source_instance => $source); + $class->mk_classaccessor(resultset_instance => $source->resultset); + $class->mk_classaccessor(class_resolver => $schema); } return $schema; } diff --git a/lib/DBIx/Class/Schema/Versioned.pm b/lib/DBIx/Class/Schema/Versioned.pm index 013cbc4f3..8101f2e43 100644 --- a/lib/DBIx/Class/Schema/Versioned.pm +++ b/lib/DBIx/Class/Schema/Versioned.pm @@ -26,7 +26,7 @@ __PACKAGE__->add_columns 'size' => '20' }, ); -__PACKAGE__->set_primary_key('version'); +__PACKAGE__->result_source_instance->set_primary_key('version'); package # Hide from PAUSE DBIx::Class::Version::TableCompat; @@ -41,7 +41,7 @@ __PACKAGE__->add_columns 'data_type' => 'VARCHAR', }, ); -__PACKAGE__->set_primary_key('Version'); +__PACKAGE__->result_source_instance->set_primary_key('Version'); package # Hide from PAUSE DBIx::Class::Version; @@ -206,11 +206,13 @@ use DBIx::Class::_Util 'dbic_internal_try'; use Scalar::Util 'weaken'; use namespace::clean; -__PACKAGE__->mk_classdata('_filedata'); -__PACKAGE__->mk_classdata('upgrade_directory'); -__PACKAGE__->mk_classdata('backup_directory'); -__PACKAGE__->mk_classdata('do_backup'); -__PACKAGE__->mk_classdata('do_diff_on_init'); +__PACKAGE__->mk_group_accessors( inherited => qw( + _filedata + upgrade_directory + backup_directory + do_backup + do_diff_on_init +) ); =head1 METHODS @@ -591,7 +593,7 @@ sub _on_connect weaken (my $w_storage = $self->storage ); - $self->{vschema} = DBIx::Class::Version->connect( + $self->{vschema} = DBIx::Class::Version->clone->connection( sub { $w_storage->dbh }, # proxy some flags from the main storage @@ -606,7 +608,7 @@ sub _on_connect # check for legacy versions table and move to new if exists unless ($self->_source_exists($vtable)) { - my $vtable_compat = DBIx::Class::VersionCompat->connect(sub { $w_storage->dbh })->resultset('TableCompat'); + my $vtable_compat = DBIx::Class::VersionCompat->clone->connection(sub { $w_storage->dbh })->resultset('TableCompat'); if ($self->_source_exists($vtable_compat)) { $self->{vschema}->deploy; map { $vtable->new_result({ installed => $_->Installed, version => $_->Version })->insert } $vtable_compat->all; diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm index f51284364..d949b01e4 100644 --- a/lib/DBIx/Class/Storage.pm +++ b/lib/DBIx/Class/Storage.pm @@ -16,7 +16,7 @@ use DBIx::Class::Carp; use DBIx::Class::Storage::BlockRunner; use Scalar::Util qw/blessed weaken/; use DBIx::Class::Storage::TxnScopeGuard; -use DBIx::Class::_Util 'dbic_internal_try'; +use DBIx::Class::_Util qw( dbic_internal_try fail_on_internal_call ); use Try::Tiny; use namespace::clean; @@ -25,7 +25,10 @@ __PACKAGE__->mk_group_accessors(component_class => 'cursor_class'); __PACKAGE__->cursor_class('DBIx::Class::Cursor'); -sub cursor { shift->cursor_class(@_); } +sub cursor { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->cursor_class(@_); +} =head1 NAME diff --git a/lib/DBIx/Class/UTF8Columns.pm b/lib/DBIx/Class/UTF8Columns.pm index 793c1bc9b..38a4dd412 100644 --- a/lib/DBIx/Class/UTF8Columns.pm +++ b/lib/DBIx/Class/UTF8Columns.pm @@ -3,7 +3,7 @@ use strict; use warnings; use base qw/DBIx::Class/; -__PACKAGE__->mk_classdata( '_utf8_columns' ); +__PACKAGE__->mk_group_accessors( inherited => '_utf8_columns' ); =head1 NAME @@ -94,7 +94,7 @@ sub utf8_columns { if (@_) { foreach my $col (@_) { $self->throw_exception("column $col doesn't exist") - unless $self->has_column($col); + unless $self->result_source_instance->has_column($col); } return $self->_utf8_columns({ map { $_ => 1 } @_ }); } else { diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index f64e04b8e..3f60d3f2c 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -577,7 +577,7 @@ sub fail_on_internal_call { $fr = [ CORE::caller(1) ]; $argdesc = ref $DB::args[0] ? DBIx::Class::_Util::refdesc($DB::args[0]) - : undef + : ( $DB::args[0] . '' ) ; }; @@ -589,7 +589,7 @@ sub fail_on_internal_call { $fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there ) { DBIx::Class::Exception->throw( sprintf ( - "Illegal internal call of indirect proxy-method %s() with argument %s: examine the last lines of the proxy method deparse below to determine what to call directly instead at %s on line %d\n\n%s\n\n Stacktrace starts", + "Illegal internal call of indirect proxy-method %s() with argument '%s': examine the last lines of the proxy method deparse below to determine what to call directly instead at %s on line %d\n\n%s\n\n Stacktrace starts", $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do { require B::Deparse; no strict 'refs'; diff --git a/t/cdbi/02-Film.t b/t/cdbi/02-Film.t index 95a460f5e..b8159c4cc 100644 --- a/t/cdbi/02-Film.t +++ b/t/cdbi/02-Film.t @@ -33,7 +33,7 @@ is(Film->__driver, "SQLite", "Driver set correctly"); } eval { my $duh = Film->insert; }; -like $@, qr/Result object instantiation requires a hashref as argument/, "needs a hashref"; +like $@, qr/Result object instantiation requires a single hashref argument/, "needs a hashref"; ok +Film->create_test_film; diff --git a/t/cdbi/09-has_many.t b/t/cdbi/09-has_many.t index bac11ed9b..c06365728 100644 --- a/t/cdbi/09-has_many.t +++ b/t/cdbi/09-has_many.t @@ -50,7 +50,7 @@ eval { my $pj = Film->add_to_actors(\%pj_data) }; like $@, qr/class/, "add_to_actors must be object method"; eval { my $pj = $btaste->add_to_actors(%pj_data) }; -like $@, qr/Result object instantiation requires a hashref as argument/, "add_to_actors takes hash"; +like $@, qr/Result object instantiation requires a single hashref argument/, "add_to_actors takes hash"; ok( my $pj = $btaste->add_to_actors( From 1d9c2229153784640763c271088c9bf7d0d25dab Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 29 Apr 2016 18:00:03 +0200 Subject: [PATCH 089/262] Bump Sub::Uplevel dep - too much breaks on <= 0.18 Note that this is a kludge - the guts of ::Carp need to be protected much better by a faulty caller() override (as was the case in RT#32640) An attempt to do so in 821edc09 turned out insufficient - everything still fails on `DBIC_TRACE=1 prove ...` if the older Sub::Uplevel is installed :( --- Changes | 2 -- Makefile.PL | 9 +++++++++ 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/Changes b/Changes index f3bd7539c..e288bb2e5 100644 --- a/Changes +++ b/Changes @@ -80,8 +80,6 @@ Revision history for DBIx::Class - Make the Optional::Dependencies error messages cpanm-friendly - Incompatibly change values (not keys) of the hash returned by Optional::Dependencies::req_group_list (no known users in the wild) - - Protect tests and codebase from incomplete caller() overrides, like - e.g. RT#32640 - Stop using bare $] throughout - protects the codebase from issues similar (but likely not limited to) P5#72210 - Config::Any is no longer a core dep, but instead is migrated to a new diff --git a/Makefile.PL b/Makefile.PL index 9a4f07448..412aa520b 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -76,6 +76,15 @@ my $test_requires = { 'Test::Warn' => '0.21', 'Test::More' => '0.94', + # This has a bug in the caller() override, ideally we need go get rid + # of it entirely, but that's for another maint + # + # FIXME - this does protect tests, but does *NOT* protect the rest of + # DBIC itself from a faulty caller() override. Something more substantial + # needs to be done in the guts of DBIC::Carp + # + 'Sub::Uplevel' => '0.19', + # this is already a dep of n::c, but just in case - used by t/55namespaces_cleaned.t # remove and do a manual glob-collection if n::c is no longer a dep 'Package::Stash' => '0.28', From 1b12190d4ca817eac91f48db668d8fe5c1983495 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 4 May 2016 18:10:33 +0200 Subject: [PATCH 090/262] In d009cb7d I stupidly created a "double around()" Consolidate all the logic in DBIC::Componentised instead --- lib/DBIx/Class.pm | 12 ------------ lib/DBIx/Class/Componentised.pm | 9 +++++++++ 2 files changed, 9 insertions(+), 12 deletions(-) diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index f1c80aea2..e7c6126cc 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -39,18 +39,6 @@ BEGIN { sub component_base_class { 'DBIx::Class' } -my $mro_already_set; -sub inject_base { - - # only examine from $_[2] onwards - # C::C3::C already sets c3 on $_[1] and $_[0] is irrelevant - mro::set_mro( $_ => 'c3' ) for grep { - $mro_already_set->{$_} ? 0 : ( $mro_already_set->{$_} = 1 ) - } @_[2 .. $#_]; - - shift->next::method(@_); -} - sub MODIFY_CODE_ATTRIBUTES { my ($class,$code,@attrs) = @_; $class->mk_classaccessor('__attr_cache' => {}) diff --git a/lib/DBIx/Class/Componentised.pm b/lib/DBIx/Class/Componentised.pm index 0fb91ad01..47797cce1 100644 --- a/lib/DBIx/Class/Componentised.pm +++ b/lib/DBIx/Class/Componentised.pm @@ -12,6 +12,9 @@ use namespace::clean; # this warns of subtle bugs introduced by UTF8Columns hacky handling of store_column # if and only if it is placed before something overriding store_column +# +# and also enforces C3 mro on all components +my $mro_already_set; sub inject_base { my $class = shift; my ($target, @complist) = @_; @@ -72,6 +75,12 @@ sub inject_base { unshift @target_isa, $comp; } + # only examine from $_[2] onwards + # C::C3::C already sets c3 on $_[1] + mro::set_mro( $_ => 'c3' ) for grep { + $mro_already_set->{$_} ? 0 : ( $mro_already_set->{$_} = 1 ) + } @_[1 .. $#_]; + $class->next::method(@_); } From dad6d9e5a228e2d2252c55da913dd4c2b878ee72 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 29 Apr 2016 13:00:35 +0200 Subject: [PATCH 091/262] Pull apart a test section (no functional changes) --- t/relationship/core.t | 16 ----------- .../diagnostics/add_invalid_relationship.t | 28 +++++++++++++++++++ 2 files changed, 28 insertions(+), 16 deletions(-) create mode 100644 xt/extra/diagnostics/add_invalid_relationship.t diff --git a/t/relationship/core.t b/t/relationship/core.t index 9955ce637..be8d7c91d 100644 --- a/t/relationship/core.t +++ b/t/relationship/core.t @@ -139,22 +139,6 @@ throws_ok { $new_bookmark->new_related( no_such_rel => {} ); } qr/No such relationship 'no_such_rel'/, 'creating in uknown rel throws'; -{ - local $TODO = "relationship checking needs fixing"; - # try to add a bogus relationship using the wrong cols - throws_ok { - DBICTest::Schema::Artist->add_relationship( - tracks => 'DBICTest::Schema::Track', - { 'foreign.cd' => 'self.cdid' } - ); - } qr/Unknown column/, 'failed when creating a rel with invalid key, ok'; -} - -# another bogus relationship using no join condition -throws_ok { - DBICTest::Schema::Artist->add_relationship( tracks => 'DBICTest::Track' ); -} qr/join condition/, 'failed when creating a rel without join condition, ok'; - # many_to_many helper tests $cd = $schema->resultset("CD")->find(1); my @producers = $cd->producers(undef, { order_by => 'producerid'} ); diff --git a/xt/extra/diagnostics/add_invalid_relationship.t b/xt/extra/diagnostics/add_invalid_relationship.t new file mode 100644 index 000000000..6562489de --- /dev/null +++ b/xt/extra/diagnostics/add_invalid_relationship.t @@ -0,0 +1,28 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +use DBICTest; + +{ + local $TODO = "relationship checking needs fixing"; + # try to add a bogus relationship using the wrong cols + throws_ok { + DBICTest::Schema::Artist->add_relationship( + tracks => 'DBICTest::Schema::Track', + { 'foreign.cd' => 'self.cdid' } + ); + } qr/Unknown column/, 'failed when creating a rel with invalid key, ok'; +} + +# another bogus relationship using no join condition +throws_ok { + DBICTest::Schema::Artist->add_relationship( tracks => 'DBICTest::Track' ); +} qr/join condition/, 'failed when creating a rel without join condition, ok'; + + +done_testing; From b8e0ecca212fd1ad779865238c8bd4b3c2f62e3f Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 2 May 2016 13:35:40 +0200 Subject: [PATCH 092/262] Explicit exception clarifying that $rsrc->from() is not a setter This has always been the case, but previously from('foo') would just eat the arguments silently --- Changes | 2 ++ lib/DBIx/Class/ResultSource/Table.pm | 5 ++++- lib/DBIx/Class/ResultSource/View.pm | 8 +++++--- 3 files changed, 11 insertions(+), 4 deletions(-) diff --git a/Changes b/Changes index e288bb2e5..edafbfe73 100644 --- a/Changes +++ b/Changes @@ -23,6 +23,8 @@ Revision history for DBIx::Class mismatches between your codebase and data source - Calling the set_* many-to-many helper with a list (instead of an arrayref) now emits a deprecation warning + - Calling the getter $rsrc->from("argument") now throws an exception + instead of silently discarding the argument * New Features - When using non-scalars (e.g. arrays) as literal bind values it is no diff --git a/lib/DBIx/Class/ResultSource/Table.pm b/lib/DBIx/Class/ResultSource/Table.pm index b6add2ae0..f1900f9df 100644 --- a/lib/DBIx/Class/ResultSource/Table.pm +++ b/lib/DBIx/Class/ResultSource/Table.pm @@ -26,7 +26,10 @@ Returns the FROM entry for the table (i.e. the table name) =cut -sub from { $_[0]->name } +sub from { + $_[0]->throw_exception('from() is not a setter method') if @_ > 1; + $_[0]->name; +} =head1 FURTHER QUESTIONS? diff --git a/lib/DBIx/Class/ResultSource/View.pm b/lib/DBIx/Class/ResultSource/View.pm index 4694c8787..846bcf661 100644 --- a/lib/DBIx/Class/ResultSource/View.pm +++ b/lib/DBIx/Class/ResultSource/View.pm @@ -148,9 +148,11 @@ or the SQL as a subselect if this is a virtual view. =cut sub from { - my $self = shift; - return \"(${\$self->view_definition})" if $self->is_virtual; - return $self->name; + $_[0]->throw_exception('from() is not a setter method') if @_ > 1; + $_[0]->is_virtual + ? \( '(' . $_[0]->view_definition .')' ) + : $_[0]->name + ; } =head1 OTHER METHODS From 59806d8681635c59ad3fa30c366d811291c84e87 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 15 May 2016 16:38:59 +0200 Subject: [PATCH 093/262] Clean up the mess around $rsrc->sqlt_deploy_callback Back in f89bb832 nothingmuch introduced a hook point used to better integrate with KiokuDB::Backend::DBI. It was properly implemented as a $rsrc instance attribute, though somewhat undocmented. Then in 880c075b castaway came along and incorrectly documented the attribute as settable from a class, without it ever becoming a member of the list in DBIC::ResultSourceProxy. Then in 3b4e619d1 yours truly came along and (either misled by the docs, or by drugs, or both) switched the accessor to classdata (CAG inherited) even though rsrc-class-level operations were never a thing. Revert part of 3b4e619d1 and fix the documentation to properly reflect the state of affairs --- lib/DBIx/Class/ResultSource.pm | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index aacf1258f..14e07d318 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -20,7 +20,7 @@ __PACKAGE__->mk_group_accessors(simple => qw/ source_name name source_info _ordered_columns _columns _primaries _unique_constraints _relationships resultset_attributes - column_info_from_storage + column_info_from_storage sqlt_deploy_callback /); __PACKAGE__->mk_group_accessors(component_class => qw/ @@ -28,8 +28,6 @@ __PACKAGE__->mk_group_accessors(component_class => qw/ result_class /); -__PACKAGE__->mk_classaccessor( sqlt_deploy_callback => 'default_sqlt_deploy_hook' ); - =head1 NAME DBIx::Class::ResultSource - Result source object @@ -129,6 +127,7 @@ sub new { $new->{_relationships} = { %{$new->{_relationships}||{}} }; $new->{name} ||= "!!NAME NOT SET!!"; $new->{_columns_info_loaded} ||= 0; + $new->{sqlt_deploy_callback} ||= 'default_sqlt_deploy_hook'; return $new; } @@ -942,11 +941,11 @@ sub unique_constraint_columns { =back - __PACKAGE__->sqlt_deploy_callback('mycallbackmethod'); + __PACKAGE__->result_source_instance->sqlt_deploy_callback('mycallbackmethod'); or - __PACKAGE__->sqlt_deploy_callback(sub { + __PACKAGE__->result_source_instance->sqlt_deploy_callback(sub { my ($source_instance, $sqlt_table) = @_; ... } ); From 7f068248010455f821c215bf029517cb99aac3e5 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 15 May 2016 15:54:30 +0200 Subject: [PATCH 094/262] Streamline ::ResultSource::* inheritance, similar to d009cb7d There should be zero functional changes --- lib/DBIx/Class/ResultSource.pm | 9 +++++---- lib/DBIx/Class/ResultSource/RowParser.pm | 1 + lib/DBIx/Class/ResultSource/Table.pm | 6 ++---- lib/DBIx/Class/ResultSource/View.pm | 5 ++--- xt/extra/c3_mro.t | 4 ++++ 5 files changed, 14 insertions(+), 11 deletions(-) diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 14e07d318..6fa12c3cd 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -3,10 +3,8 @@ package DBIx::Class::ResultSource; use strict; use warnings; -use base 'DBIx::Class'; -__PACKAGE__->load_components(qw( - ResultSource::RowParser -)); +use base 'DBIx::Class::ResultSource::RowParser'; +use mro 'c3'; use DBIx::Class::Carp; use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try fail_on_internal_call ); @@ -14,6 +12,9 @@ use SQL::Abstract 'is_literal_value'; use Devel::GlobalDestruction; use Scalar::Util qw/blessed weaken isweak/; +# FIXME - somehow breaks ResultSetManager, do not remove until investigated +use DBIx::Class::ResultSet; + use namespace::clean; __PACKAGE__->mk_group_accessors(simple => qw/ diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index 9d41e01ef..efd67b16c 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -5,6 +5,7 @@ use strict; use warnings; use base 'DBIx::Class'; +use mro 'c3'; use Try::Tiny; use List::Util 'max'; diff --git a/lib/DBIx/Class/ResultSource/Table.pm b/lib/DBIx/Class/ResultSource/Table.pm index f1900f9df..e1dcc03ca 100644 --- a/lib/DBIx/Class/ResultSource/Table.pm +++ b/lib/DBIx/Class/ResultSource/Table.pm @@ -3,10 +3,8 @@ package DBIx::Class::ResultSource::Table; use strict; use warnings; -use DBIx::Class::ResultSet; - -use base qw/DBIx::Class/; -__PACKAGE__->load_components(qw/ResultSource/); +use base 'DBIx::Class::ResultSource'; +use mro 'c3'; =head1 NAME diff --git a/lib/DBIx/Class/ResultSource/View.pm b/lib/DBIx/Class/ResultSource/View.pm index 846bcf661..59957902c 100644 --- a/lib/DBIx/Class/ResultSource/View.pm +++ b/lib/DBIx/Class/ResultSource/View.pm @@ -3,10 +3,9 @@ package DBIx::Class::ResultSource::View; use strict; use warnings; -use DBIx::Class::ResultSet; +use base 'DBIx::Class::ResultSource'; +use mro 'c3'; -use base qw/DBIx::Class/; -__PACKAGE__->load_components(qw/ResultSource/); __PACKAGE__->mk_group_accessors( 'simple' => qw(is_virtual view_definition deploy_depends_on) ); diff --git a/xt/extra/c3_mro.t b/xt/extra/c3_mro.t index 27a034145..db6040281 100644 --- a/xt/extra/c3_mro.t +++ b/xt/extra/c3_mro.t @@ -59,6 +59,10 @@ check_ancestry($_) for ( ref( $art->result_source ), ref( $art->result_source->resultset ), ref( $art->result_source->schema ), + ( map + { ref $art->result_source->schema->source($_) } + $art->result_source->schema->sources + ), qw( AAA BBB CCC ), ((! DBIx::Class::Optional::Dependencies->req_ok_for('cdbicompat') ) ? () : do { unshift @INC, 't/cdbi/testlib'; From dd1853390485b141d014a59aa550fba966493784 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 15 May 2016 17:01:32 +0200 Subject: [PATCH 095/262] Ensure the component_class override require()s its value in a pipeline --- lib/DBIx/Class/AccessorGroup.pm | 6 +++++- t/05components.t | 10 ++++++++-- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index 01a5559d1..5ac4651c2 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -46,7 +46,11 @@ sub get_component_class { }; sub set_component_class { - shift->set_inherited(@_); + $_[0]->set_inherited($_[1], $_[2]); + + # trigger a load for the case of $foo->component_accessor("bar")->new + $_[0]->get_component_class($_[1]) + if defined wantarray; } 1; diff --git a/t/05components.t b/t/05components.t index b6f2c3e3a..335fb068f 100644 --- a/t/05components.t +++ b/t/05components.t @@ -6,10 +6,16 @@ use Test::More; use DBICTest; -use DBICTest::ForeignComponent; + +{ + package DBICTest::SomeResult; + use base 'DBIx::Class::Core'; + __PACKAGE__->table("boguz"); +} # Tests if foreign component was loaded by calling foreign's method -ok( DBICTest::ForeignComponent->foreign_test_method, 'foreign component' ); +ok( ! $INC{"DBICTest/ForeignComponent.pm"}, "DBICTest::ForeignComponent not yet loaded" ); +ok( DBICTest::SomeResult->result_class("DBICTest::ForeignComponent")->foreign_test_method, 'foreign component loaded correctly' ); # Test for inject_base to filter out duplicates { package DBICTest::_InjectBaseTest; From ab1043a6bf062356fd698fc984a22abf674885ef Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 15 May 2016 22:52:18 +0200 Subject: [PATCH 096/262] Rollback some mistaken indirect-call-elisions from e5053694 The ::Realtionship::Base calls perform result-instance adjustments, thus they CAN NOT be omitted That would have been *really* embarrassing, good thing dependent smoking caught this crap. Not adding an extra test at this point, but probably should :/ Audit was performed by scrutinizing each line of: grep -- '->' \ <(git diff -U0 e50536940^..e50536940) \ <(git diff -U0 77c3a5dca^..77c3a5dca) \ > argh.log --- lib/DBIx/Class/Relationship/Accessor.pm | 4 ++-- lib/DBIx/Class/Relationship/Base.pm | 2 +- lib/DBIx/Class/Relationship/ProxyMethods.pm | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index fae251ee6..0dab6409d 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -100,8 +100,8 @@ EOC } elsif ($acc_type eq 'multi') { - quote_sub "${class}::${rel}_rs", "shift->related_resultset('$rel')->search_rs( \@_ )"; - quote_sub "${class}::add_to_${rel}", "shift->related_resultset('$rel')->new_result( \@_ )->insert"; + quote_sub "${class}::${rel}_rs", "shift->related_resultset( q{$rel} )->search_rs( \@_ )"; + quote_sub "${class}::add_to_${rel}", "shift->create_related( q{$rel} => \@_ )"; quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel ); DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; shift->related_resultset(%s)->search( @_ ) diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index 323c31ea8..994e7d70c 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -767,7 +767,7 @@ sub find_or_create_related { my $self = shift; my $rel = shift; my $obj = $self->related_resultset($rel)->find(@_); - return (defined($obj) ? $obj : $self->related_resultset($rel)->new_result(@_)->insert); + return (defined($obj) ? $obj : $self->create_related( $rel => @_ )); } =head2 update_or_create_related diff --git a/lib/DBIx/Class/Relationship/ProxyMethods.pm b/lib/DBIx/Class/Relationship/ProxyMethods.pm index f7585a7db..cb615140f 100644 --- a/lib/DBIx/Class/Relationship/ProxyMethods.pm +++ b/lib/DBIx/Class/Relationship/ProxyMethods.pm @@ -28,7 +28,7 @@ sub proxy_to_related { my $self = shift; my $relobj = $self->%1$s; if (@_ && !defined $relobj) { - $relobj = $self->related_resultset(q{%1$s})->new_result({ %2$s => $_[0] })->insert; + $relobj = $self->create_related( q{%1$s} => { %2$s => $_[0] } ); @_ = (); } $relobj ? $relobj->%2$s(@_) : undef; From d99f2db7432d90469c7b860a865e0c32f1611cec Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 17 May 2016 17:43:30 +0200 Subject: [PATCH 097/262] Add a few more indirect call guards missed in e5053694 No notable code changes were required as a result --- lib/DBIx/Class/Relationship/Accessor.pm | 13 +++++++++++-- lib/DBIx/Class/Relationship/ManyToMany.pm | 16 ++++++++++++---- lib/DBIx/Class/ResultSource.pm | 6 ++++-- lib/DBIx/Class/Schema.pm | 1 + 4 files changed, 28 insertions(+), 8 deletions(-) diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index 0dab6409d..025ab2466 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -100,9 +100,18 @@ EOC } elsif ($acc_type eq 'multi') { - quote_sub "${class}::${rel}_rs", "shift->related_resultset( q{$rel} )->search_rs( \@_ )"; - quote_sub "${class}::add_to_${rel}", "shift->create_related( q{$rel} => \@_ )"; + quote_sub "${class}::${rel}_rs", sprintf( <<'EOC', perlstring $rel ); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; + shift->related_resultset(%s)->search_rs( @_ ) +EOC + + quote_sub "${class}::add_to_${rel}", sprintf( <<'EOC', perlstring $rel ); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; + shift->create_related( %s => @_ ); +EOC + quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel ); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; shift->related_resultset(%s)->search( @_ ) EOC diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm index 1cf6b0278..fdfb5ddaa 100644 --- a/lib/DBIx/Class/Relationship/ManyToMany.pm +++ b/lib/DBIx/Class/Relationship/ManyToMany.pm @@ -5,7 +5,7 @@ use strict; use warnings; use DBIx::Class::Carp; -use DBIx::Class::_Util qw(fail_on_internal_wantarray quote_sub); +use DBIx::Class::_Util qw( quote_sub perlstring ); # FIXME - this souldn't be needed my $cu; @@ -61,12 +61,19 @@ EOW '$carp_unique' => \$cu, }; - quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', $rel, $f_rel ), $qsub_attrs; + quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', map { perlstring $_ } ( "${class}::${meth}", $rel, $f_rel ) ), $qsub_attrs; + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + # allow nested calls from our ->many_to_many, see comment below + ( (CORE::caller(1))[3] ne %s ) + and + DBIx::Class::_Util::fail_on_internal_call; # this little horror is there replicating a deprecation from # within search_rs() itself - shift->related_resultset( q{%1$s} ) - ->related_resultset( q{%2$s} ) + shift->related_resultset( %s ) + ->related_resultset( %s ) ->search_rs ( undef, ( @_ > 1 and ref $_[-1] eq 'HASH' ) @@ -79,6 +86,7 @@ EOC quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; my $rs = shift->%s( @_ ); diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 6fa12c3cd..eb56b01f9 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -353,7 +353,10 @@ sub add_columns { return $self; } -sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB +sub add_column { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->add_columns(@_) +} =head2 has_column @@ -578,7 +581,6 @@ sub remove_columns { $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]); } -# DO NOT CHANGE THIS TO A GLOB sub remove_column { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->remove_columns(@_) diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index c0cba10c2..fff27ddd2 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -908,6 +908,7 @@ sub compose_namespace { } } + # Legacy stuff, not inserting INDIRECT assertions quote_sub "${target}::${_}" => "shift->schema->$_(\@_)" for qw(class source resultset); } From c8b1011e62b44d8a35b5de0ec8e7ace99879c7af Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 15 May 2016 22:52:18 +0200 Subject: [PATCH 098/262] Start known issues changelog section - place it on top for clarity Aside from the 3 pieces listed in Changes, everything else tested on the list below passes on 5.16.2 as of the date of this commit Note: slight nudging (cpanm -n) was necessary to get some intra-deps reset; set -o pipefail; for d in \ RapidApp \ App::DBCritic \ App::DH \ Catalyst::Controller::DBIC::API \ Catalyst::Model::DBIC::Schema \ Catalyst::Model::DBIC::Schema::PerRequest \ Catalyst::Plugin::Authorization::RoleAbilities \ Catalyst::TraitFor::Model::DBIC::Schema::Result \ Catalyst::TraitFor::Model::DBIC::Shortcut \ CatalystX::CRUD::ModelAdapter::DBIC \ CatalystX::Eta \ CatalystX::Resource \ CatalystX::SimpleLogin \ Dancer2::Plugin::DBIC \ Dancer2::Session::DBIC \ Dancer::Plugin::DBIC \ Dancer::Session::DBIC \ DBICx::Modeler \ DBICx::Sugar \ DBIx::Class::AlwaysUpdate \ DBIx::Class::AuditAny \ DBIx::Class::AuditLog \ DBIx::Class::BatchUpdate \ DBIx::Class::Candy \ DBIx::Class::DeploymentHandler \ DBIx::Class::DynamicDefault \ DBIx::Class::DynamicSubclass \ DBIx::Class::EasyFixture \ DBIx::Class::Fixtures \ DBIx::Class::Helpers \ DBIx::Class::HTMLWidget \ DBIx::Class::InflateColumn::Boolean \ DBIx::Class::InflateColumn::DateTimeX::Immutable \ DBIx::Class::InflateColumn::Math::Currency \ DBIx::Class::InflateColumn::Serializer::Role::HashContentAccessor \ DBIx::Class::InflateColumn::Time \ DBIx::Class::InflateColumn::TimeMoment \ DBIx::Class::Journal \ DBIx::Class::Migration \ DBIx::Class::MooseColumns \ DBIx::Class::Objects \ DBIx::Class::ParameterizedJoinHack \ DBIx::Class::PgLog \ DBIx::Class::QueryLog \ DBIx::Class::RandomColumns \ DBIx::Class::Result::ColumnData \ DBIx::Class::ResultSet::AccessorsEverywhere \ DBIx::Class::ResultSet::AuditLog \ DBIx::Class::ResultSet::RecursiveUpdate \ DBIx::Class::ResultSource::MultipleTableInheritance \ DBIx::Class::Result::Validation \ DBIx::Class::Schema::Config \ DBIx::Class::Schema::Diff \ DBIx::Class::Schema::Loader \ DBIx::Class::Schema::Loader::Dynamic \ DBIx::Class::Schema::PopulateMore \ DBIx::Class::Schema::RestrictWithObject \ DBIx::Class::Schema::TxnEndHook \ DBIx::Class::Schema::Versioned::Inline \ DBIx::Class::Sims \ DBIx::Class::TimeStamp \ DBIx::Class::TopoSort \ DBIx::Class::Tree \ DBIx::Class::Tree::Mobius \ DBIx::Class::UnicornLogger \ DBIx::Class::UserStamp \ DBIx::Class::Validation \ DBIx::Class::Validation::Structure \ DBIx::Class::VirtualColumns \ DBIx::Class::Wrapper \ DBIx::Schema::Changelog \ DBIx::Table::TestDataGenerator \ Galileo \ HTML::FormHandler::Model::DBIC \ HTML::FormHandler::TraitFor::Model::DBIC \ Interchange6::Schema \ KiokuDB::Backend::DBI \ MooseX::Meta::Method::Transactional \ MooseX::Role::DBIC \ MooseX::Storage::DBIC \ MooseX::Types::DBIx::Class \ Reaction \ Tapper::Schema \ Test::DBIC::Schema::Connector \ Test::DBIC::Versioned \ Test::DBIx::Class \ WebAPI::DBIC \ Yeb::Plugin::DBIC \ "DBD::SQLite@1.35 Handel Catalyst::ActionRole::BuildDBICResult" \ ; do \ PERL5LIB=/home/rabbit/devel/dbic/lib \ DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USAGE=1 \ cpanm -v --reinstall $d 2>&1 \ | tee -a /dev/shm/umpfh \ | grep -P -B1 '^(Building and testing|Result:)' || break \ ; done --- Changes | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/Changes b/Changes index edafbfe73..6a70384e3 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,8 @@ +Current Known Issues / Regressions + - Breaks DBIx::Class::FrozenColumns (fix pending in RT#114424) + - Breaks DBIx::Class::ResultSet::WithMetaData (fix pending in RT#104602) + - Breaks DBIx::Class::Tree::NestedSet (fix pending in RT#114440) + Revision history for DBIx::Class * Notable Changes and Deprecations From 538c5c4673003dc6bbf9709e01a3935fa1416631 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 19 May 2016 09:19:00 +0200 Subject: [PATCH 099/262] (travis) Poorman updated their offerings As a bonus sidesteps https://github.com/travis-ci/travis-ci/issues/5944 --- .../travis-ci_scripts/10_before_install.bash | 62 ++++++++++++------- maint/travis-ci_scripts/common.bash | 2 +- 2 files changed, 40 insertions(+), 24 deletions(-) diff --git a/maint/travis-ci_scripts/10_before_install.bash b/maint/travis-ci_scripts/10_before_install.bash index 667425922..4fa1338a5 100755 --- a/maint/travis-ci_scripts/10_before_install.bash +++ b/maint/travis-ci_scripts/10_before_install.bash @@ -71,47 +71,63 @@ if [[ "$CLEANTEST" != "true" ]]; then "sudo bash -c 'dd if=/dev/zero of=/swap.img bs=256M count=5 && chmod 600 /swap.img && mkswap /swap.img && swapon /swap.img'" fi - export CACHE_DIR="/tmp/poormanscache" + + # never installed, this looks like trusty + if [[ ! -d /var/lib/mysql ]] ; then + sudo dpkg --add-architecture i386 + extra_debs+=( postgresql mysql-server ) + fi + + + # these APT sources do not mean anything to us anyway + sudo rm -rf /etc/apt/sources.list.d/* # - # FIXME these debconf lines should automate the firebird config but do not :((( + # FIXME these debconf lines should automate the firebird config but seem not to :((( sudo bash -c 'echo -e "firebird2.5-super\tshared/firebird/enabled\tboolean\ttrue" | debconf-set-selections' sudo bash -c 'echo -e "firebird2.5-super\tshared/firebird/sysdba_password/new_password\tpassword\t123" | debconf-set-selections' - # these APT sources do not mean anything to us anyway - sudo rm -rf /etc/apt/sources.list.d/* + run_or_err "Updating APT sources" "sudo apt-get update" + apt_install ${extra_debs[@]} libmysqlclient-dev memcached firebird2.5-super firebird2.5-dev expect - # the actual package is built for lucid, installs fine on both precise and trusty - sudo bash -c 'echo "deb http://archive.canonical.com/ubuntu precise partner" >> /etc/apt/sources.list' - # never installed, this looks like trusty - if [[ ! -d /var/lib/mysql ]] ; then - sudo dpkg --add-architecture i386 - extra_debs="$extra_debs postgresql mysql-server" - fi + # need to stop them again, in case we installed them above (trusty) + for d in mysql postgresql ; do + run_or_err "Stopping $d" "sudo /etc/init.d/$d stop || /bin/true" + done + + + export CACHE_DIR="/tmp/poormanscache" + mkdir "$CACHE_DIR" # FIXME - by default db2 eats too much memory, we won't be able to test on legacy infra # someone needs to add a minimizing configuration akin to 9367d187 if [[ "$(free -m | grep 'Mem:' | perl -p -e '$_ = (split /\s+/, $_)[1]')" -gt 4000 ]] ; then - extra_debs="$extra_debs db2exc" + run_or_err "Getting DB2 from poor man's cache github" ' + wget -qO- https://github.com/poormanscache/poormanscache/archive/DB2_ExC/9.7.5_deb_x86-64.tar.gz \ + | tar -C "$CACHE_DIR" -zx' + + # the actual package is built for lucid, installs fine on both precise and trusty + manual_debs+=( "db2exc_9.7.5-0lucid0_amd64.deb" ) fi - run_or_err "Updating APT sources" "sudo apt-get update" + run_or_err "Getting Oracle from poor man's cache github" ' + wget -qO- https://github.com/poormanscache/poormanscache/archive/OracleXE/10.2.0_deb_mixed.tar.gz \ + | tar -C "$CACHE_DIR" -zx' + manual_debs+=( "bc-multiarch-travis_1.0_all.deb" "oracle-xe_10.2.0.1-1.1_i386.deb" ) + + + # reassemble chunked pieces ( working around github's filesize limit ) + for reass in $CACHE_DIR/*/reassemble ; do /bin/bash "$reass" ; done + + run_or_err "Installing RDBMS debs manually: $( echo ${manual_debs[@]/#/$CACHE_DIR/*/*/} )" \ + "sudo dpkg -i $( echo ${manual_debs[@]/#/$CACHE_DIR/*/*/} ) || sudo bash -c 'source maint/travis-ci_scripts/common.bash && apt_install -f'" - apt_install $extra_debs libmysqlclient-dev memcached firebird2.5-super firebird2.5-dev expect # needs to happen separately and *after* db2exc, as the former shits all over /usr/include (wtf?!) # for more info look at /opt/ibm/db2/V9.7/instance/db2iutil :: create_links() apt_install unixodbc-dev - # need to stop them again, in case we installed them above (trusty) - for d in mysql postgresql ; do - run_or_err "Stopping $d" "sudo /etc/init.d/$d stop || /bin/true" - done - - run_or_err "Cloning poor man's cache from github" "git clone --depth=1 --single-branch --branch=oracle/10.2.0 https://github.com/poormanscache/poormanscache.git $CACHE_DIR && $CACHE_DIR/reassemble" - run_or_err "Installing OracleXE manually from deb" \ - "sudo dpkg -i $CACHE_DIR/apt_cache/bc-multiarch-travis_1.0_all.deb $CACHE_DIR/apt_cache/oracle-xe_10.2.0.1-1.1_i386.deb || sudo bash -c 'source maint/travis-ci_scripts/common.bash && apt_install -f'" ### config memcached run_or_err "Starting memcached" "sudo /etc/init.d/memcached start" @@ -258,7 +274,7 @@ FileUsage = 1 GRANT connect,resource TO $DBICTEST_ORA_EXTRAUSER_USER; '" - export ORACLE_HOME="$CACHE_DIR/ora_instaclient/x86-64/oracle_instaclient_10.2.0.5.0" + export ORACLE_HOME="$CACHE_DIR/poormanscache-OracleXE-10.2.0_deb_mixed/ora_instaclient/x86-64/oracle_instaclient_10.2.0.5.0" ### config db2exc # we may have skipped installation due to low memory diff --git a/maint/travis-ci_scripts/common.bash b/maint/travis-ci_scripts/common.bash index 3f7c976eb..d2b77d820 100755 --- a/maint/travis-ci_scripts/common.bash +++ b/maint/travis-ci_scripts/common.bash @@ -99,7 +99,7 @@ apt_install() { # flatten pkgs="$@" - run_or_err "Installing Debian APT packages: $pkgs" "sudo apt-get install --allow-unauthenticated --no-install-recommends -y $pkgs" + run_or_err "Installing APT packages: $pkgs" "sudo apt-get install --allow-unauthenticated --no-install-recommends -y $pkgs" } extract_prereqs() { From 9d0785d5dc8143fc41584fed2f8f9da7811e31c1 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 19 May 2016 09:23:55 +0200 Subject: [PATCH 100/262] (travis) Clear out some resolved FIXMEs --- maint/travis-ci_scripts/30_before_script.bash | 6 +++--- maint/travis-ci_scripts/50_after_success.bash | 3 --- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index eb65015b7..958f2d853 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -24,7 +24,7 @@ if is_cperl ; then fi -# FIXME - this is a kludge in place of proper MDV testing. For the time +# FIXME - this is a kludge in place of proper MVDT testing. For the time # being simply use the minimum versions of our DBI/DBDstack, to avoid # fuckups like 0.08260 (went unnoticed for 5 months) if [[ "$MVDT" == "true" ]] ; then @@ -70,8 +70,8 @@ if [[ "$BREAK_CC" == "true" ]] ; then run_or_err "Linking ~/bin/cc to /bin/false - thus essentially BREAKING the C compiler" \ "ln -s /bin/false $HOME/bin/cc" - # FIXME: working around RT#113682, RT#113685, and some other unfiled bugs - installdeps Module::Build B::Hooks::EndOfScope Devel::GlobalDestruction Class::Accessor::Grouped + # FIXME: working around RT#113682, and some other unfiled bugs + installdeps Module::Build Devel::GlobalDestruction Class::Accessor::Grouped run_or_err "Linking ~/bin/cc to /bin/true - BREAKING the C compiler even harder" \ "ln -fs /bin/true $HOME/bin/cc" diff --git a/maint/travis-ci_scripts/50_after_success.bash b/maint/travis-ci_scripts/50_after_success.bash index 3d3451f8b..8b44371cb 100755 --- a/maint/travis-ci_scripts/50_after_success.bash +++ b/maint/travis-ci_scripts/50_after_success.bash @@ -27,9 +27,6 @@ if [[ "$DEVREL_DEPS" == "true" ]] && perl -M5.008003 -e1 &>/dev/null ; then parallel_installdeps_notest YAML Lexical::SealRequireHints fi - # FIXME - workaround for RT#113740 - parallel_installdeps_notest List::AllUtils - # FIXME Change when Moose goes away installdeps Moose $(perl -Ilib -MDBIx::Class::Optional::Dependencies=-list_missing,dist_dir) From 07a243ad8f4273317a028eb7a55a8682a713eba3 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 19 May 2016 10:25:36 +0200 Subject: [PATCH 101/262] (travis) Test::Strict needs Devel::Cover which fails on blead To work around https://github.com/pjcj/Devel--Cover/issues/161 provide a fake Devel::Cover satisfying https://github.com/Manwar/Test-Strict/issues/17 --- maint/travis-ci_scripts/30_before_script.bash | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 958f2d853..bc0e9fb93 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -171,6 +171,16 @@ else run_or_err "Configure on current branch with --with-optdeps" "perl Makefile.PL --with-optdeps" + # FIXME - evil evil work around for https://github.com/Manwar/Test-Strict/issues/17 + if perl -M5.025 -e1 &>/dev/null; then + mkdir -p "$( perl -MConfig -e 'print $Config{sitelib}' )/Devel" + cat < "$( perl -MConfig -e 'print $Config{sitelib}' )/Devel/Cover.pm" +package Devel::Cover; +our \$VERSION = 0.43; +1; +MyDevelCover + fi + # if we are smoking devrels - make sure we upgrade everything we know about if [[ "$DEVREL_DEPS" == "true" ]] ; then parallel_installdeps_notest "$(make listalldeps | sort -R)" From d699fb200cf56bab115f1fafc2573624d4bd7cd4 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 19 May 2016 16:49:41 +0200 Subject: [PATCH 102/262] (travis) Bump to Cperl 5.22.2 @miyagawa++ # YAML api - allows for trivial grep/sed slicing and dicing Read under -w --- .travis.yml | 13 ++++----- maint/travis-ci_scripts/20_install.bash | 27 ++++++++++++------- maint/travis-ci_scripts/30_before_script.bash | 23 ++++++++++++---- 3 files changed, 43 insertions(+), 20 deletions(-) diff --git a/.travis.yml b/.travis.yml index 93ec06b9c..fe1c57154 100644 --- a/.travis.yml +++ b/.travis.yml @@ -206,7 +206,8 @@ matrix: # MAKE SURE TO KEEP THE FLAGS IDENTICAL TO CPERL BELOW # allows for easier side-by-side comparison - - perl: "5.22.1_thr_qm" + # vcpu=1 for even more stable results + - perl: "5.22.2_thr_qm" # explicit new infra spec preparing for a future forced upgrade # also need to pull in a sufficiently new compiler for quadmath.h sudo: required @@ -216,7 +217,7 @@ matrix: - CLEANTEST=true - POISON_ENV=true - MVDT=false - - BREWVER=5.22.1 + - BREWVER=5.22.2 - BREWOPTS="-Duseithreads -Dusequadmath" ### @@ -224,18 +225,18 @@ matrix: # MAKE SURE TO KEEP THE FLAGS IDENTICAL TO STOCK 5.22.1 ABOVE # allows for easier side-by-side comparison - - perl: "cperl-5.22.1_thr_qm" + # vcpu=1 for even more stable results + - perl: "cperl-5.22.2_thr_qm" # explicit new infra spec preparing for a future forced upgrade # also need to pull in a sufficiently new compiler for quadmath.h sudo: required dist: trusty env: - # FIXME - work around https://github.com/perl11/cperl/issues/131 - VCPU_USE=1 - CLEANTEST=true - POISON_ENV=true - MVDT=false - - BREWVER=cperl-5.22.1 + - BREWVER=cperl-5.22.2 - BREWOPTS="-Duseithreads -Dusequadmath" # threaded oldest possible with blead CPAN @@ -348,7 +349,7 @@ matrix: allow_failures: # these run with various dev snapshots - allowed to fail - - perl: cperl-5.22.1_thr_qm + - perl: cperl-5.22.2_thr_qm - perl: devcpan_5.8.1_thr_mb - perl: devcpan_5.8.1 - perl: devcpan_5.8.3_mb diff --git a/maint/travis-ci_scripts/20_install.bash b/maint/travis-ci_scripts/20_install.bash index 7628b4a76..d5d348169 100755 --- a/maint/travis-ci_scripts/20_install.bash +++ b/maint/travis-ci_scripts/20_install.bash @@ -4,7 +4,7 @@ if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi # we need a mirror that both has the standard index and a backpan version rolled # into one, due to MDV testing -CPAN_MIRROR="http://cpan.metacpan.org/" +export CPAN_MIRROR="http://cpan.metacpan.org/" PERL_CPANM_OPT="$PERL_CPANM_OPT --mirror $CPAN_MIRROR" @@ -42,6 +42,11 @@ if [[ -n "$BREWVER" ]] ; then run_or_err "Compiling/installing Perl $BREWVER (without testing, using ${perlbrew_jopt:-1} threads, may take up to 5 minutes)" \ "perlbrew install --as $BREWVER --notest --noman --verbose $BREWOPTS -j${perlbrew_jopt:-1} $BREWSRC" + # FIXME work around https://github.com/perl11/cperl/issues/144 + if is_cperl && ! [[ -f ~/perl5/perlbrew/perls/$BREWVER/bin/perl ]] ; then + ln -s ~/perl5/perlbrew/perls/$BREWVER/bin/cperl ~/perl5/perlbrew/perls/$BREWVER/bin/perl + fi + # can not do 'perlbrew use' in the run_or_err subshell above, or a $() # furthermore some versions of `perlbrew use` return 0 regardless of whether # the perl is found (won't be there unless compilation suceeded, wich *ALSO* returns 0) @@ -128,17 +133,21 @@ if [[ "$POISON_ENV" = "true" ]] ; then ### 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" - # move it somewhere as following cpanm will clobber it - run_or_err "Moving latest stable DBIC from CPAN to /tmp" "mv ~/.cpanm/latest-build/DBIx-Class-*/lib /tmp/stable_dbic_lib" + # FIXME - work around https://github.com/perl11/cperl/issues/145 + if ! is_cperl ; then + # 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="/tmp/stable_dbic_lib:$PERL5LIB" + # move it somewhere as following cpanm will clobber it + run_or_err "Moving latest stable DBIC from CPAN to /tmp" "mv ~/.cpanm/latest-build/DBIx-Class-*/lib /tmp/stable_dbic_lib" - # 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)" + export PERL5LIB="/tmp/stable_dbic_lib:$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)" + fi fi diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index bc0e9fb93..2a8b0d791 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -13,6 +13,7 @@ fi # Need a shitton of patches to run on cperl (luckily all provided) # Also need to have YAML in place, otherwise the distroprefs are not readable +# (cperl 5.22.2 comes with YAML already) if is_cperl ; then run_or_err "Downloading and installing cperl distroprefs" ' @@ -20,7 +21,7 @@ if is_cperl ; then tar -C $HOME/.cpan --strip-components 1 -zx distroprefs-master/prefs distroprefs-master/sources ' - installdeps YAML + perl -M5.022002 -e1 &>/dev/null || installdeps YAML fi @@ -84,11 +85,23 @@ if [[ "$CLEANTEST" = "true" ]]; then # we build are guaranteed to be clean, without side # effects from travis preinstalls) - # trick cpanm into executing true as shell - we just need the find+unpack - [[ -d ~/.cpanm/latest-build/DBIx-Class-*/inc ]] || run_or_err "Downloading latest stable DBIC inc/ from CPAN" \ - "SHELL=/bin/true cpanm --look DBIx::Class" + # work around https://github.com/perl11/cperl/issues/145 (no cpanm) + if is_cperl ; then - mv ~/.cpanm/latest-build/DBIx-Class-*/inc . + wget -qO- $( wget -qO- http://cpanmetadb.plackperl.org/v1.0/package/DBIx::Class | grep distfile | sed "s|distfile:\s*|$CPAN_MIRROR/authors/id/|" ) \ + | tar -zx --strip-components 1 --wildcards '*/inc' + + # FIXME - kill this when M::I is gone + # Argh -DFORTIFY_INC!!! + export PERL5LIB="$PERL5LIB:." + + else + # trick cpanm into executing true as shell - we just need the find+unpack + [[ -d ~/.cpanm/latest-build/DBIx-Class-*/inc ]] || run_or_err "Downloading latest stable DBIC inc/ from CPAN" \ + "SHELL=/bin/true cpanm --look DBIx::Class" + + mv ~/.cpanm/latest-build/DBIx-Class-*/inc . + fi # The first CPAN which is somewhat sane is around 1.94_56 (perl 5.12) # The problem is that the first sane version also brings a *lot* of From 59d017a017e04267fddc5c90ac474032614cf5dd Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 19 May 2016 20:49:55 +0200 Subject: [PATCH 103/262] Properly fix corner case of non-comparing overload Back in 096ab902a I stupidly introduced a distinction between blessed and non-blessed structures in store_column. In retrospect this makes absolutely no sense. It took me an embarrasingly long time to get my clue on, including sending a bogus bugrport (with a patch FFS!!!) and wasting SYBER's time: https://rt.cpan.org/Ticket/Display.html?id=114424 At least that shit never shipped :/ --- Changes | 1 - lib/DBIx/Class/Row.pm | 27 +++++++++++++++------------ lib/DBIx/Class/Storage/DBI.pm | 2 +- 3 files changed, 16 insertions(+), 14 deletions(-) diff --git a/Changes b/Changes index 6a70384e3..b002e57d3 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,4 @@ Current Known Issues / Regressions - - Breaks DBIx::Class::FrozenColumns (fix pending in RT#114424) - Breaks DBIx::Class::ResultSet::WithMetaData (fix pending in RT#104602) - Breaks DBIx::Class::Tree::NestedSet (fix pending in RT#114440) diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index f42092a37..40d6fbd2f 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -417,7 +417,14 @@ sub insert { or (defined $current_rowdata{$_} xor defined $returned_cols->{$_}) or - (defined $current_rowdata{$_} and $current_rowdata{$_} ne $returned_cols->{$_}) + ( + defined $current_rowdata{$_} + and + # one of the few spots doing forced-stringification + # needed to work around objects with defined stringification + # but *without* overloaded comparison (ugh!) + "$current_rowdata{$_}" ne "$returned_cols->{$_}" + ) ); } @@ -1225,17 +1232,13 @@ sub store_column { $self->throw_exception( "set_column called for ${column} without value" ) if @_ < 3; - return $self->{_column_data}{$column} = $value - unless length ref $value and my $vref = is_plain_value( $value ); - - # if we are dealing with a value/ref - there are a couple possibilities - # unpack the underlying piece of data and stringify all objects explicitly - # ( to accomodate { -value => ... } and guard against overloaded objects - # with defined stringification AND fallback => 0 (ugh!) - $self->{_column_data}{$column} = defined blessed $$vref - ? "$$vref" - : $$vref - ; + my $vref; + $self->{_column_data}{$column} = ( + # unpack potential { -value => "foo" } + ( length ref $value and $vref = is_plain_value( $value ) ) + ? $$vref + : $value + ); } =head2 inflate_result diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 71c57daf7..302bcca34 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -1812,7 +1812,7 @@ sub _format_for_trace { map { defined( $_ && $_->[1] ) - ? qq{'$_->[1]'} + ? sprintf( "'%s'", "$_->[1]" ) # because overload : q{NULL} } @{$_[1] || []}; } From eef9b4844e1e297bb1480583c21add02d2e8232e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= Date: Tue, 17 May 2016 16:33:27 +0100 Subject: [PATCH 104/262] Harmonize time zone spelling in InflateColumn::DateTime The rest of the DateTime ecosystem consistently uses "time zone" and "time_zone", so use that in InflateColumn::DateTime too "timezone" is still accepted for backwards compatibility --- Changes | 2 ++ lib/DBIx/Class/InflateColumn/DateTime.pm | 40 ++++++++++++++-------- t/icdt/offline_mysql.t | 22 ++++++------ t/lib/DBICTest/Schema/EventTZ.pm | 4 ++- t/lib/DBICTest/Schema/EventTZDeprecated.pm | 4 ++- t/lib/DBICTest/Schema/EventTZPg.pm | 4 +-- 6 files changed, 46 insertions(+), 30 deletions(-) diff --git a/Changes b/Changes index b002e57d3..871b012fe 100644 --- a/Changes +++ b/Changes @@ -34,6 +34,8 @@ Revision history for DBIx::Class - When using non-scalars (e.g. arrays) as literal bind values it is no longer necessary to explicitly specify a bindtype (this turned out to be a mostly useless overprotection) + - InflateColumn::DateTime now accepts the ecosystem-standard option + 'time_zone', in addition to the DBIC-only 'timezone' (GH#28) - DBIx::Class::Optional::Dependencies now properly understands combinations of requirements and does the right thing with e.g. ->req_list_for([qw( rdbms_oracle ic_dt )]) bringing in the Oracle diff --git a/lib/DBIx/Class/InflateColumn/DateTime.pm b/lib/DBIx/Class/InflateColumn/DateTime.pm index bb6223d69..4f08c1f14 100644 --- a/lib/DBIx/Class/InflateColumn/DateTime.pm +++ b/lib/DBIx/Class/InflateColumn/DateTime.pm @@ -31,12 +31,16 @@ Then you can treat the specified column as a L object. print "This event starts the month of ". $event->starts_when->month_name(); -If you want to set a specific timezone and locale for that field, use: +If you want to set a specific time zone and locale for that field, use: __PACKAGE__->add_columns( - starts_when => { data_type => 'datetime', timezone => "America/Chicago", locale => "de_DE" } + starts_when => { data_type => 'datetime', time_zone => "America/Chicago", locale => "de_DE" } ); +Note: DBIC before 0.082900 only accepted C, and silently discarded +any C arguments. For backwards compatibility, C will +continue being accepted as a synonym for C. + If you want to inflate no matter what data_type your column is, use inflate_datetime or inflate_date: @@ -73,7 +77,7 @@ that this feature is new as of 0.07, so it may not be perfect yet - bug reports to the list very much welcome). If the data_type of a field is C, C or C (or -a derivative of these datatypes, e.g. C), this +a derivative of these datatypes, e.g. C), this module will automatically call the appropriate parse/format method for deflation/inflation as defined in the storage class. For instance, for a C field the methods C and C @@ -152,7 +156,7 @@ sub register_column { } if ($info->{extra}) { - for my $slot (qw/timezone locale floating_tz_ok/) { + for my $slot (qw/time_zone timezone locale floating_tz_ok/) { if ( defined $info->{extra}{$slot} ) { carp "Putting $slot into extra => { $slot => '...' } has been deprecated, ". "please put it directly into the '$column' column definition."; @@ -161,6 +165,12 @@ sub register_column { } } + if ( defined $info->{timezone} ) { + $self->throw_exception("Cannot specify both 'timezone' and 'time_zone' in '$column' column defintion.") + if defined $info->{time_zone}; + $info->{time_zone} = delete $info->{timezone}; + } + # shallow copy to avoid unfounded(?) Devel::Cycle complaints my $infcopy = {%$info}; @@ -225,7 +235,7 @@ sub _datetime_parser { sub _post_inflate_datetime { my( $self, $dt, $info ) = @_; - $dt->set_time_zone($info->{timezone}) if defined $info->{timezone}; + $dt->set_time_zone($info->{time_zone}) if defined $info->{time_zone}; $dt->set_locale($info->{locale}) if defined $info->{locale}; return $dt; @@ -234,14 +244,14 @@ sub _post_inflate_datetime { sub _pre_deflate_datetime { my( $self, $dt, $info ) = @_; - if (defined $info->{timezone}) { - carp "You're using a floating timezone, please see the documentation of" + if (defined $info->{time_zone}) { + carp "You're using a floating time zone, please see the documentation of" . " DBIx::Class::InflateColumn::DateTime for an explanation" if ref( $dt->time_zone ) eq 'DateTime::TimeZone::Floating' and not $info->{floating_tz_ok} and not $ENV{DBIC_FLOATING_TZ_OK}; - $dt->set_time_zone($info->{timezone}); + $dt->set_time_zone($info->{time_zone}); } $dt->set_locale($info->{locale}) if defined $info->{locale}; @@ -254,13 +264,13 @@ __END__ =head1 USAGE NOTES -If you have a datetime column with an associated C, and subsequently +If you have a datetime column with an associated C, and subsequently create/update this column with a DateTime object in the L -timezone, you will get a warning (as there is a very good chance this will not have the +time zone, you will get a warning (as there is a very good chance this will not have the result you expect). For example: __PACKAGE__->add_columns( - starts_when => { data_type => 'datetime', timezone => "America/Chicago" } + starts_when => { data_type => 'datetime', time_zone => "America/Chicago" } ); my $event = $schema->resultset('EventTZ')->create({ @@ -273,7 +283,7 @@ The warning can be avoided in several ways: =item Fix your broken code -When calling C on a Floating DateTime object, the timezone is simply +When calling C on a Floating DateTime object, the time zone is simply set to the requested value, and B. It is always a good idea to be supply explicit times to the database: @@ -284,7 +294,7 @@ to be supply explicit times to the database: =item Suppress the check on per-column basis __PACKAGE__->add_columns( - starts_when => { data_type => 'datetime', timezone => "America/Chicago", floating_tz_ok => 1 } + starts_when => { data_type => 'datetime', time_zone => "America/Chicago", floating_tz_ok => 1 } ); =item Suppress the check globally @@ -293,7 +303,7 @@ Set the environment variable DBIC_FLOATING_TZ_OK to some true value. =back -Putting extra attributes like timezone, locale or floating_tz_ok into extra => {} has been +Putting extra attributes like time_zone, locale or floating_tz_ok into extra => {} has been B because this gets you into trouble using L. Instead put it directly into the columns definition like in the examples above. If you still use the old way you'll see a warning - please fix your code then! @@ -305,7 +315,7 @@ use the old way you'll see a warning - please fix your code then! =item More information about the add_columns method, and column metadata, can be found in the documentation for L. -=item Further discussion of problems inherent to the Floating timezone: +=item Further discussion of problems inherent to the Floating time zone: L and L<< $dt->set_time_zone|DateTime/"Set" Methods >> diff --git a/t/icdt/offline_mysql.t b/t/icdt/offline_mysql.t index a865ef5a4..c9d519707 100644 --- a/t/icdt/offline_mysql.t +++ b/t/icdt/offline_mysql.t @@ -20,7 +20,7 @@ use DBIx::Class::_Util 'sigwarn_silencer'; my $schema = DBICTest->init_schema(); -# Test "timezone" parameter +# Test "time_zone" parameter foreach my $tbl (qw/EventTZ EventTZDeprecated/) { my $event_tz = $schema->resultset($tbl)->create({ starts_at => DateTime->new(year=>2007, month=>12, day=>31, time_zone => "America/Chicago" ), @@ -34,25 +34,25 @@ foreach my $tbl (qw/EventTZ EventTZDeprecated/) { is ($event_tz->created_on->month_name, "January", 'Default locale loaded: month_name'); my $starts_at = $event_tz->starts_at; - is("$starts_at", '2007-12-31T00:00:00', 'Correct date/time using timezone'); + is("$starts_at", '2007-12-31T00:00:00', 'Correct date/time using time zone'); my $created_on = $event_tz->created_on; - is("$created_on", '2006-01-31T12:34:56', 'Correct timestamp using timezone'); - is($event_tz->created_on->time_zone->name, "America/Chicago", "Correct timezone"); + is("$created_on", '2006-01-31T12:34:56', 'Correct timestamp using time zone'); + is($event_tz->created_on->time_zone->name, "America/Chicago", "Correct time zone"); my $loaded_event = $schema->resultset($tbl)->find( $event_tz->id ); isa_ok($loaded_event->starts_at, 'DateTime', 'DateTime returned'); $starts_at = $loaded_event->starts_at; - is("$starts_at", '2007-12-31T00:00:00', 'Loaded correct date/time using timezone'); - is($starts_at->time_zone->name, 'America/Chicago', 'Correct timezone'); + is("$starts_at", '2007-12-31T00:00:00', 'Loaded correct date/time using time zone'); + is($starts_at->time_zone->name, 'America/Chicago', 'Correct time zone'); isa_ok($loaded_event->created_on, 'DateTime', 'DateTime returned'); $created_on = $loaded_event->created_on; - is("$created_on", '2006-01-31T12:34:56', 'Loaded correct timestamp using timezone'); - is($created_on->time_zone->name, 'America/Chicago', 'Correct timezone'); + is("$created_on", '2006-01-31T12:34:56', 'Loaded correct timestamp using time zone'); + is($created_on->time_zone->name, 'America/Chicago', 'Correct time zone'); - # Test floating timezone warning + # Test floating time zone warning # We expect one warning SKIP: { skip "ENV{DBIC_FLOATING_TZ_OK} was set, skipping", 1 if $ENV{DBIC_FLOATING_TZ_OK}; @@ -63,8 +63,8 @@ foreach my $tbl (qw/EventTZ EventTZDeprecated/) { created_on => DateTime->new(year=>2006, month=>1, day=>31, hour => 13, minute => 34, second => 56 ), }); }, - qr/You're using a floating timezone, please see the documentation of DBIx::Class::InflateColumn::DateTime for an explanation/, - 'Floating timezone warning' + qr/You're using a floating time zone, please see the documentation of DBIx::Class::InflateColumn::DateTime for an explanation/, + 'Floating time zone warning' ); }; diff --git a/t/lib/DBICTest/Schema/EventTZ.pm b/t/lib/DBICTest/Schema/EventTZ.pm index 4c6c48a2e..d63586845 100644 --- a/t/lib/DBICTest/Schema/EventTZ.pm +++ b/t/lib/DBICTest/Schema/EventTZ.pm @@ -11,7 +11,9 @@ __PACKAGE__->table('event'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, - starts_at => { data_type => 'datetime', timezone => "America/Chicago", locale => 'de_DE', datetime_undef_if_invalid => 1 }, + starts_at => { data_type => 'datetime', time_zone => "America/Chicago", locale => 'de_DE', datetime_undef_if_invalid => 1 }, + + # DO NOT change 'timezone' - there to test the legacy syntax created_on => { data_type => 'timestamp', timezone => "America/Chicago", floating_tz_ok => 1 }, ); diff --git a/t/lib/DBICTest/Schema/EventTZDeprecated.pm b/t/lib/DBICTest/Schema/EventTZDeprecated.pm index c66cd0707..70ac7c7c3 100644 --- a/t/lib/DBICTest/Schema/EventTZDeprecated.pm +++ b/t/lib/DBICTest/Schema/EventTZDeprecated.pm @@ -11,7 +11,9 @@ __PACKAGE__->table('event'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, - starts_at => { data_type => 'datetime', extra => { timezone => "America/Chicago", locale => 'de_DE' } }, + starts_at => { data_type => 'datetime', extra => { time_zone => "America/Chicago", locale => 'de_DE' } }, + + # DO NOT change 'timezone' - there to test the legacy syntax created_on => { data_type => 'timestamp', extra => { timezone => "America/Chicago", floating_tz_ok => 1 } }, ); diff --git a/t/lib/DBICTest/Schema/EventTZPg.pm b/t/lib/DBICTest/Schema/EventTZPg.pm index 1f191afb0..07a2d1f9a 100644 --- a/t/lib/DBICTest/Schema/EventTZPg.pm +++ b/t/lib/DBICTest/Schema/EventTZPg.pm @@ -11,8 +11,8 @@ __PACKAGE__->table('event'); __PACKAGE__->add_columns( id => { data_type => 'integer', is_auto_increment => 1 }, - starts_at => { data_type => 'datetime', timezone => "America/Chicago", locale => 'de_DE' }, - created_on => { data_type => 'timestamp with time zone', timezone => "America/Chicago" }, + starts_at => { data_type => 'datetime', time_zone => "America/Chicago", locale => 'de_DE' }, + created_on => { data_type => 'timestamp with time zone', time_zone => "America/Chicago" }, ts_without_tz => { data_type => 'timestamp without time zone' }, ); From 47e6d13a64b4fb3ab2c89670afe895c240814abf Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 24 May 2016 10:43:18 +0200 Subject: [PATCH 105/262] This piece of doc has been incorrect since c354902c --- lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm | 4 ---- 1 file changed, 4 deletions(-) diff --git a/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm b/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm index 6b430f466..f06875e16 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm @@ -20,10 +20,6 @@ Given a pool (L) of replicated database's (L), defines a method by which query load can be spread out across each replicant in the pool. -This Balancer uses L keyword 'shuffle' to randomly pick an active -replicant from the associated pool. This may or may not be random enough for -you, patches welcome. - =head1 ATTRIBUTES This class defines the following attributes. From fecbfe179d254bbcc8b2df8382a91dcd598dd022 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 24 May 2016 13:55:31 +0200 Subject: [PATCH 106/262] Fix incorrect whitespace test outside of checkouts I stupidly broke it in 1fb834df --- xt/dist/postdistdir/whitespace.t | 33 ++++++++++++++++++-------------- 1 file changed, 19 insertions(+), 14 deletions(-) diff --git a/xt/dist/postdistdir/whitespace.t b/xt/dist/postdistdir/whitespace.t index 17b20602b..a825c1e0c 100644 --- a/xt/dist/postdistdir/whitespace.t +++ b/xt/dist/postdistdir/whitespace.t @@ -27,9 +27,19 @@ Test::EOL::all_perl_files_ok({ trailing_whitespace => 1 }, @pl_targets); Test::NoTabs::all_perl_files_ok(@pl_targets); # check some non-"perl files" in the root separately -my @root_files = grep { -f $_ } bsd_glob('*'); +# start with what we want to check no matter what .gitignore says +my @root_files = grep { -f $_ } qw( + Changes + LICENSE + AUTHORS + README + MANIFEST + META.yml + META.json +); -# use .gitignore as a partial guide of what to skip +# if .gitignore is available - go for * and use .gitignore as a guide +# of what to skip if (open(my $gi, '<', '.gitignore')) { my $skipnames; while (my $ln = <$gi>) { @@ -38,18 +48,13 @@ if (open(my $gi, '<', '.gitignore')) { $skipnames->{$_}++ for bsd_glob($ln); } - # these we want to check no matter what the above says - delete @{$skipnames}{qw( - Changes - LICENSE - AUTHORS - README - MANIFEST - META.yml - META.json - )}; - - @root_files = grep { ! $skipnames->{$_} } @root_files; + delete @{$skipnames}{@root_files}; + + @root_files = grep { + ! $skipnames->{$_} + and + -f $_ + } bsd_glob('*'); } for my $fn (@root_files) { From 17afd4efaada78208fcb697599292a284a825cdb Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 24 May 2016 08:54:18 +0200 Subject: [PATCH 107/262] Simplify the find-test-temp-dir codepath a bit --- t/lib/DBICTest/Util.pm | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 3bcbe8945..990050cb0 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -31,7 +31,7 @@ use Config; use Carp qw(cluck confess croak); use Fcntl qw( :DEFAULT :flock ); use Scalar::Util qw( blessed refaddr openhandle ); -use DBIx::Class::_Util qw( scope_guard parent_dir mkdir_p ); +use DBIx::Class::_Util qw( scope_guard parent_dir ); use base 'Exporter'; our @EXPORT_OK = qw( @@ -249,7 +249,15 @@ EOE # polluting the root dir with random crap or failing outright my $local_dir = find_co_root . 't/var/'; - mkdir_p $local_dir; + # Generlly this should be handled by ANFANG, but double-check ourselves + # Not using mkdir_p here: we *know* everything else up until 'var' exists + # If it doesn't - we better fail outright + # (also saves an extra File::Path require(), small enough as it is) + -d $local_dir + or + mkdir $local_dir + or + die "Unable to create build-local tempdir '$local_dir': $!\n"; warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n\n"; $dir = $local_dir; From 92fbedbc5befe2e660ec168b1b6a2a1255ae6104 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 28 Feb 2016 13:27:25 +0100 Subject: [PATCH 108/262] Better lean startup check Instead of stupidly loading DBICTest right away, delay to examine the actual bare DBIC startup --- xt/extra/lean_startup.t | 120 ++++++++++++++++++++++++++++++++-------- 1 file changed, 98 insertions(+), 22 deletions(-) diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index d107bb889..4d73f4b96 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -1,7 +1,14 @@ # Use a require override instead of @INC munging (less common) # Do the override as early as possible so that CORE::require doesn't get compiled away -my ($initial_inc_contents, $expected_dbic_deps, $require_sites); +BEGIN { + if ( $ENV{RELEASE_TESTING} ) { + require warnings and warnings->import; + require strict and strict->import; + } +} + +my ($initial_inc_contents, $expected_dbic_deps, $require_sites, %stack); BEGIN { unshift @INC, 't/lib'; require DBICTest::Util::OverrideRequire; @@ -9,16 +16,18 @@ BEGIN { DBICTest::Util::OverrideRequire::override_global_require( sub { my $res = $_[0]->(); + return $res if $stack{neutralize_override}; + my $req = $_[1]; $req =~ s/\.pm$//; $req =~ s/\//::/g; my $up = 0; my @caller; - do { @caller = caller($up++) } while ( + do { @caller = CORE::caller($up++) } while ( @caller and ( # exclude our test suite, known "module require-rs" and eval frames - $caller[1] =~ /^ t [\/\\] /x + $caller[1] =~ / (?: \A | [\/\\] ) x?t [\/\\] /x or $caller[0] =~ /^ (?: base | parent | Class::C3::Componentised | Module::Inspector | Module::Runtime ) $/x or @@ -31,6 +40,18 @@ BEGIN { return $res if $req =~ /^DBIx::Class|^DBICTest::/; + # FIXME - work around RT#114641 + # + # Because *OF COURSE* when (questionable) unicode tests fail on < 5.8 + # the answer is to make the entire module 5.8 only, instead of skipping + # the tests in question + # rjbs-- # thinly veiled passive aggressive bullshit + # + # The actual skip is needed because the use happens before 'package' had + # a chance to switch the namespace, so the shim thinks DBIC::Schema tried + # to require this + return $res if $req eq '5.008'; + # exclude everything where the current namespace does not match the called function # (this works around very weird XS-induced require callstack corruption) if ( @@ -42,12 +63,17 @@ BEGIN { and $caller[0] =~ /^DBIx::Class/ and - (caller($up))[3] =~ /\Q$caller[0]/ + (CORE::caller($up))[3] =~ /\Q$caller[0]/ ) { - CORE::require('Test/More.pm'); + local $stack{neutralize_override} = 1; + + do 1 while CORE::caller(++$up); + + require('Test/More.pm'); + local $Test::Builder::Level = $up + 1; Test::More::fail ("Unexpected require of '$req' by $caller[0] ($caller[1] line $caller[2])"); - CORE::require('DBICTest/Util.pm'); + require('DBICTest/Util.pm'); Test::More::diag( 'Require invoked' . DBICTest::Util::stacktrace() ); } @@ -73,6 +99,7 @@ BEGIN { delete @ENV{qw( DBIC_TRACE DBICTEST_SQLT_DEPLOY + DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER DBICTEST_VIA_REPLICATED DBICTEST_DEBUG_CONCURRENCY_LOCKS )}; @@ -120,10 +147,9 @@ BEGIN { Class::Accessor::Grouped Class::C3::Componentised - SQL::Abstract )); - require DBICTest::Schema; + require DBIx::Class::Schema; assert_no_missing_expected_requires(); } @@ -135,9 +161,10 @@ BEGIN { Method::Generate::Accessor Method::Generate::Constructor Context::Preserve + SQL::Abstract )); - my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); + my $s = DBIx::Class::Schema->connect('dbi:SQLite::memory:'); ok (! $s->storage->connected, 'no connection'); assert_no_missing_expected_requires(); } @@ -149,7 +176,52 @@ BEGIN { Hash::Merge )); - my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); + { + eval <<'EOP' or die $@; + + package DBICTest::Result::Artist; + + use warnings; + use strict; + + use base 'DBIx::Class::Core'; + + __PACKAGE__->table("artist"); + + __PACKAGE__->add_columns( + artistid => { + data_type => 'integer', + is_auto_increment => 1, + }, + name => { + data_type => 'varchar', + size => 100, + is_nullable => 1, + }, + rank => { + data_type => 'integer', + default_value => 13, + }, + charfield => { + data_type => 'char', + size => 10, + is_nullable => 1, + }, + ); + + __PACKAGE__->set_primary_key('artistid'); + __PACKAGE__->add_unique_constraint(['name']); + __PACKAGE__->add_unique_constraint(u_nullable => [qw/charfield rank/]); + + 1; + +EOP + } + + my $s = DBIx::Class::Schema->connect('dbi:SQLite::memory:'); + + $s->register_class( Artist => 'DBICTest::Result::Artist' ); + $s->storage->dbh_do(sub { $_[1]->do('CREATE TABLE artist ( "artistid" INTEGER PRIMARY KEY NOT NULL, @@ -165,21 +237,23 @@ BEGIN { assert_no_missing_expected_requires(); } -# and do full populate() as well, just in case - shouldn't add new stuff + +# and do full DBICTest based populate() as well, just in case - shouldn't add new stuff { - local $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}; - { - # in general we do not want DBICTest to load before sqla, but it is - # ok to cheat here - local $INC{'SQL/Abstract.pm'}; - require DBICTest; - } + # DBICTest needs File::Spec, but older versions of Storable load it alread + # Instead of adding a contrived conditional, just preempt the testing entirely + require File::Spec; + + require DBICTest; + DBICTest->import; + my $s = DBICTest->init_schema; - is ($s->resultset('Artist')->find(1)->name, 'Caterwauler McCrae'); - assert_no_missing_expected_requires(); + is ($s->resultset('Artist')->find(1)->name, 'Caterwauler McCrae', 'Expected find() result'); } done_testing; +# one final quiet guard to run at all times +END { assert_no_missing_expected_requires('quiet') }; sub register_lazy_loadable_requires { local $Test::Builder::Level = $Test::Builder::Level + 1; @@ -198,7 +272,8 @@ sub register_lazy_loadable_requires { # check if anything we were expecting didn't actually load sub assert_no_missing_expected_requires { - my $nl; + my $quiet = shift; + for my $mod (keys %$expected_dbic_deps) { (my $modfn = "$mod.pm") =~ s/::/\//g; fail sprintf ( @@ -207,9 +282,10 @@ sub assert_no_missing_expected_requires { __FILE__ ) unless $INC{$modfn}; } + pass(sprintf 'All modules expected at %s line %s loaded by DBIC: %s', __FILE__, (caller(0))[2], join (', ', sort keys %$expected_dbic_deps ), - ) unless $nl; + ) unless $quiet; } From 58b92e31bbd259ddf1d32e342d3978cd43d6e1af Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 24 May 2016 10:40:12 +0200 Subject: [PATCH 109/262] Remove last active reference to List::Util from lib/ This makes zero difference right now that List::Util/Scalar::Util/Sub::Util are one disgusting ball of mud, but hopefully it will make sense soon after @haarg's refactor finally ships --- lib/DBIx/Class/ResultSource/RowParser.pm | 10 ++++++++-- lib/DBIx/Class/Storage/DBI/Cursor.pm | 4 +++- t/prefetch/o2m_o2m_order_by_with_limit.t | 4 ++-- xt/extra/lean_startup.t | 3 ++- 4 files changed, 15 insertions(+), 6 deletions(-) diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index efd67b16c..aff2b8148 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -8,7 +8,6 @@ use base 'DBIx::Class'; use mro 'c3'; use Try::Tiny; -use List::Util 'max'; use DBIx::Class::ResultSource::RowParser::Util qw( assemble_simple_parser @@ -405,7 +404,14 @@ sub _resolve_collapse { # coderef later $collapse_map->{-identifying_columns} = []; $collapse_map->{-identifying_columns_variants} = [ sort { - (scalar @$a) <=> (scalar @$b) or max(@$a) <=> max(@$b) + (scalar @$a) <=> (scalar @$b) + or + ( + # Poor man's max() + ( sort { $b <=> $a } @$a )[0] + <=> + ( sort { $b <=> $a } @$b )[0] + ) } @collapse_sets ]; } } diff --git a/lib/DBIx/Class/Storage/DBI/Cursor.pm b/lib/DBIx/Class/Storage/DBI/Cursor.pm index ecd292b0f..6ea7004c4 100644 --- a/lib/DBIx/Class/Storage/DBI/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/Cursor.pm @@ -182,10 +182,12 @@ sub all { (undef, $sth) = $self->storage->_select( @{$self->{args}} ); - return ( + ( DBIx::Class::_ENV_::SHUFFLE_UNORDERED_RESULTSETS and ! $self->{attrs}{order_by} + and + require List::Util ) ? List::Util::shuffle( @{$sth->fetchall_arrayref} ) : @{$sth->fetchall_arrayref} diff --git a/t/prefetch/o2m_o2m_order_by_with_limit.t b/t/prefetch/o2m_o2m_order_by_with_limit.t index fc447a217..5f0fffb7c 100644 --- a/t/prefetch/o2m_o2m_order_by_with_limit.t +++ b/t/prefetch/o2m_o2m_order_by_with_limit.t @@ -4,7 +4,7 @@ use strict; use warnings; use Test::More; - +use List::Util 'min'; use DBICTest ':DiffSQL'; use DBIx::Class::SQLMaker::LimitDialects; @@ -133,7 +133,7 @@ for ( is_deeply( $rs->all_hri, - [ @{$hri_contents}[$offset .. List::Util::min( $used_limit+$offset-1, $#$hri_contents)] ], + [ @{$hri_contents}[$offset .. min( $used_limit+$offset-1, $#$hri_contents)] ], "Correct slice of the resultset returned with limit '$limit', offset '$offset'", ); } diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index 4d73f4b96..b5f5491ef 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -98,6 +98,7 @@ BEGIN { # these envvars *will* bring in more stuff than the baseline delete @ENV{qw( DBIC_TRACE + DBIC_SHUFFLE_UNORDERED_RESULTSETS DBICTEST_SQLT_DEPLOY DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER DBICTEST_VIA_REPLICATED @@ -142,7 +143,6 @@ BEGIN { Sub::Quote Scalar::Util - List::Util Storable Class::Accessor::Grouped @@ -234,6 +234,7 @@ EOP my $art = $s->resultset('Artist')->create({ name => \[ '?' => 'foo'], rank => 42 }); $art->discard_changes; $art->update({ rank => 69, name => 'foo' }); + $s->resultset('Artist')->all; assert_no_missing_expected_requires(); } From 399b94557c905a4786209415b33c5a622181701f Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 24 May 2016 14:36:41 +0200 Subject: [PATCH 110/262] Add permanent plumbing for _TempExtlib (d0435d75) Since this is the second time we need this, there likely will be more down the road. Split the permanenet and temporary parts into two commits so reverting is less of a PITA. This commit contains the pieces that are perfectly fine to lay dormant until times we need _TempExtlib --- .gitignore | 2 ++ lib/DBIx/Class/StartupCheck.pm | 3 --- lib/DBIx/Class/_Util.pm | 2 ++ maint/careless_ssh.bash | 3 +++ maint/gen_pod_inherit | 1 + t/00describe_environment.t | 2 ++ xt/dist/loadable_standalone_testschema_resultclasses.t | 2 +- xt/dist/pod_coverage.t | 2 ++ xt/dist/postdistdir/pod_footers.t | 1 + xt/dist/strictures.t | 4 ++++ xt/extra/internals/namespaces_cleaned.t | 1 + xt/extra/internals/optional_deps.t | 3 +++ 12 files changed, 22 insertions(+), 4 deletions(-) create mode 100755 maint/careless_ssh.bash diff --git a/.gitignore b/.gitignore index c8cda3ed8..81d2445c2 100644 --- a/.gitignore +++ b/.gitignore @@ -19,3 +19,5 @@ t/var/ *~ maint/.Generated_Pod examples/Schema/db + +lib/DBIx/Class/_TempExtlib diff --git a/lib/DBIx/Class/StartupCheck.pm b/lib/DBIx/Class/StartupCheck.pm index dff403bc3..4986eb50a 100644 --- a/lib/DBIx/Class/StartupCheck.pm +++ b/lib/DBIx/Class/StartupCheck.pm @@ -1,8 +1,5 @@ package DBIx::Class::StartupCheck; -use strict; -use warnings; - 1; __END__ diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 3f60d3f2c..a20705d96 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -1,6 +1,8 @@ package # hide from PAUSE DBIx::Class::_Util; +use DBIx::Class::StartupCheck; # load es early as we can, usually a noop + use warnings; use strict; diff --git a/maint/careless_ssh.bash b/maint/careless_ssh.bash new file mode 100755 index 000000000..1b9e0bcd8 --- /dev/null +++ b/maint/careless_ssh.bash @@ -0,0 +1,3 @@ +#!/bin/bash + +/usr/bin/ssh -o UserKnownHostsFile=/dev/null -o StrictHostKeyChecking=no "$@" diff --git a/maint/gen_pod_inherit b/maint/gen_pod_inherit index e441e88ee..4164da6c6 100755 --- a/maint/gen_pod_inherit +++ b/maint/gen_pod_inherit @@ -47,6 +47,7 @@ Pod::Inherit->new({ lib/DBIx/Class/DB.pm lib/DBIx/Class/CDBICompat/ lib/DBIx/Class/CDBICompat.pm + lib/DBIx/Class/_TempExtlib/ ), # skip the ::Storage:: family for now qw( diff --git a/t/00describe_environment.t b/t/00describe_environment.t index 37e3da946..e24249fd2 100644 --- a/t/00describe_environment.t +++ b/t/00describe_environment.t @@ -167,6 +167,8 @@ find({ wanted => sub { -f $_ or return; + $_ =~ m|lib/DBIx/Class/_TempExtlib| and return; + # can't just `require $fn`, as we need %INC to be # populated properly my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x diff --git a/xt/dist/loadable_standalone_testschema_resultclasses.t b/xt/dist/loadable_standalone_testschema_resultclasses.t index 5416df832..95dd24f4f 100644 --- a/xt/dist/loadable_standalone_testschema_resultclasses.t +++ b/xt/dist/loadable_standalone_testschema_resultclasses.t @@ -15,7 +15,7 @@ use File::Find; my $worker = sub { my $fn = shift; - if (my @offenders = grep { $_ !~ m{DBIx/Class/(?:_Util|Carp)\.pm} } grep { $_ =~ /(^|\/)DBI/ } keys %INC) { + if (my @offenders = grep { $_ !~ m{DBIx/Class/(?:_Util|Carp|StartupCheck)\.pm} } grep { $_ =~ /(^|\/)DBI/ } keys %INC) { die "Wtf - DBI* modules present in %INC: @offenders"; } diff --git a/xt/dist/pod_coverage.t b/xt/dist/pod_coverage.t index 4505af4b1..b98a5550c 100644 --- a/xt/dist/pod_coverage.t +++ b/xt/dist/pod_coverage.t @@ -116,6 +116,8 @@ my $exceptions = { /] }, + 'DBIx::Class::_TempExtlib*' => { skip => 1 }, + 'DBIx::Class::Admin::*' => { skip => 1 }, 'DBIx::Class::ClassResolver::PassThrough' => { skip => 1 }, 'DBIx::Class::Componentised' => { skip => 1 }, diff --git a/xt/dist/postdistdir/pod_footers.t b/xt/dist/postdistdir/pod_footers.t index 4b14dedf4..ee2ac9d02 100644 --- a/xt/dist/postdistdir/pod_footers.t +++ b/xt/dist/postdistdir/pod_footers.t @@ -29,6 +29,7 @@ find({ return unless -f $fn; return unless $fn =~ / \. (?: pm | pod ) $ /ix; + return if $fn =~ qr{\Qlib/DBIx/Class/_TempExtlib/}; my $data = slurp_bytes $fn; diff --git a/xt/dist/strictures.t b/xt/dist/strictures.t index c896c955a..93feda8ef 100644 --- a/xt/dist/strictures.t +++ b/xt/dist/strictures.t @@ -46,6 +46,10 @@ find({ t/lib/ANFANG.pm # no stictures by design (load speed sensitive) | lib/DBIx/Class/Optional/Dependencies.pm # no stictures by design (load speed sensitive) + | + lib/DBIx/Class/StartupCheck.pm # no stictures by design (load speed sensitive) + | + lib/DBIx/Class/_TempExtlib/.+ )$}x; my $f = $_; diff --git a/xt/extra/internals/namespaces_cleaned.t b/xt/extra/internals/namespaces_cleaned.t index 36e12b1dc..8584bd3d8 100644 --- a/xt/extra/internals/namespaces_cleaned.t +++ b/xt/extra/internals/namespaces_cleaned.t @@ -208,6 +208,7 @@ sub find_modules { find( { wanted => sub { -f $_ or return; + $_ =~ m|lib/DBIx/Class/_TempExtlib| and return; s/\.pm$// or return; s/^ (?: lib | blib . (?:lib|arch) ) . //x; push @modules, join ('::', File::Spec->splitdir($_)); diff --git a/xt/extra/internals/optional_deps.t b/xt/extra/internals/optional_deps.t index de45ae065..c1aa96e9b 100644 --- a/xt/extra/internals/optional_deps.t +++ b/xt/extra/internals/optional_deps.t @@ -20,6 +20,9 @@ use List::Util 'shuffle'; use Config; SKIP: { + skip 'Lean load pattern testing makes no sense with TempExtlib', 1 + if grep { $_ =~ /TempExtlib/ } @INC; + skip 'Lean load pattern testing unsafe with $ENV{PERL5OPT}', 1 if $ENV{PERL5OPT}; From b46b85376ad7ff53fa4ec4350a19b4514c4e0d3b Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 24 May 2016 13:16:34 +0200 Subject: [PATCH 111/262] Bring back _TempExtlib (d0435d75), this time for Sub::Quote And this is the part that brings back the to-be-removed portion (unlike the previous 399b9455 which is here to stay) See next commit for why we need this, to be removed once Moo $next ships --- Makefile.PL | 37 +++++++++++++++++++++++++ lib/DBIx/Class/Optional/Dependencies.pm | 4 +++ lib/DBIx/Class/StartupCheck.pm | 33 ++++++++++++++++++++++ xt/extra/lean_startup.t | 1 + 4 files changed, 75 insertions(+) diff --git a/Makefile.PL b/Makefile.PL index 412aa520b..ce145a702 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -21,6 +21,40 @@ BEGIN { $Module::Install::AUTHOR = 0 if (grep { $ENV{"PERL5_${_}_IS_RUNNING"} } (qw/CPANM CPANPLUS CPAN/) ); } +## +## TEMPORARY (and non-portable) +## Get trial Moo +## +BEGIN { + my $target_libdir = 'lib/DBIx/Class/_TempExtlib'; + + if ( ($Module::Install::AUTHOR or $ENV{TRAVIS}) and ! $ENV{MAKELEVEL} ) { + + `rm -rf $target_libdir`; + `mkdir $target_libdir`; + for ( + [ 'Sub::Quote' => master => 'https://github.com/moose/Moo.git' ], + ) { + my $tdir = "/tmp/dbictemplib/$_->[0]/"; + + `rm -rf $tdir`; + + `GIT_SSH=maint/careless_ssh.bash git clone --bare --quiet --branch=$_->[1] --depth=1 $_->[2] $tdir`; + printf "\nIncluding %s git rev %s\n", + $_->[0], + scalar `GIT_DIR=$tdir git rev-parse $_->[1]`, + ; + `git archive --format=tar --remote=file://$tdir $_->[1] lib/ | tar --strip-components=1 -xC $target_libdir`; + + #`rm -rf $tdir`; + } + + unshift @INC, $target_libdir; + + no_index directory => $target_libdir; + } +} + name 'DBIx-Class'; version_from 'lib/DBIx/Class.pm'; perl_version '5.008001'; @@ -60,6 +94,9 @@ my $runtime_requires = { 'SQL::Abstract' => '1.81', 'Try::Tiny' => '0.07', + # Temp to satisfy TemptExtlib + 'Role::Tiny' => '2.000002', + # Technically this is not a core dependency - it is only required # by the MySQL codepath. However this particular version is bundled # since 5.10.0 and is a pure-perl module anyway - let it slide diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm index 4bb44ff7f..4a1535663 100644 --- a/lib/DBIx/Class/Optional/Dependencies.pm +++ b/lib/DBIx/Class/Optional/Dependencies.pm @@ -7,6 +7,10 @@ BEGIN { require warnings and warnings->import; require strict and strict->import; } + + # Temporary to satisfy TempExtlib under tests + require DBIx::Class::StartupCheck + if $0 =~ /\.t$/; } sub croak { diff --git a/lib/DBIx/Class/StartupCheck.pm b/lib/DBIx/Class/StartupCheck.pm index 4986eb50a..986e4520b 100644 --- a/lib/DBIx/Class/StartupCheck.pm +++ b/lib/DBIx/Class/StartupCheck.pm @@ -1,5 +1,38 @@ package DBIx::Class::StartupCheck; +# Temporary - tempextlib +use warnings; +use strict; +use namespace::clean; +BEGIN { + # There can be only one of these, make sure we get the bundled part and + # *not* something off the site lib + for (qw( + Sub::Quote + )) { + (my $incfn = "$_.pm") =~ s|::|/|g; + + if ($INC{$incfn}) { + die "\n\t*TEMPORARY* TRIAL RELEASE REQUIREMENTS VIOLATED\n\n" + . "Unable to continue - a part of the bundled templib contents " + . "was already loaded (likely an older version from CPAN). " + . "Make sure that @{[ __PACKAGE__ ]} is loaded before $_\n" + . "\n\tThis *WILL NOT* be necessary for the official DBIC release\n\n" + ; + } + } + + require File::Spec; + our ($HERE) = File::Spec->rel2abs( + File::Spec->catdir( (File::Spec->splitpath(__FILE__))[1], '_TempExtlib' ) + ) =~ /^(.*)$/; # screw you, taint mode + + die "TempExtlib $HERE does not seem to exist - perhaps you need to run `perl Makefile.PL` in the DBIC checkout?\n" + unless -d $HERE; + + unshift @INC, $HERE; +} + 1; __END__ diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index b5f5491ef..d5a0b0a7b 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -141,6 +141,7 @@ BEGIN { Sub::Name Sub::Defer Sub::Quote + File::Spec Scalar::Util Storable From e85eb407cd475abef6c489dfd36b4866785e00be Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 23 May 2016 19:42:56 +0200 Subject: [PATCH 112/262] Force no_defer on DBIC-internal quote_sub() invocations --- lib/DBIx/Class/_Util.pm | 41 ++++++++++++++++++++++++- xt/extra/internals/namespaces_cleaned.t | 2 -- xt/extra/internals/quote_sub.t | 10 +++--- 3 files changed, 46 insertions(+), 7 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index a20705d96..933aa79ae 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -82,7 +82,7 @@ use B (); use Carp 'croak'; use Storable 'nfreeze'; use Scalar::Util qw(weaken blessed reftype refaddr); -use Sub::Quote qw(qsub quote_sub); +use Sub::Quote qw(qsub); use Sub::Name (); # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone' @@ -102,6 +102,45 @@ our @EXPORT_OK = qw( use constant UNRESOLVABLE_CONDITION => \ '1 = 0'; +BEGIN { + Sub::Quote->VERSION(2.002); +} +# Override forcing no_defer, and adding naming consistency checks +sub quote_sub { + Carp::confess( "Anonymous quoting not supported by the DBIC sub_quote override - supply a sub name" ) if + @_ < 2 + or + ! defined $_[1] + or + length ref $_[1] + ; + + Carp::confess( "The DBIC sub_quote override expects sub name '$_[0]' to be fully qualified" ) + unless $_[0] =~ /::/; + + Carp::confess( "The DBIC sub_quote override expects the sub name '$_[0]' to match the supplied 'package' argument" ) if + $_[3] + and + defined $_[3]->{package} + and + index( $_[0], $_[3]->{package} ) != 0 + ; + + my @caller = caller(0); + my $sq_opts = { + package => $caller[0], + hints => $caller[8], + warning_bits => $caller[9], + hintshash => $caller[10], + %{ $_[3] || {} }, + + # explicitly forced for everything + no_defer => 1, + }; + + my $cref = Sub::Quote::quote_sub( $_[0], $_[1], $_[2]||{}, $sq_opts ); +} + sub sigwarn_silencer ($) { my $pattern = shift; diff --git a/xt/extra/internals/namespaces_cleaned.t b/xt/extra/internals/namespaces_cleaned.t index 8584bd3d8..e5d74acbd 100644 --- a/xt/extra/internals/namespaces_cleaned.t +++ b/xt/extra/internals/namespaces_cleaned.t @@ -109,8 +109,6 @@ my $skip_idx = { map { $_ => 1 } ( my $has_moose = eval { require Moose::Util }; -Sub::Defer::undefer_all(); - my $seen; #inheritance means we will see the same method multiple times for my $mod (@modules) { diff --git a/xt/extra/internals/quote_sub.t b/xt/extra/internals/quote_sub.t index 77b490507..23fb05752 100644 --- a/xt/extra/internals/quote_sub.t +++ b/xt/extra/internals/quote_sub.t @@ -6,9 +6,11 @@ use Test::Warn; use DBIx::Class::_Util 'quote_sub'; +### Test for strictures leakage my $q = do { no strict 'vars'; - quote_sub '$x = $x . "buh"; $x += 42'; + quote_sub 'DBICTest::QSUB::nostrict' + => '$x = $x . "buh"; $x += 42'; }; warnings_exist { @@ -23,10 +25,10 @@ warnings_exist { } ; -my $no_nothing_q = do { +my $no_nothing_q = sub { no strict; no warnings; - quote_sub <<'EOC'; + quote_sub 'DBICTest::QSUB::nowarn', <<'EOC'; BEGIN { warn "-->${^WARNING_BITS}<--\n" }; my $n = "Test::Warn::warnings_exist"; warn "-->@{[ *{$n}{CODE} ]}<--\n"; @@ -35,7 +37,7 @@ EOC my $we_cref = Test::Warn->can('warnings_exist'); -warnings_exist { $no_nothing_q->() } [ +warnings_exist { $no_nothing_q->()->() } [ qr/^\-\-\>\0+\<\-\-$/m, qr/^\Q-->$we_cref<--\E$/m, ], 'Expected warnings, strict did not leak inside the qsub' From 140bcb6a5e00a248c375b741579ed09e36604f64 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 24 May 2016 12:38:16 +0200 Subject: [PATCH 113/262] Add preliminary non-core attribute support This is done in such a "cargocult" way to unblock the rsrc work. Will be gutted out once Moo 2.002 ships --- lib/DBIx/Class.pm | 5 +++++ lib/DBIx/Class/_Util.pm | 25 +++++++++++++++++++++++++ xt/extra/internals/quote_sub.t | 26 ++++++++++++++++++++++++++ xt/extra/lean_startup.t | 1 + 4 files changed, 57 insertions(+) diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index e7c6126cc..c12a34338 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -47,6 +47,11 @@ sub MODIFY_CODE_ATTRIBUTES { return (); } +sub FETCH_CODE_ATTRIBUTES { + my ($class,$code) = @_; + @{ $class->_attr_cache->{$code} || [] } +} + sub _attr_cache { my $self = shift; my $cache = $self->can('__attr_cache') ? $self->__attr_cache : {}; diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 933aa79ae..31f038f37 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -103,7 +103,11 @@ our @EXPORT_OK = qw( use constant UNRESOLVABLE_CONDITION => \ '1 = 0'; BEGIN { + # add preliminary attribute support + # FIXME FIXME FIXME + # To be revisited when Moo with proper attr support ships Sub::Quote->VERSION(2.002); + require attributes; } # Override forcing no_defer, and adding naming consistency checks sub quote_sub { @@ -139,6 +143,27 @@ sub quote_sub { }; my $cref = Sub::Quote::quote_sub( $_[0], $_[1], $_[2]||{}, $sq_opts ); + + # FIXME FIXME FIXME + # To be revisited when Moo with proper attr support ships + if( + # external application does not work on things like :prototype(...), :lvalue, etc + my @attrs = grep { + $_ !~ /^[a-z]/ + or + Carp::confess( "The DBIC sub_quote override does not support applying of reserved attribute '$_'" ) + } @{ $sq_opts->{attributes} || []} + ) { + Carp::confess( "The DBIC sub_quote override does not allow mixing 'attributes' with 'no_install'" ) + if $sq_opts->{no_install}; + + # might be different from $sq_opts->{package}; + my ($install_into) = $_[0] =~ /(.+)::[^:]+$/; + + attributes->import( $install_into, $cref, @attrs ); + } + + $cref; } sub sigwarn_silencer ($) { diff --git a/xt/extra/internals/quote_sub.t b/xt/extra/internals/quote_sub.t index 23fb05752..dcadd2001 100644 --- a/xt/extra/internals/quote_sub.t +++ b/xt/extra/internals/quote_sub.t @@ -47,4 +47,30 @@ warnings_exist { $no_nothing_q->()->() } [ } ; +### Test the upcoming attributes support +require DBIx::Class; +@DBICTest::QSUB::ISA = 'DBIx::Class'; + +my $var = \42; +my $s = quote_sub( + 'DBICTest::QSUB::attr', + '$v', + { '$v' => $var }, + { + # use grandfathered 'ResultSet' attribute for starters + attributes => [qw( ResultSet )], + package => 'DBICTest::QSUB', + }, +); + +is $s, \&DBICTest::QSUB::attr, 'Same cref installed'; + +is DBICTest::QSUB::attr(), 42, 'Sub properly installed and callable'; + +is_deeply + [ attributes::get( $s ) ], + [ 'ResultSet' ], + 'Attribute installed', +unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 + done_testing; diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index d5a0b0a7b..87da4a51e 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -141,6 +141,7 @@ BEGIN { Sub::Name Sub::Defer Sub::Quote + attributes File::Spec Scalar::Util From e8452b02f9db53148f3d0bc6679a107a9c956174 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 26 May 2016 12:17:29 +0200 Subject: [PATCH 114/262] Better lean startup skip in require override ribasushi-- # didn't think through this kind of thing can happen more widely --- xt/extra/lean_startup.t | 15 ++++----------- 1 file changed, 4 insertions(+), 11 deletions(-) diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index 87da4a51e..df4d8986b 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -40,17 +40,10 @@ BEGIN { return $res if $req =~ /^DBIx::Class|^DBICTest::/; - # FIXME - work around RT#114641 - # - # Because *OF COURSE* when (questionable) unicode tests fail on < 5.8 - # the answer is to make the entire module 5.8 only, instead of skipping - # the tests in question - # rjbs-- # thinly veiled passive aggressive bullshit - # - # The actual skip is needed because the use happens before 'package' had - # a chance to switch the namespace, so the shim thinks DBIC::Schema tried - # to require this - return $res if $req eq '5.008'; + # Some modules have a bare 'use $perl_version' as the first statement + # Since the use() happens before 'package' had a chance to switch + # the namespace, the shim thinks DBIC* tried to require this + return $res if $req =~ /^v?[0-9.]$/; # exclude everything where the current namespace does not match the called function # (this works around very weird XS-induced require callstack corruption) From 95b76469a363174145245b3490ebba83d1b639ce Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 25 May 2016 12:54:31 +0200 Subject: [PATCH 115/262] Couple things forgotten during 399b9455/b46b8537 --- lib/DBIx/Class.pm | 5 +++-- lib/DBIx/Class/StartupCheck.pm | 5 ++++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index c12a34338..a4b8654c5 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -1,5 +1,8 @@ package DBIx::Class; +# important to load early +use DBIx::Class::_Util; + use strict; use warnings; @@ -15,11 +18,9 @@ $VERSION = '0.082899_15'; $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases -use DBIx::Class::_Util; use mro 'c3'; use base qw/DBIx::Class::Componentised DBIx::Class::AccessorGroup/; -use DBIx::Class::StartupCheck; use DBIx::Class::Exception; __PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames'); diff --git a/lib/DBIx/Class/StartupCheck.pm b/lib/DBIx/Class/StartupCheck.pm index 986e4520b..7a44a4baf 100644 --- a/lib/DBIx/Class/StartupCheck.pm +++ b/lib/DBIx/Class/StartupCheck.pm @@ -17,7 +17,10 @@ BEGIN { . "Unable to continue - a part of the bundled templib contents " . "was already loaded (likely an older version from CPAN). " . "Make sure that @{[ __PACKAGE__ ]} is loaded before $_\n" - . "\n\tThis *WILL NOT* be necessary for the official DBIC release\n\n" + . "\nUsually it is sufficient to add PERL5OPT=\"-M@{[ __PACKAGE__ ]}\" " + . "to your environment in order to resolve this problem\n" + . "\n\tThis is temporary and *WILL NOT* be necessary for the official " + . "DBIC release\n\n" ; } } From c9f4555e1f3716a055ecec41c39369a66f66b38b Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 26 May 2016 13:51:57 +0200 Subject: [PATCH 116/262] Skip lean_startup.t entirely on cperl for now --- xt/extra/lean_startup.t | 3 +++ 1 file changed, 3 insertions(+) diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index df4d8986b..67a9b2646 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -88,6 +88,9 @@ BEGIN { plan skip_all => 'Dependency load patterns are radically different before perl 5.10' if "$]" < 5.010; + plan skip_all => 'Dependency load patterns may be different on cperl - skip for now' + if $^V =~ /\d+c$/; + # these envvars *will* bring in more stuff than the baseline delete @ENV{qw( DBIC_TRACE From 2ff0298236251060746c44fad5bec5ece455c35c Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 25 May 2016 17:14:23 +0200 Subject: [PATCH 117/262] Fix more taint.t failures under local::lib Add a CI run under l::l (when POISON_ENV is set) to weed this problem out once and for all Also relegate the test to xt/ - it will still run on smokers given 554484cb and has no value failing on an end-user system (CI runs the entire suite under prove -T anyhow) --- Changes | 1 + maint/travis-ci_scripts/20_install.bash | 7 +++++ maint/travis-ci_scripts/30_before_script.bash | 12 ++++++++ t/lib/DBICTest/WithTaint.pm | 5 ++-- xt/dist/strictures.t | 2 ++ t/54taint.t => xt/extra/taint.t | 28 ++++++++++--------- 6 files changed, 39 insertions(+), 16 deletions(-) rename t/54taint.t => xt/extra/taint.t (96%) diff --git a/Changes b/Changes index 871b012fe..fb7673d8e 100644 --- a/Changes +++ b/Changes @@ -81,6 +81,7 @@ Revision history for DBIx::Class * Misc - Add explicit test for pathological example of asymmetric IC::DT setup working with copy() in t/icdt/engine_specific/sybase.t (GH#84) + - Fix t/54taint.t failing on local::lib's with upgraded Carp on 5.8.* - Fix invalid variable names in ResultSource::View examples - Typo fixes from downstream debian packagers (RT#112007) - Skip tests in a way more intelligent and speedy manner when optional diff --git a/maint/travis-ci_scripts/20_install.bash b/maint/travis-ci_scripts/20_install.bash index d5d348169..4fc50d01a 100755 --- a/maint/travis-ci_scripts/20_install.bash +++ b/maint/travis-ci_scripts/20_install.bash @@ -64,6 +64,13 @@ elif [[ "$CLEANTEST" == "true" ]] && [[ "$POISON_ENV" != "true" ]] ; then purge_sitelib fi +if [[ "$POISON_ENV" = "true" ]] ; then + # create a perlbrew-specific local lib + perlbrew lib create travis-local + perlbrew use "$( perlbrew use | grep -oP '(?<=Currently using ).+' )@travis-local" + echo_err "POISON_ENV active - adding a local lib: $(perlbrew use)" +fi + # configure CPAN.pm - older versions go into an endless loop # when trying to autoconf themselves CPAN_CFG_SCRIPT=" diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 2a8b0d791..f590ff0b4 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -35,8 +35,20 @@ if [[ "$MVDT" == "true" ]] ; then # the fulltest may re-upgrade DBI, be conservative only on cleantests # earlier DBI will not compile without PERL_POLLUTE which was gone in 5.14 parallel_installdeps_notest T/TI/TIMB/DBI-1.614.tar.gz + + # FIXME work around DBD::DB2 being silly: https://rt.cpan.org/Ticket/Display.html?id=101659 + if [[ -n "$DBICTEST_DB2_DSN" ]] ; then + echo_err "Installing same DBI version into the main perl (above the current local::lib)" + $SHELL -lic "perlbrew use $( perlbrew use | grep -oP '(?<=Currently using )[^@]+' ) && parallel_installdeps_notest T/TI/TIMB/DBI-1.614.tar.gz" + fi else parallel_installdeps_notest T/TI/TIMB/DBI-1.57.tar.gz + + # FIXME work around DBD::DB2 being silly: https://rt.cpan.org/Ticket/Display.html?id=101659 + if [[ -n "$DBICTEST_DB2_DSN" ]] ; then + echo_err "Installing same DBI version into the main perl (above the current local::lib)" + $SHELL -lic "perlbrew use $( perlbrew use | grep -oP '(?<=Currently using )[^@]+' ) && parallel_installdeps_notest T/TI/TIMB/DBI-1.57.tar.gz" + fi fi # Test both minimum DBD::SQLite and minimum BigInt SQLite diff --git a/t/lib/DBICTest/WithTaint.pm b/t/lib/DBICTest/WithTaint.pm index abad25d79..b3cd66c1a 100644 --- a/t/lib/DBICTest/WithTaint.pm +++ b/t/lib/DBICTest/WithTaint.pm @@ -1,4 +1,3 @@ -# keep stricture tests happy -use strict; -use warnings; +package DBICTest::WithTaint; + 1; diff --git a/xt/dist/strictures.t b/xt/dist/strictures.t index 93feda8ef..8d15f123b 100644 --- a/xt/dist/strictures.t +++ b/xt/dist/strictures.t @@ -41,6 +41,8 @@ find({ return if m{^(?: maint/Makefile.PL.inc/.+ # all the maint inc snippets are auto-strictured | + t/lib/DBICTest/WithTaint.pm # no stictures by design (trips up local::lib on older perls) + | t/lib/DBICTest/Util/OverrideRequire.pm # no stictures by design (load order sensitive) | t/lib/ANFANG.pm # no stictures by design (load speed sensitive) diff --git a/t/54taint.t b/xt/extra/taint.t similarity index 96% rename from t/54taint.t rename to xt/extra/taint.t index fbf028666..e8c6af19a 100644 --- a/t/54taint.t +++ b/xt/extra/taint.t @@ -1,8 +1,22 @@ BEGIN { $ENV{DBICTEST_ANFANG_DEFANG} = 1 } +# When in taint mode, PERL5LIB is ignored (but *not* unset) +# Put it back in INC so that local-lib users can actually +# run this test. Use lib.pm instead of an @INC unshift as +# it will correctly add any arch subdirs encountered +# +# Yes, this is a lazy solution: adding -I args in the exec below is the +# more sensible approach, but no time to properly do it at present +use Config; +use lib ( + grep { length } + map { split /\Q$Config{path_sep}\E/, (/^(.*)$/)[0] } # untainting regex + grep { defined } + @ENV{qw(PERL5LIB PERLLIB)} # precedence preserved by lib +); + use strict; use warnings; -use Config; # there is talk of possible perl compilations where -T is fatal or just # doesn't work. We don't want to have the user deal with that. @@ -45,18 +59,6 @@ BEGIN { unless ($INC{'t/lib/DBICTest/WithTaint.pm'}) { 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 lib.pm instead of an @INC unshift as -# it will correctly add any arch subdirs encountered - -use lib ( - grep { length } - map { split /\Q$Config{path_sep}\E/, (/^(.*)$/)[0] } # untainting regex - grep { defined } - @ENV{qw(PERL5LIB PERLLIB)} # precedence preserved by lib -); - # We need to specify 'lib' here as well because even if it was already in # @INC, the above will have put our local::lib in front of it, so now an # installed DBIx::Class will take precedence over the one we're trying to test. From 04c1a07034f365766217376a0ea194f14fb209a9 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 26 May 2016 17:02:06 +0200 Subject: [PATCH 118/262] Prevent CLONE from potentially running more than once Argh, another thing I didn't know about iThreads: CLONE will run for every package defining *or inheriting* it. Sigh... --- lib/DBIx/Class/Storage/DBI.pm | 2 +- lib/DBIx/Class/Storage/DBI/Cursor.pm | 2 +- lib/DBIx/Class/_Util.pm | 2 +- t/lib/DBICTest/Util/LeakTracer.pm | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 302bcca34..6c2940c88 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -251,7 +251,7 @@ sub new { undef; } - sub CLONE { + sub DBIx::Class::__DBI_Storage_iThreads_handler__::CLONE { # As per DBI's recommendation, DBIC disconnects all handles as # soon as possible (DBIC will reconnect only on demand from within # the thread) diff --git a/lib/DBIx/Class/Storage/DBI/Cursor.pm b/lib/DBIx/Class/Storage/DBI/Cursor.pm index 6ea7004c4..155855979 100644 --- a/lib/DBIx/Class/Storage/DBI/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/Cursor.pm @@ -72,7 +72,7 @@ Returns a new L object. return $self; } - sub CLONE { + sub DBIx::Class::__DBI_Cursor_iThreads_handler__::CLONE { for (keys %cursor_registry) { # once marked we no longer care about them, hence no # need to keep in the registry, left alone renumber the diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 31f038f37..da0d49bc1 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -437,7 +437,7 @@ sub is_exception ($) { { my $destruction_registry = {}; - sub CLONE { + sub DBIx::Class::__Util_iThreads_handler__::CLONE { %$destruction_registry = map { (defined $_) ? ( refaddr($_) => $_ ) diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index 8e2e6e896..4873d77b3 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -73,7 +73,7 @@ sub populate_weakregistry { } # Regenerate the slots names on a thread spawn -sub CLONE { +sub DBICTest::__LeakTracer_iThreads_handler__::CLONE { my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs; %reg_of_regs = (); From 10be570e51ef741ead5f0e8d5ceca78499a8965c Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 25 May 2016 14:19:13 +0200 Subject: [PATCH 119/262] Move even more utils into DBIC::_Util (see next commit) Zero functional changes --- lib/DBIx/Class/_Util.pm | 43 +++++++++++++++++++++++++++++-- t/00describe_environment.t | 2 +- t/lib/DBICTest/Util.pm | 32 +---------------------- t/lib/DBICTest/Util/LeakTracer.pm | 4 +-- 4 files changed, 45 insertions(+), 36 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index da0d49bc1..a713ee7db 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -94,8 +94,8 @@ our @EXPORT_OK = qw( fail_on_internal_wantarray fail_on_internal_call refdesc refcount hrefaddr set_subname scope_guard detected_reinvoked_destructor - is_exception dbic_internal_try - quote_sub qsub perlstring serialize deep_clone dump_value + is_exception dbic_internal_try visit_namespaces + quote_sub qsub perlstring serialize deep_clone dump_value uniq parent_dir mkdir_p UNRESOLVABLE_CONDITION ); @@ -200,6 +200,36 @@ sub refcount ($) { B::svref_2object($_[0])->REFCNT; } +sub visit_namespaces { + my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; + + my $visited_count = 1; + + # A package and a namespace are subtly different things + $args->{package} ||= 'main'; + $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x; + $args->{package} =~ s/^:://; + + if ( $args->{action}->($args->{package}) ) { + my $ns = + ( ($args->{package} eq 'main') ? '' : $args->{package} ) + . + '::' + ; + + $visited_count += visit_namespaces( %$args, package => $_ ) for + grep + # this happens sometimes on %:: traversal + { $_ ne '::main' } + map + { $_ =~ /^(.+?)::$/ ? "$ns$1" : () } + do { no strict 'refs'; keys %$ns } + ; + } + + $visited_count; +} + # FIXME In another life switch this to a polyfill like the one in namespace::clean sub set_subname ($$) { @@ -215,6 +245,15 @@ sub serialize ($) { nfreeze($_[0]); } +sub uniq { + my( %seen, $seen_undef, $numeric_preserving_copy ); + grep { not ( + defined $_ + ? $seen{ $numeric_preserving_copy = $_ }++ + : $seen_undef++ + ) } @_; +} + my $dd_obj; sub dump_value ($) { local $Data::Dumper::Indent = 1 diff --git a/t/00describe_environment.t b/t/00describe_environment.t index e24249fd2..21cf5d6d5 100644 --- a/t/00describe_environment.t +++ b/t/00describe_environment.t @@ -57,7 +57,7 @@ use List::Util 'max'; use ExtUtils::MakeMaker; use DBICTest::RunMode; -use DBICTest::Util 'visit_namespaces'; +use DBIx::Class::_Util 'visit_namespaces'; use DBIx::Class::Optional::Dependencies; my $known_paths = { diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 990050cb0..46b8c2f4a 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -37,7 +37,7 @@ use base 'Exporter'; our @EXPORT_OK = qw( dbg stacktrace class_seems_loaded local_umask slurp_bytes tmpdir find_co_root rm_rf - visit_namespaces PEEPEENESS + PEEPEENESS check_customcond_args await_flock DEBUG_TEST_CONCURRENCY_LOCKS ); @@ -409,36 +409,6 @@ sub check_customcond_args ($) { $args; } -sub visit_namespaces { - my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; - - my $visited_count = 1; - - # A package and a namespace are subtly different things - $args->{package} ||= 'main'; - $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x; - $args->{package} =~ s/^:://; - - if ( $args->{action}->($args->{package}) ) { - my $ns = - ( ($args->{package} eq 'main') ? '' : $args->{package} ) - . - '::' - ; - - $visited_count += visit_namespaces( %$args, package => $_ ) for - grep - # this happens sometimes on %:: traversal - { $_ ne '::main' } - map - { $_ =~ /^(.+?)::$/ ? "$ns$1" : () } - do { no strict 'refs'; keys %$ns } - ; - } - - return $visited_count; -} - # # Replicate the *heuristic* (important!!!) implementation found in various # forms within Class::Load / Module::Inspector / Class::C3::Componentised diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index 4873d77b3..6f1bcb662 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -6,9 +6,9 @@ use strict; use ANFANG; use Carp; use Scalar::Util qw(isweak weaken blessed reftype); -use DBIx::Class::_Util qw(refcount hrefaddr refdesc dump_value); +use DBIx::Class::_Util qw(refcount hrefaddr refdesc dump_value visit_namespaces); use DBICTest::RunMode; -use DBICTest::Util qw( stacktrace visit_namespaces ); +use DBICTest::Util 'stacktrace'; use constant { CV_TRACING => !!( !DBICTest::RunMode->is_plain From 7bd921c01e7ad780f701c30d53300c610a7202b9 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 25 May 2016 10:00:58 +0200 Subject: [PATCH 120/262] Expand/fortify the handling of attributes Now works properly under ithreads, and allows multiple attributes->import() calls to be made on the same cref --- lib/DBIx/Class.pm | 73 +++++++++++++++++++-- xt/extra/internals/attributes.t | 111 ++++++++++++++++++++++++++++++++ xt/extra/internals/quote_sub.t | 26 -------- 3 files changed, 179 insertions(+), 31 deletions(-) create mode 100644 xt/extra/internals/attributes.t diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index a4b8654c5..ef1c60e2d 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -23,6 +23,10 @@ use mro 'c3'; use base qw/DBIx::Class::Componentised DBIx::Class::AccessorGroup/; use DBIx::Class::Exception; +use DBIx::Class::_Util qw( uniq refdesc visit_namespaces ); +use Scalar::Util qw( weaken refaddr ); +use namespace::clean; + __PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames'); __PACKAGE__->_skip_namespace_frames('^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve|^Moose::Meta::'); @@ -40,11 +44,72 @@ BEGIN { sub component_base_class { 'DBIx::Class' } + +my $cref_registry; +sub DBIx::Class::__Attr_iThreads_handler__::CLONE { + + # this is disgusting, but the best we can do without even more surgery + visit_namespaces( action => sub { + my $pkg = shift; + + # skip dangerous namespaces + return 1 if $pkg =~ /^ (?: + DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3 + ) $/x; + + no strict 'refs'; + + if ( + exists ${"${pkg}::"}{__cag___attr_cache} + and + ref( my $attr_stash = ${"${pkg}::__cag___attr_cache"} ) eq 'HASH' + ) { + $attr_stash->{ $cref_registry->{$_} } = delete $attr_stash->{$_} + for keys %$attr_stash; + } + + return 1; + }) +} + sub MODIFY_CODE_ATTRIBUTES { my ($class,$code,@attrs) = @_; $class->mk_classaccessor('__attr_cache' => {}) unless $class->can('__attr_cache'); - $class->__attr_cache->{$code} = [@attrs]; + + # compaction step + defined $cref_registry->{$_} or delete $cref_registry->{$_} + for keys %$cref_registry; + + # The original API used stringification instead of refaddr - can't change that now + if( $cref_registry->{$code} ) { + Carp::confess( sprintf + "Coderefs '%s' and '%s' stringify to the same value '%s': nothing will work", + refdesc($code), + refdesc($cref_registry->{$code}), + "$code" + ) if refaddr($cref_registry->{$code}) != refaddr($code); + } + else { + weaken( $cref_registry->{$code} = $code ) + } + + $class->__attr_cache->{$code} = [ sort( uniq( + @{ $class->__attr_cache->{$code} || [] }, + @attrs, + ))]; + + # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on: + # decidedly not cool + # + # There should be some sort of warning on unrecognized attributes or + # somesuch... OTOH people do use things in the wild hence the plan of action + # is anything but clear :/ + # + # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/lib/DBIx/Class/Service.pm#L93-110 + # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L29 + # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L36 + # return (); } @@ -55,10 +120,8 @@ sub FETCH_CODE_ATTRIBUTES { sub _attr_cache { my $self = shift; - my $cache = $self->can('__attr_cache') ? $self->__attr_cache : {}; - - return { - %$cache, + +{ + %{ $self->can('__attr_cache') ? $self->__attr_cache : {} }, %{ $self->maybe::next::method || {} }, }; } diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t new file mode 100644 index 000000000..5c9b50d4d --- /dev/null +++ b/xt/extra/internals/attributes.t @@ -0,0 +1,111 @@ +use warnings; +use strict; + +use Config; +my $skip_threads; +BEGIN { + if( ! $Config{useithreads} ) { + $skip_threads = 'your perl does not support ithreads'; + } + elsif( "$]" < 5.008005 ) { + $skip_threads = 'DBIC does not actively support threads before perl 5.8.5'; + } + elsif( $INC{'Devel/Cover.pm'} ) { + $skip_threads = 'Devel::Cover does not work with ithreads yet'; + } + + unless( $skip_threads ) { + require threads; + threads->import; + } +} + +use Test::More; +use DBIx::Class::_Util qw( quote_sub modver_gt_or_eq ); + +### Test the upcoming attributes support +require DBIx::Class; +@DBICTest::ATTRTEST::ISA = 'DBIx::Class'; + +my $var = \42; +my $s = quote_sub( + 'DBICTest::ATTRTEST::attr', + '$v', + { '$v' => $var }, + { + attributes => [qw( ResultSet )], + package => 'DBICTest::ATTRTEST', + }, +); + +is $s, \&DBICTest::ATTRTEST::attr, 'Same cref installed'; + +is DBICTest::ATTRTEST::attr(), 42, 'Sub properly installed and callable'; + +is_deeply + [ attributes::get( $s ) ], + [ 'ResultSet' ], + 'Attribute installed', +unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 + +sub add_more_attrs { + # Test that secondary attribute application works + attributes->import( + 'DBICTest::ATTRTEST', + DBICTest::ATTRTEST->can('attr'), + 'method', + 'SomethingNobodyUses', + ); + + # and that double-application also works + attributes->import( + 'DBICTest::ATTRTEST', + DBICTest::ATTRTEST->can('attr'), + 'SomethingNobodyUses', + ); + + is_deeply + [ sort( attributes::get( $s ) )], + [ + qw( ResultSet SomethingNobodyUses method ), + + # before 5.10/5.8.9 internal reserved would get doubled, sigh + # + # FIXME - perhaps need to weed them out somehow at FETCH_CODE_ATTRIBUTES + # time...? In any case - this is not important at this stage + ( modver_gt_or_eq( attributes => '0.08' ) ? () : 'method' ) + ], + 'Secondary attributes installed', + unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 + + is_deeply ( + DBICTest::ATTRTEST->_attr_cache->{$s}, + [ + qw( ResultSet SomethingNobodyUses ), + + # after 5.10/5.8.9 FETCH_CODE_ATTRIBUTES is never called for reserved + # attribute names, so there is nothing for DBIC to see + # + # FIXME - perhaps need to teach ->_attr to reinvoke attributes::get() ? + # In any case - this is not important at this stage + ( modver_gt_or_eq( attributes => '0.08' ) ? () : 'method' ) + ], + 'Attributes visible in DBIC-specific attribute API', + ); +} + + +if ($skip_threads) { + SKIP: { skip "Skipping the thread test: $skip_threads", 1 } + + add_more_attrs(); +} +else { + threads->create(sub { + add_more_attrs(); + select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls + })->join; +} + + +done_testing; diff --git a/xt/extra/internals/quote_sub.t b/xt/extra/internals/quote_sub.t index dcadd2001..23fb05752 100644 --- a/xt/extra/internals/quote_sub.t +++ b/xt/extra/internals/quote_sub.t @@ -47,30 +47,4 @@ warnings_exist { $no_nothing_q->()->() } [ } ; -### Test the upcoming attributes support -require DBIx::Class; -@DBICTest::QSUB::ISA = 'DBIx::Class'; - -my $var = \42; -my $s = quote_sub( - 'DBICTest::QSUB::attr', - '$v', - { '$v' => $var }, - { - # use grandfathered 'ResultSet' attribute for starters - attributes => [qw( ResultSet )], - package => 'DBICTest::QSUB', - }, -); - -is $s, \&DBICTest::QSUB::attr, 'Same cref installed'; - -is DBICTest::QSUB::attr(), 42, 'Sub properly installed and callable'; - -is_deeply - [ attributes::get( $s ) ], - [ 'ResultSet' ], - 'Attribute installed', -unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 - done_testing; From 397056f953866afb74ac2f66c613851dedb16554 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 26 May 2016 21:21:05 +0200 Subject: [PATCH 121/262] Revert c9f4555e - I did not see a mistake I made in the skip-regex ribasushi-- # get your fucking act together... --- xt/extra/lean_startup.t | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index 67a9b2646..7c5df0a3e 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -43,7 +43,7 @@ BEGIN { # Some modules have a bare 'use $perl_version' as the first statement # Since the use() happens before 'package' had a chance to switch # the namespace, the shim thinks DBIC* tried to require this - return $res if $req =~ /^v?[0-9.]$/; + return $res if $req =~ /^v?[0-9.]+$/; # exclude everything where the current namespace does not match the called function # (this works around very weird XS-induced require callstack corruption) @@ -88,9 +88,6 @@ BEGIN { plan skip_all => 'Dependency load patterns are radically different before perl 5.10' if "$]" < 5.010; - plan skip_all => 'Dependency load patterns may be different on cperl - skip for now' - if $^V =~ /\d+c$/; - # these envvars *will* bring in more stuff than the baseline delete @ENV{qw( DBIC_TRACE From 7dc14bc09910cb750e5fe503dfa18a97eed490d1 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 30 May 2016 16:44:05 +0200 Subject: [PATCH 122/262] Correct mistake in t/00describe_environment.t reporting of _TempExtlib This isn't actually correct, but is a reasonable approximation. The entire thing needs to be rewritten, but that's another fight --- t/00describe_environment.t | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/t/00describe_environment.t b/t/00describe_environment.t index 21cf5d6d5..9a973dec0 100644 --- a/t/00describe_environment.t +++ b/t/00describe_environment.t @@ -600,12 +600,21 @@ sub module_found_at_inc_index { my $fn = module_notional_filename($mod); - for my $i ( 0 .. $#$inc_dirs ) { + # trust INC if it specifies an existing path + if( -f ( my $existing_path = abs_unix_path( $INC{$fn} ) ) ) { + for my $i ( 0 .. $#$inc_dirs ) { + + # searching from here on out won't mean anything + # FIXME - there is actually a way to interrogate this safely, but + # that's a fight for another day + return undef if length ref $inc_dirs->[$i]; + + return $i + if 0 == index( $existing_path, abs_unix_path( $inc_dirs->[$i] ) . '/' ); + } + } - # searching from here on out won't mean anything - # FIXME - there is actually a way to interrogate this safely, but - # that's a fight for another day - return undef if length ref $inc_dirs->[$i]; + for my $i ( 0 .. $#$inc_dirs ) { if ( -d $inc_dirs->[$i] From 983f766d16b707dc31af556b7ccfb6d35c391522 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 30 May 2016 11:04:54 +0200 Subject: [PATCH 123/262] Expand the c3 mro test from d009cb7d No functional changes --- lib/DBIx/Class/AccessorGroup.pm | 2 ++ xt/extra/c3_mro.t | 6 +++--- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index 5ac4651c2..7c6dece4b 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -4,6 +4,8 @@ use strict; use warnings; use base qw/Class::Accessor::Grouped/; +use mro 'c3'; + use Scalar::Util qw/weaken blessed/; use DBIx::Class::_Util 'fail_on_internal_call'; use namespace::clean; diff --git a/xt/extra/c3_mro.t b/xt/extra/c3_mro.t index db6040281..fad386a87 100644 --- a/xt/extra/c3_mro.t +++ b/xt/extra/c3_mro.t @@ -16,10 +16,10 @@ my @global_ISA_tail = qw( ); is( - mro::get_mro('DBIx::Class'), + mro::get_mro($_), 'c3', - 'Correct mro on base class DBIx::Class', -); + "Correct mro on base class '$_'", +) for grep { $_ =~ /^DBIx::Class/ } @global_ISA_tail; { package AAA; From 0130575a1a5ad9249a5cdc705c043286fabdf32c Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 29 May 2016 16:00:22 +0200 Subject: [PATCH 124/262] Proper attribute support under ithreads (fix 7bd921c0) The previous implementation was rushed (for decidedly non-technical reasons) and is predictably completely wrong :/ Properly fix renumbering of the registry, and add a double-thread test to catch future problems Read under --color-words --- lib/DBIx/Class.pm | 28 +++++++++++++++++++--------- xt/extra/internals/attributes.t | 12 +++++++++--- 2 files changed, 28 insertions(+), 12 deletions(-) diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index ef1c60e2d..61c09b167 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -45,7 +45,7 @@ BEGIN { sub component_base_class { 'DBIx::Class' } -my $cref_registry; +my $attr_cref_registry; sub DBIx::Class::__Attr_iThreads_handler__::CLONE { # this is disgusting, but the best we can do without even more surgery @@ -64,12 +64,22 @@ sub DBIx::Class::__Attr_iThreads_handler__::CLONE { and ref( my $attr_stash = ${"${pkg}::__cag___attr_cache"} ) eq 'HASH' ) { - $attr_stash->{ $cref_registry->{$_} } = delete $attr_stash->{$_} + $attr_stash->{ $attr_cref_registry->{$_}{weakref} } = delete $attr_stash->{$_} for keys %$attr_stash; } return 1; - }) + }); + + # renumber the cref registry itself + %$attr_cref_registry = map { + ( defined $_->{weakref} ) + ? ( + # because of how __attr_cache works, ugh + "$_->{weakref}" => $_, + ) + : () + } values %$attr_cref_registry; } sub MODIFY_CODE_ATTRIBUTES { @@ -78,20 +88,20 @@ sub MODIFY_CODE_ATTRIBUTES { unless $class->can('__attr_cache'); # compaction step - defined $cref_registry->{$_} or delete $cref_registry->{$_} - for keys %$cref_registry; + defined $attr_cref_registry->{$_}{weakref} or delete $attr_cref_registry->{$_} + for keys %$attr_cref_registry; # The original API used stringification instead of refaddr - can't change that now - if( $cref_registry->{$code} ) { + if( $attr_cref_registry->{$code} ) { Carp::confess( sprintf "Coderefs '%s' and '%s' stringify to the same value '%s': nothing will work", refdesc($code), - refdesc($cref_registry->{$code}), + refdesc($attr_cref_registry->{$code}{weakref}), "$code" - ) if refaddr($cref_registry->{$code}) != refaddr($code); + ) if refaddr($attr_cref_registry->{$code}{weakref}) != refaddr($code); } else { - weaken( $cref_registry->{$code} = $code ) + weaken( $attr_cref_registry->{$code}{weakref} = $code ) } $class->__attr_cache->{$code} = [ sort( uniq( diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t index 5c9b50d4d..e305f97c7 100644 --- a/xt/extra/internals/attributes.t +++ b/xt/extra/internals/attributes.t @@ -23,7 +23,6 @@ BEGIN { use Test::More; use DBIx::Class::_Util qw( quote_sub modver_gt_or_eq ); -### Test the upcoming attributes support require DBIx::Class; @DBICTest::ATTRTEST::ISA = 'DBIx::Class'; @@ -102,10 +101,17 @@ if ($skip_threads) { } else { threads->create(sub { - add_more_attrs(); + + threads->create(sub { + + add_more_attrs(); + select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls + + })->join; + select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls + })->join; } - done_testing; From 5f48fa565dc31b9d22762488afdec8502b8ca515 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 29 May 2016 16:50:02 +0200 Subject: [PATCH 125/262] Attribute handling got too complex - move it into a component No functional changes, just c/p code around For some reason git diff -C -C -M doesn't work here... --- lib/DBIx/Class.pm | 101 +--------------------------- lib/DBIx/Class/AccessorGroup.pm | 2 +- lib/DBIx/Class/MethodAttributes.pm | 104 +++++++++++++++++++++++++++++ xt/dist/pod_coverage.t | 5 +- xt/extra/c3_mro.t | 1 + 5 files changed, 110 insertions(+), 103 deletions(-) create mode 100644 lib/DBIx/Class/MethodAttributes.pm diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index 61c09b167..f76419d47 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -23,12 +23,9 @@ use mro 'c3'; use base qw/DBIx::Class::Componentised DBIx::Class::AccessorGroup/; use DBIx::Class::Exception; -use DBIx::Class::_Util qw( uniq refdesc visit_namespaces ); -use Scalar::Util qw( weaken refaddr ); -use namespace::clean; - -__PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames'); -__PACKAGE__->_skip_namespace_frames('^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve|^Moose::Meta::'); +__PACKAGE__->mk_classaccessor( _skip_namespace_frames => + '^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve|^Moose::Meta::' +); # FIXME - this is not really necessary, and is in # fact going to slow things down a bit @@ -44,98 +41,6 @@ BEGIN { sub component_base_class { 'DBIx::Class' } - -my $attr_cref_registry; -sub DBIx::Class::__Attr_iThreads_handler__::CLONE { - - # this is disgusting, but the best we can do without even more surgery - visit_namespaces( action => sub { - my $pkg = shift; - - # skip dangerous namespaces - return 1 if $pkg =~ /^ (?: - DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3 - ) $/x; - - no strict 'refs'; - - if ( - exists ${"${pkg}::"}{__cag___attr_cache} - and - ref( my $attr_stash = ${"${pkg}::__cag___attr_cache"} ) eq 'HASH' - ) { - $attr_stash->{ $attr_cref_registry->{$_}{weakref} } = delete $attr_stash->{$_} - for keys %$attr_stash; - } - - return 1; - }); - - # renumber the cref registry itself - %$attr_cref_registry = map { - ( defined $_->{weakref} ) - ? ( - # because of how __attr_cache works, ugh - "$_->{weakref}" => $_, - ) - : () - } values %$attr_cref_registry; -} - -sub MODIFY_CODE_ATTRIBUTES { - my ($class,$code,@attrs) = @_; - $class->mk_classaccessor('__attr_cache' => {}) - unless $class->can('__attr_cache'); - - # compaction step - defined $attr_cref_registry->{$_}{weakref} or delete $attr_cref_registry->{$_} - for keys %$attr_cref_registry; - - # The original API used stringification instead of refaddr - can't change that now - if( $attr_cref_registry->{$code} ) { - Carp::confess( sprintf - "Coderefs '%s' and '%s' stringify to the same value '%s': nothing will work", - refdesc($code), - refdesc($attr_cref_registry->{$code}{weakref}), - "$code" - ) if refaddr($attr_cref_registry->{$code}{weakref}) != refaddr($code); - } - else { - weaken( $attr_cref_registry->{$code}{weakref} = $code ) - } - - $class->__attr_cache->{$code} = [ sort( uniq( - @{ $class->__attr_cache->{$code} || [] }, - @attrs, - ))]; - - # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on: - # decidedly not cool - # - # There should be some sort of warning on unrecognized attributes or - # somesuch... OTOH people do use things in the wild hence the plan of action - # is anything but clear :/ - # - # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/lib/DBIx/Class/Service.pm#L93-110 - # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L29 - # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L36 - # - return (); -} - -sub FETCH_CODE_ATTRIBUTES { - my ($class,$code) = @_; - @{ $class->_attr_cache->{$code} || [] } -} - -sub _attr_cache { - my $self = shift; - +{ - %{ $self->can('__attr_cache') ? $self->__attr_cache : {} }, - %{ $self->maybe::next::method || {} }, - }; -} - # *DO NOT* change this URL nor the identically named =head1 below # it is linked throughout the ecosystem sub DBIx::Class::_ENV_::HELP_URL () { diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index 7c6dece4b..0ae4b5bde 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -3,7 +3,7 @@ package DBIx::Class::AccessorGroup; use strict; use warnings; -use base qw/Class::Accessor::Grouped/; +use base qw( DBIx::Class::MethodAttributes Class::Accessor::Grouped ); use mro 'c3'; use Scalar::Util qw/weaken blessed/; diff --git a/lib/DBIx/Class/MethodAttributes.pm b/lib/DBIx/Class/MethodAttributes.pm new file mode 100644 index 000000000..6dac25281 --- /dev/null +++ b/lib/DBIx/Class/MethodAttributes.pm @@ -0,0 +1,104 @@ +package # hide from PAUSE + DBIx::Class::MethodAttributes; + +use strict; +use warnings; + +use DBIx::Class::_Util qw( uniq refdesc visit_namespaces ); +use Scalar::Util qw( weaken refaddr ); + +use mro 'c3'; +use namespace::clean; + +my $attr_cref_registry; +sub DBIx::Class::__Attr_iThreads_handler__::CLONE { + + # This is disgusting, but the best we can do without even more surgery + visit_namespaces( action => sub { + my $pkg = shift; + + # skip dangerous namespaces + return 1 if $pkg =~ /^ (?: + DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3 + ) $/x; + + no strict 'refs'; + + if ( + exists ${"${pkg}::"}{__cag___attr_cache} + and + ref( my $attr_stash = ${"${pkg}::__cag___attr_cache"} ) eq 'HASH' + ) { + $attr_stash->{ $attr_cref_registry->{$_}{weakref} } = delete $attr_stash->{$_} + for keys %$attr_stash; + } + + return 1; + }); + + # renumber the cref registry itself + %$attr_cref_registry = map { + ( defined $_->{weakref} ) + ? ( + # because of how __attr_cache works, ugh + "$_->{weakref}" => $_, + ) + : () + } values %$attr_cref_registry; +} + +sub MODIFY_CODE_ATTRIBUTES { + my ($class,$code,@attrs) = @_; + $class->mk_classaccessor('__attr_cache' => {}) + unless $class->can('__attr_cache'); + + # compaction step + defined $attr_cref_registry->{$_}{weakref} or delete $attr_cref_registry->{$_} + for keys %$attr_cref_registry; + + # The original misc-attr API used stringification instead of refaddr - can't change that now + if( $attr_cref_registry->{$code} ) { + Carp::confess( sprintf + "Coderefs '%s' and '%s' stringify to the same value '%s': nothing will work", + refdesc($code), + refdesc($attr_cref_registry->{$code}{weakref}), + "$code" + ) if refaddr($attr_cref_registry->{$code}{weakref}) != refaddr($code); + } + else { + weaken( $attr_cref_registry->{$code}{weakref} = $code ) + } + + $class->__attr_cache->{$code} = [ sort( uniq( + @{ $class->__attr_cache->{$code} || [] }, + @attrs, + ))]; + + # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on: + # decidedly not cool + # + # There should be some sort of warning on unrecognized attributes or + # somesuch... OTOH people do use things in the wild hence the plan of action + # is anything but clear :/ + # + # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/lib/DBIx/Class/Service.pm#L93-110 + # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L29 + # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L36 + # + return (); +} + +sub FETCH_CODE_ATTRIBUTES { + my ($class,$code) = @_; + @{ $class->_attr_cache->{$code} || [] } +} + +sub _attr_cache { + my $self = shift; + +{ + %{ $self->can('__attr_cache') ? $self->__attr_cache : {} }, + %{ $self->maybe::next::method || {} }, + }; +} + +1; diff --git a/xt/dist/pod_coverage.t b/xt/dist/pod_coverage.t index b98a5550c..4f4682488 100644 --- a/xt/dist/pod_coverage.t +++ b/xt/dist/pod_coverage.t @@ -29,11 +29,7 @@ require Test::Pod::Coverage; my $exceptions = { 'DBIx::Class' => { ignore => [qw/ - MODIFY_CODE_ATTRIBUTES component_base_class - inject_base - mk_classdata - mk_classaccessor /] }, 'DBIx::Class::Optional::Dependencies' => { @@ -120,6 +116,7 @@ my $exceptions = { 'DBIx::Class::Admin::*' => { skip => 1 }, 'DBIx::Class::ClassResolver::PassThrough' => { skip => 1 }, + 'DBIx::Class::MethodAttributes' => { skip => 1 }, 'DBIx::Class::Componentised' => { skip => 1 }, 'DBIx::Class::AccessorGroup' => { skip => 1 }, 'DBIx::Class::Relationship::*' => { skip => 1 }, diff --git a/xt/extra/c3_mro.t b/xt/extra/c3_mro.t index fad386a87..398f51e48 100644 --- a/xt/extra/c3_mro.t +++ b/xt/extra/c3_mro.t @@ -12,6 +12,7 @@ my @global_ISA_tail = qw( DBIx::Class::Componentised Class::C3::Componentised DBIx::Class::AccessorGroup + DBIx::Class::MethodAttributes Class::Accessor::Grouped ); From 5ab7259324b6e3d0feea533239b6d77db0b28c9c Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 25 May 2016 11:44:20 +0200 Subject: [PATCH 126/262] Introduce DBIC-specific method attribute support When attribute support was added back in ed28f830 it was done in a weird roundabout manner, with the only way to access the attributes via a chained class accessor __attr_cache hidden behind a cascading method _attr_cache. This is wasteful and rather inelegant. To mitigate this, and the propensity of DBIC to eat any attribute it can lay its hands on, introduce special handling for attributes prefixed with DBIC_ Any such attributes are handled by a much simpler storage system, and are not made available to the legacy _attr_cache interface. --- lib/DBIx/Class/MethodAttributes.pm | 175 ++++++++++++++++++++++++++--- xt/dist/pod_coverage.t | 1 - xt/extra/internals/attributes.t | 125 +++++++++++++++------ 3 files changed, 251 insertions(+), 50 deletions(-) diff --git a/lib/DBIx/Class/MethodAttributes.pm b/lib/DBIx/Class/MethodAttributes.pm index 6dac25281..cea396116 100644 --- a/lib/DBIx/Class/MethodAttributes.pm +++ b/lib/DBIx/Class/MethodAttributes.pm @@ -1,5 +1,4 @@ -package # hide from PAUSE - DBIx::Class::MethodAttributes; +package DBIx::Class::MethodAttributes; use strict; use warnings; @@ -10,10 +9,11 @@ use Scalar::Util qw( weaken refaddr ); use mro 'c3'; use namespace::clean; -my $attr_cref_registry; +my ( $attr_cref_registry, $attr_cache_active ); sub DBIx::Class::__Attr_iThreads_handler__::CLONE { # This is disgusting, but the best we can do without even more surgery + # Note the if() at the end - we do not run this crap if we can help it visit_namespaces( action => sub { my $pkg = shift; @@ -34,7 +34,7 @@ sub DBIx::Class::__Attr_iThreads_handler__::CLONE { } return 1; - }); + }) if $attr_cache_active; # renumber the cref registry itself %$attr_cref_registry = map { @@ -48,9 +48,16 @@ sub DBIx::Class::__Attr_iThreads_handler__::CLONE { } sub MODIFY_CODE_ATTRIBUTES { - my ($class,$code,@attrs) = @_; - $class->mk_classaccessor('__attr_cache' => {}) - unless $class->can('__attr_cache'); + my $class = shift; + my $code = shift; + + my $attrs; + $attrs->{ + $_ =~ /^[a-z]+$/ ? 'builtin' + : $_ =~ /^DBIC_/ ? 'dbic' + : 'misc' + }{$_}++ for @_; + # compaction step defined $attr_cref_registry->{$_}{weakref} or delete $attr_cref_registry->{$_} @@ -69,10 +76,37 @@ sub MODIFY_CODE_ATTRIBUTES { weaken( $attr_cref_registry->{$code}{weakref} = $code ) } - $class->__attr_cache->{$code} = [ sort( uniq( - @{ $class->__attr_cache->{$code} || [] }, - @attrs, - ))]; + # handle legacy attrs + if( $attrs->{misc} ) { + + # if the user never tickles this - we won't have to do a gross + # symtable scan in the ithread handler above, so: + # + # User - please don't tickle this + $attr_cache_active = 1; + + $class->mk_classaccessor('__attr_cache' => {}) + unless $class->can('__attr_cache'); + + $class->__attr_cache->{$code} = [ sort( uniq( + @{ $class->__attr_cache->{$code} || [] }, + keys %{ $attrs->{misc} }, + ))]; + } + + # handle DBIC_* attrs + if( $attrs->{dbic} ) { + my $slot = $attr_cref_registry->{$code}; + + $slot->{attrs} = [ uniq + @{ $slot->{attrs} || [] }, + grep { + $class->VALID_DBIC_CODE_ATTRIBUTE($_) + or + Carp::confess( "DBIC-specific attribute '$_' did not pass validation by $class->VALID_DBIC_CODE_ATTRIBUTE() as described in DBIx::Class::MethodAttributes" ) + } keys %{$attrs->{dbic}}, + ]; + } # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on: # decidedly not cool @@ -85,12 +119,33 @@ sub MODIFY_CODE_ATTRIBUTES { # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L29 # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L36 # - return (); + # For the time being reuse the old logic for any attribute we do not have + # explicit plans for (i.e. stuff that is neither reserved, nor DBIC-internal) + # + # Pass the "builtin attrs" onwards, as the DBIC internals can't possibly handle them + return sort keys %{ $attrs->{builtin} || {} }; +} + +# Address the above FIXME halfway - if something (e.g. DBIC::Helpers) wants to +# add extra attributes - it needs to override this in its base class to allow +# for 'return 1' on the newly defined attributes +sub VALID_DBIC_CODE_ATTRIBUTE { + #my ($class, $attr) = @_; + + # initially no valid attributes + 0; } sub FETCH_CODE_ATTRIBUTES { - my ($class,$code) = @_; - @{ $class->_attr_cache->{$code} || [] } + #my ($class,$code) = @_; + + sort( + @{ $_[0]->_attr_cache->{$_[1]} || [] }, + ( defined( $attr_cref_registry->{$_[1]}{ weakref } ) + ? @{ $attr_cref_registry->{$_[1]}{attrs} || [] } + : () + ), + ) } sub _attr_cache { @@ -102,3 +157,95 @@ sub _attr_cache { } 1; + +__END__ + +=head1 NAME + +DBIx::Class::MethodAttributes - DBIC-specific handling of CODE attributes + +=head1 SYNOPSIS + + my @attrlist = attributes::get( \&My::App::Schema::Result::some_method ) + +=head1 DESCRIPTION + +This class provides the L inheritance chain with the bits +necessary for L support on methods. + +Historically DBIC has accepted any string as a C attribute and made +such strings available via the semi-private L method. This +was used for e.g. the long-deprecated L, +but also has evidence of use on both C and C. + +Starting mid-2016 DBIC treats any method attribute starting with C +as an I for various DBIC-related methods. +Unlike the general attribute naming policy, strict whitelisting is imposed +on attribute names starting with C as described in +L below. + +=head2 DBIC-specific method attributes + +The following method attributes are currently recognized under the C +prefix: + +=over + +=item * None so far + +=back + +=head1 METHODS + +=head2 MODIFY_CODE_ATTRIBUTES + +See L. + +=head2 FETCH_CODE_ATTRIBUTES + +See L. Always returns the combination of +all attributes: both the free-form strings registered via the +L and the DBIC-specific ones. + +=head2 VALID_DBIC_CODE_ATTRIBUTE + +=over + +=item Arguments: $attribute_string + +=item Return Value: ( true| false ) + +=back + +This method is invoked when processing each DBIC-specific attribute (the ones +starting with C). An attribute is considered invalid and an exception +is thrown unless this method returns a C value. + +=head2 _attr_cache + +=over + +=item Arguments: none + +=item Return Value: B + +=back + +The legacy method of retrieving attributes declared on DBIC methods +(L was not defined until mid-2016). This method +B, and is kept for backwards +compatibility only. + +In order to query the attributes of a particular method use +L as shown in the L. + +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/xt/dist/pod_coverage.t b/xt/dist/pod_coverage.t index 4f4682488..004f35e11 100644 --- a/xt/dist/pod_coverage.t +++ b/xt/dist/pod_coverage.t @@ -116,7 +116,6 @@ my $exceptions = { 'DBIx::Class::Admin::*' => { skip => 1 }, 'DBIx::Class::ClassResolver::PassThrough' => { skip => 1 }, - 'DBIx::Class::MethodAttributes' => { skip => 1 }, 'DBIx::Class::Componentised' => { skip => 1 }, 'DBIx::Class::AccessorGroup' => { skip => 1 }, 'DBIx::Class::Relationship::*' => { skip => 1 }, diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t index e305f97c7..b107a21b7 100644 --- a/xt/extra/internals/attributes.t +++ b/xt/extra/internals/attributes.t @@ -21,75 +21,130 @@ BEGIN { } use Test::More; -use DBIx::Class::_Util qw( quote_sub modver_gt_or_eq ); +use Test::Exception; +use DBIx::Class::_Util qw( quote_sub ); require DBIx::Class; -@DBICTest::ATTRTEST::ISA = 'DBIx::Class'; +@DBICTest::AttrLegacy::ISA = 'DBIx::Class'; +sub DBICTest::AttrLegacy::VALID_DBIC_CODE_ATTRIBUTE { 1 } my $var = \42; my $s = quote_sub( - 'DBICTest::ATTRTEST::attr', + 'DBICTest::AttrLegacy::attr', '$v', { '$v' => $var }, { - attributes => [qw( ResultSet )], - package => 'DBICTest::ATTRTEST', + attributes => [qw( ResultSet DBIC_random_attr )], + package => 'DBICTest::AttrLegacy', }, ); -is $s, \&DBICTest::ATTRTEST::attr, 'Same cref installed'; +is $s, \&DBICTest::AttrLegacy::attr, 'Same cref installed'; -is DBICTest::ATTRTEST::attr(), 42, 'Sub properly installed and callable'; +is DBICTest::AttrLegacy::attr(), 42, 'Sub properly installed and callable'; is_deeply - [ attributes::get( $s ) ], - [ 'ResultSet' ], + [ sort( attributes::get( $s ) ) ], + [qw( DBIC_random_attr ResultSet )], 'Attribute installed', unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 + +@DBICTest::AttrTest::ISA = 'DBIx::Class'; +{ + package DBICTest::AttrTest; + + eval <<'EOS' or die $@; + sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ } + sub attr :lvalue :method :DBIC_attr1 { $$var} + 1; +EOS + + ::throws_ok { + attributes->import( + 'DBICTest::AttrTest', + DBICTest::AttrTest->can('attr'), + 'DBIC_unknownattr', + ); + } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/; +} + +is_deeply + [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ], + [qw( DBIC_attr1 lvalue method )], + 'Attribute installed', +unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 + +ok( + ! DBICTest::AttrTest->can('__attr_cache'), + 'Inherited classdata never created on core attrs' +); + +is_deeply( + DBICTest::AttrTest->_attr_cache, + {}, + 'Cache never instantiated on core attrs' +); + sub add_more_attrs { # Test that secondary attribute application works attributes->import( - 'DBICTest::ATTRTEST', - DBICTest::ATTRTEST->can('attr'), - 'method', + 'DBICTest::AttrLegacy', + DBICTest::AttrLegacy->can('attr'), 'SomethingNobodyUses', ); # and that double-application also works attributes->import( - 'DBICTest::ATTRTEST', - DBICTest::ATTRTEST->can('attr'), + 'DBICTest::AttrLegacy', + DBICTest::AttrLegacy->can('attr'), 'SomethingNobodyUses', ); is_deeply [ sort( attributes::get( $s ) )], - [ - qw( ResultSet SomethingNobodyUses method ), - - # before 5.10/5.8.9 internal reserved would get doubled, sigh - # - # FIXME - perhaps need to weed them out somehow at FETCH_CODE_ATTRIBUTES - # time...? In any case - this is not important at this stage - ( modver_gt_or_eq( attributes => '0.08' ) ? () : 'method' ) - ], + [ qw( DBIC_random_attr ResultSet SomethingNobodyUses ) ], 'Secondary attributes installed', unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 is_deeply ( - DBICTest::ATTRTEST->_attr_cache->{$s}, - [ - qw( ResultSet SomethingNobodyUses ), - - # after 5.10/5.8.9 FETCH_CODE_ATTRIBUTES is never called for reserved - # attribute names, so there is nothing for DBIC to see - # - # FIXME - perhaps need to teach ->_attr to reinvoke attributes::get() ? - # In any case - this is not important at this stage - ( modver_gt_or_eq( attributes => '0.08' ) ? () : 'method' ) - ], - 'Attributes visible in DBIC-specific attribute API', + DBICTest::AttrLegacy->_attr_cache->{$s}, + [ qw( ResultSet SomethingNobodyUses ) ], + 'Attributes visible in legacy DBIC attribute API', + ); + + + + # Test that secondary attribute application works + attributes->import( + 'DBICTest::AttrTest', + DBICTest::AttrTest->can('attr'), + 'DBIC_attr2', + ); + + # and that double-application also works + attributes->import( + 'DBICTest::AttrTest', + DBICTest::AttrTest->can('attr'), + 'DBIC_attr2', + 'DBIC_attr3', + ); + + is_deeply + [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ], + [qw( DBIC_attr1 DBIC_attr2 DBIC_attr3 lvalue method )], + 'DBIC-specific attribute installed', + unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 + + ok( + ! DBICTest::AttrTest->can('__attr_cache'), + 'Inherited classdata never created on core+DBIC-specific attrs' + ); + + is_deeply( + DBICTest::AttrTest->_attr_cache, + {}, + 'Legacy DBIC attribute cache never instantiated on core+DBIC-specific attrs' ); } From 296248c321e75da7fd912ed80b8644aa3cdcccd6 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 1 Jun 2016 10:46:28 +0200 Subject: [PATCH 127/262] Introduce the describe_class_methods() utility function This code will be needed several commits later to tie together the hierarchy validation work. Returns a comprehensive list of methods and related trivia. This required way more code than one would hope, this part of perl is *really* hateful. Read test changes under -w Everything is implemented on "bare metal" (no Package::Stash, very aggressive caching) as this needs to be as efficient as possible. Currently timings on old and new MRO are roughly such on a downclocked X201 / M540: ~/devel/dbic$ perlbrew exec --with 5.8.5,5.16.2,5.24.0_rc1 \ perl -T -Ilib -It/lib -MDBICTest -MTime::HiRes=time -e ' my $t0 = time; sub tstamp { printf "%.6f\n", time - $t0; $t0 = time; } tstamp(); for ( (qw( DBICTest::Schema::Artist DBICTest::Schema::CD DBICTest::Schema::Track main )) x 2 ) { print "describing $_\n"; DBIx::Class::_Util::describe_class_methods($_); tstamp(); } ' 5.8.5 ========== 0.000005 describing DBICTest::Schema::Artist 0.224748 describing DBICTest::Schema::CD 0.066118 describing DBICTest::Schema::Track 0.090433 describing main 0.003152 describing DBICTest::Schema::Artist 0.038846 describing DBICTest::Schema::CD 0.038390 describing DBICTest::Schema::Track 0.043453 describing main 0.002128 5.16.2 ========== 0.000005 describing DBICTest::Schema::Artist 0.077804 describing DBICTest::Schema::CD 0.007684 describing DBICTest::Schema::Track 0.013071 describing main 0.001073 describing DBICTest::Schema::Artist 0.000109 describing DBICTest::Schema::CD 0.000096 describing DBICTest::Schema::Track 0.000098 describing main 0.000041 5.24.0_rc1 ========== 0.000005 describing DBICTest::Schema::Artist 0.044058 describing DBICTest::Schema::CD 0.006093 describing DBICTest::Schema::Track 0.011004 describing main 0.000735 describing DBICTest::Schema::Artist 0.000118 describing DBICTest::Schema::CD 0.000114 describing DBICTest::Schema::Track 0.000113 describing main 0.000059 Additional sanity-checking of this deceptively simple code was performed by sad brute-forcing of the entire test schema set ( at the time of this commit the cumulative sum output was 0x1a65e78e316348104ab9cdc3e474c79096 ) perlbrew exec --with 5.8.5,5.10.0,5.16.2,5.18.0,5.20.0,5.24.0_rc1 \ perl -T -Ilib -It/lib -MDBICTest -e ' use Math::BigInt; use Digest::MD5 "md5_hex"; use List::Util 'shuffle'; use Data::Dumper::Concise; use DBIx::Class::_Util qw( describe_class_methods uniq ); my $sum = Math::BigInt->new(0); for ( shuffle uniq sort map { ( defined Scalar::Util::blessed $_ ) ? ref $_ : $_ } ( qw( DBIx::Class::ResultSource DBIx::Class::Core DBIx::Class::ResultSet DBICTest::Schema ), ( map { $_, $_->result_class, $_->resultset_class, } map { DBICTest::Schema->source($_) } DBICTest::Schema->sources ), ) ) { my $desc = describe_class_methods($_); # unstable between invocations delete $desc->{cumulative_gen}; # only available on 5.10+ delete $desc->{methods}{DOES}; # only available on 5.18+ delete $desc->{methods}{"(("}; $sum += Math::BigInt->new( "0x" . md5_hex(Dumper($desc)) ); } print $sum->as_hex; ' --- lib/DBIx/Class/MethodAttributes.pm | 12 ++ lib/DBIx/Class/_Util.pm | 248 +++++++++++++++++++++- t/52leaks.t | 1 + xt/extra/internals/attributes.t | 324 ++++++++++++++++++++++++++--- 4 files changed, 557 insertions(+), 28 deletions(-) diff --git a/lib/DBIx/Class/MethodAttributes.pm b/lib/DBIx/Class/MethodAttributes.pm index cea396116..1b50ac9f4 100644 --- a/lib/DBIx/Class/MethodAttributes.pm +++ b/lib/DBIx/Class/MethodAttributes.pm @@ -76,6 +76,16 @@ sub MODIFY_CODE_ATTRIBUTES { weaken( $attr_cref_registry->{$code}{weakref} = $code ) } + + # increment the pkg gen, this ensures the sanity checkers will re-evaluate + # this class when/if the time comes + mro::method_changed_in($class) if ( + ! DBIx::Class::_ENV_::OLD_MRO + and + ( $attrs->{dbic} or $attrs->{misc} ) + ); + + # handle legacy attrs if( $attrs->{misc} ) { @@ -94,6 +104,7 @@ sub MODIFY_CODE_ATTRIBUTES { ))]; } + # handle DBIC_* attrs if( $attrs->{dbic} ) { my $slot = $attr_cref_registry->{$code}; @@ -108,6 +119,7 @@ sub MODIFY_CODE_ATTRIBUTES { ]; } + # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on: # decidedly not cool # diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index a713ee7db..11034e24e 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -8,6 +8,8 @@ use strict; use constant SPURIOUS_VERSION_CHECK_WARNINGS => ( "$]" < 5.010 ? 1 : 0); +my $mro_recursor_stack; + BEGIN { package # hide from pause DBIx::Class::_ENV_; @@ -49,10 +51,71 @@ BEGIN { if ( "$]" < 5.009_005) { require MRO::Compat; constant->import( OLD_MRO => 1 ); + + # + # Yes, I know this is a rather PHP-ish name, but please first read + # https://metacpan.org/source/BOBTFISH/MRO-Compat-0.12/lib/MRO/Compat.pm#L363-368 + # + # Even if we are using Class::C3::XS it still won't work, as doing + # defined( *{ "SubClass::"->{$_} }{CODE} ) + # will set pkg_gen to the same value for SubClass and *ALL PARENTS* + # + *DBIx::Class::_Util::get_real_pkg_gen = sub ($) { + require Digest::MD5; + require Math::BigInt; + + # the non-assign-unless-there-is-a-hash is deliberate + ( $mro_recursor_stack->{cache} || {} )->{$_[0]}{gen} ||= ( + Math::BigInt->new( '0x' . ( Digest::MD5::md5_hex( join "\0", map { + + ( $mro_recursor_stack->{cache} || {} )->{$_}{methlist} ||= do { + + my $class = $_; + + no strict 'refs'; + my %methlist = + map + # this is essentially a uniq_by step + # it is crucial on OLD_MRO + {( Scalar::Util::refaddr($_) => $_ )} + map + { + ( + ref(\ "${class}::"->{$_} ) ne 'GLOB' + or + defined( *{ "${class}::"->{$_} }{CODE} ) + ) + ? ( \&{"${class}::$_"} ) + : () + } + keys %{ "${class}::" } + ; + + # RV to be hashed up and turned into a number + join "\0", ( + $class, + map {( + $_, # refaddr is sufficient, ignore names entirely + @{ + ( $mro_recursor_stack->{cache} || {} )->{attrs}{$_} + ||= + [ attributes::get( $methlist{$_} ) ] + }, + )} sort keys %methlist + ), + } + } ( 'UNIVERSAL', @{ + ( $mro_recursor_stack->{cache} || {} )->{$_[0]}{linear_isa} + ||= + mro::get_linear_isa($_[0]) + } ) ) ) ) + ); + }; } else { require mro; constant->import( OLD_MRO => 0 ); + *DBIx::Class::_Util::get_real_pkg_gen = \&mro::get_pkg_gen; } # Both of these are no longer used for anything. However bring @@ -84,6 +147,7 @@ use Storable 'nfreeze'; use Scalar::Util qw(weaken blessed reftype refaddr); use Sub::Quote qw(qsub); use Sub::Name (); +use attributes (); # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone' BEGIN { *deep_clone = \&Storable::dclone } @@ -92,7 +156,7 @@ use base 'Exporter'; our @EXPORT_OK = qw( sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt fail_on_internal_wantarray fail_on_internal_call - refdesc refcount hrefaddr set_subname + refdesc refcount hrefaddr set_subname describe_class_methods scope_guard detected_reinvoked_destructor is_exception dbic_internal_try visit_namespaces quote_sub qsub perlstring serialize deep_clone dump_value uniq @@ -107,7 +171,6 @@ BEGIN { # FIXME FIXME FIXME # To be revisited when Moo with proper attr support ships Sub::Quote->VERSION(2.002); - require attributes; } # Override forcing no_defer, and adding naming consistency checks sub quote_sub { @@ -575,6 +638,187 @@ sub modver_gt_or_eq_and_lt ($$$) { ) ? 1 : 0; } +{ + # FIXME - should be a private my(), but I'm too uncertain whether + # all bases are covered + our $describe_class_query_cache; + + sub describe_class_methods { + + croak "Expecting a class name" + if not defined $_[0] or $_[0] !~ $module_name_rx; + + # use a cache on old MRO, since while we are recursing in this function + # nothing can possibly change (the speedup is immense) + # (yes, people could be tie()ing the stash and adding methods on access + # but there is a limit to how much crazy can be supported here) + # + # we use the cache for linear_isa lookups on new MRO as well - it adds + # a *tiny* speedup, and simplifies the code a lot + # + local $mro_recursor_stack->{cache} = {} + unless $mro_recursor_stack->{cache}; + + my $my_gen = 0; + + $my_gen += get_real_pkg_gen($_) for ( + 'UNIVERSAL', + my ($class, @my_ISA) = @{ + $mro_recursor_stack->{cache}{$_[0]}{linear_isa} + ||= + mro::get_linear_isa($_[0]) + } + ); + + my $slot = $describe_class_query_cache->{$class} ||= {}; + + unless ( ($slot->{cumulative_gen}||0) == $my_gen ) { + + # reset + %$slot = ( + class => $class, + isa => [ @my_ISA ], # copy before we shove UNIVERSAL into it + mro => { + type => mro::get_mro($class), + }, + cumulative_gen => $my_gen, + ); + $slot->{mro}{is_c3} = ($slot->{mro}{type} eq 'c3') ? 1 : 0; + + push @my_ISA, 'UNIVERSAL'; + + # ensure the cache is populated for the parents, code below can then + # efficiently operate over the query_cache directly + for (reverse @my_ISA) { + my ($parent_gen, @parent_ISA); + + # and even more skips before calling out recursively + describe_class_methods($_) unless ( + $describe_class_query_cache->{$_}{cumulative_gen} + and + $parent_gen = get_real_pkg_gen($_) + and + ( + ( + (undef, @parent_ISA) = @{ + $mro_recursor_stack->{cache}{$_}{linear_isa} + ||= + mro::get_linear_isa($_) + } + ) == 1 + or + do { + $parent_gen += get_real_pkg_gen($_) for @parent_ISA; + 1; + } + ) + and + $describe_class_query_cache->{$_}{cumulative_gen} == $parent_gen + ); + } + + my ($methods_seen_via_ISA_on_old_mro, $current_node_refaddr); + no strict 'refs'; + + # combine full ISA-order inherited and local method list into a + # "shadowing stack" + + ( + $current_node_refaddr = refaddr($_) + + and + + # on complex MI herarchies the method can be anywhere in the + # shadow stack - look through the entire slot, not just [0] + ( ! grep { + refaddr($_) == $current_node_refaddr + } @{ $slot->{methods}{ $_->{name} } || [] } ) + + and + + unshift @{ $slot->{methods}{$_->{name}} }, $_ + + and + + @{ $slot->{methods}{$_->{name}} } > 1 + + and + + $slot->{methods_with_supers}{$_->{name}} = $slot->{methods}{$_->{name}} + + ) for ( + + # what describe_class_methods for @my_ISA produced above + ( map { $_->[0] } map { + values %{ $describe_class_query_cache->{$_}{methods} } + } reverse @my_ISA ), + + # our own non-cleaned subs + their attributes + ( map { + ( + # these 2 OR-ed checks are sufficient for 5.10+ + ( + ref(\ "${class}::"->{$_} ) ne 'GLOB' + or + defined( *{ "${class}::"->{$_} }{CODE} ) + ) + and + # need to account for dummy helper crefs under OLD_MRO + ( + ! DBIx::Class::_ENV_::OLD_MRO + or + ( + $methods_seen_via_ISA_on_old_mro ||= do { + my $rv = {}; + $rv->{$_->{name}}->{ refaddr( \&{ "$_->{via_class}::$_->{name}"} ) } = 1 for + map { @$_ } map + { values %{ $describe_class_query_cache->{$_}{methods} } } + @my_ISA; + $rv; + } + and + ( + ! $methods_seen_via_ISA_on_old_mro->{$_} + or + ! $methods_seen_via_ISA_on_old_mro->{$_}{ refaddr( \&{"${class}::${_}"} ) } + ) + ) + ) + ) ? { + via_class => $class, + name => $_, + attributes => { map { $_ => 1 } @{ + $mro_recursor_stack->{cache}{attrs}{ refaddr \&{"${class}::${_}"} } + ||= + [ attributes::get( \&{"${class}::${_}"} ) ] + } }, + } + : () + } keys %{"${class}::"} ) + ); + + + # recalculate the pkg_gen on newer perls under Taint mode, + # because of shit like: + # perl -T -Mmro -e 'package Foo; sub bar {}; defined( *{ "Foo::"->{bar}}{CODE} ) and warn mro::get_pkg_gen("Foo") for (1,2,3)' + # + if ( + ! DBIx::Class::_ENV_::OLD_MRO + and + ${^TAINT} + ) { + + $slot->{cumulative_gen} = 0; + $slot->{cumulative_gen} += get_real_pkg_gen($_) + for $class, @my_ISA; + } + } + + # RV + +{ %$slot }; + } +} + # # Why not just use some higher-level module or at least File::Spec here? diff --git a/t/52leaks.t b/t/52leaks.t index fffc942d0..ae96a2176 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -108,6 +108,7 @@ if ( !$ENV{DBICTEST_VIA_REPLICATED} and !DBICTest::RunMode->is_plain ) { require DBI; require DBD::SQLite; require Moo; + require Math::BigInt; %$weak_registry = (); } diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t index b107a21b7..b26f5d53f 100644 --- a/xt/extra/internals/attributes.t +++ b/xt/extra/internals/attributes.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; @@ -22,12 +24,26 @@ BEGIN { use Test::More; use Test::Exception; -use DBIx::Class::_Util qw( quote_sub ); +use DBIx::Class::_Util qw( quote_sub describe_class_methods serialize refdesc ); +use List::Util 'shuffle'; +use Errno (); + +use DBICTest; + +my $pkg_gen_history = {}; + +sub grab_pkg_gen ($) { + push @{ $pkg_gen_history->{$_[0]} }, [ + DBIx::Class::_Util::get_real_pkg_gen($_[0]), + 'line ' . ( (caller(0))[2] ), + ]; +} -require DBIx::Class; @DBICTest::AttrLegacy::ISA = 'DBIx::Class'; sub DBICTest::AttrLegacy::VALID_DBIC_CODE_ATTRIBUTE { 1 } +grab_pkg_gen("DBICTest::AttrLegacy"); + my $var = \42; my $s = quote_sub( 'DBICTest::AttrLegacy::attr', @@ -39,6 +55,8 @@ my $s = quote_sub( }, ); +grab_pkg_gen("DBICTest::AttrLegacy"); + is $s, \&DBICTest::AttrLegacy::attr, 'Same cref installed'; is DBICTest::AttrLegacy::attr(), 42, 'Sub properly installed and callable'; @@ -47,33 +65,52 @@ is_deeply [ sort( attributes::get( $s ) ) ], [qw( DBIC_random_attr ResultSet )], 'Attribute installed', -unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 +; +{ + package DBICTest::SomeGrandParentClass; + use base 'DBIx::Class::MethodAttributes'; + sub VALID_DBIC_CODE_ATTRIBUTE { shift->next::method(@_) }; +} +{ + package DBICTest::SomeParentClass; + use base qw(DBICTest::SomeGrandParentClass); +} +{ + package DBICTest::AnotherParentClass; + use base 'DBIx::Class::MethodAttributes'; + sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ }; +} -@DBICTest::AttrTest::ISA = 'DBIx::Class'; { - package DBICTest::AttrTest; + package DBICTest::AttrTest; + + @DBICTest::AttrTest::ISA = qw( DBICTest::SomeParentClass DBICTest::AnotherParentClass ); + use mro 'c3'; + + ::grab_pkg_gen("DBICTest::AttrTest"); - eval <<'EOS' or die $@; - sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ } + eval <<'EOS' or die $@; sub attr :lvalue :method :DBIC_attr1 { $$var} 1; EOS - ::throws_ok { - attributes->import( - 'DBICTest::AttrTest', - DBICTest::AttrTest->can('attr'), - 'DBIC_unknownattr', - ); - } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/; + ::grab_pkg_gen("DBICTest::AttrTest"); + + ::throws_ok { + attributes->import( + 'DBICTest::AttrTest', + DBICTest::AttrTest->can('attr'), + 'DBIC_unknownattr', + ); + } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/; } is_deeply [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ], [qw( DBIC_attr1 lvalue method )], 'Attribute installed', -unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 +; ok( ! DBICTest::AttrTest->can('__attr_cache'), @@ -87,6 +124,7 @@ is_deeply( ); sub add_more_attrs { + # Test that secondary attribute application works attributes->import( 'DBICTest::AttrLegacy', @@ -101,11 +139,13 @@ sub add_more_attrs { 'SomethingNobodyUses', ); + grab_pkg_gen("DBICTest::AttrLegacy"); + is_deeply [ sort( attributes::get( $s ) )], [ qw( DBIC_random_attr ResultSet SomethingNobodyUses ) ], 'Secondary attributes installed', - unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 + ; is_deeply ( DBICTest::AttrLegacy->_attr_cache->{$s}, @@ -113,8 +153,6 @@ sub add_more_attrs { 'Attributes visible in legacy DBIC attribute API', ); - - # Test that secondary attribute application works attributes->import( 'DBICTest::AttrTest', @@ -122,6 +160,8 @@ sub add_more_attrs { 'DBIC_attr2', ); + grab_pkg_gen("DBICTest::AttrTest"); + # and that double-application also works attributes->import( 'DBICTest::AttrTest', @@ -130,11 +170,13 @@ sub add_more_attrs { 'DBIC_attr3', ); + grab_pkg_gen("DBICTest::AttrTest"); + is_deeply [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ], [qw( DBIC_attr1 DBIC_attr2 DBIC_attr3 lvalue method )], 'DBIC-specific attribute installed', - unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 + ; ok( ! DBICTest::AttrTest->can('__attr_cache'), @@ -146,27 +188,257 @@ sub add_more_attrs { {}, 'Legacy DBIC attribute cache never instantiated on core+DBIC-specific attrs' ); -} + # no point dragging in threads::shared, just do the check here + for my $class ( keys %$pkg_gen_history ) { + my $stack = $pkg_gen_history->{$class}; + + for my $i ( 1 .. $#$stack ) { + cmp_ok( + $stack->[$i-1][0], + ( DBIx::Class::_ENV_::OLD_MRO ? '!=' : '<' ), + $stack->[$i][0], + "pkg_gen for $class changed from $stack->[$i-1][1] to $stack->[$i][1]" + ); + } + } + + my $cnt; + # check that class description is stable, and changes when needed + for my $class (qw( + DBICTest::AttrTest + DBICTest::AttrLegacy + DBIx::Class + main + )) { + my $desc = describe_class_methods($class); + + is_deeply( + describe_class_methods($class), + $desc, + "describe_class_methods result is stable over '$class' (pass $_)" + ) for (1,2,3); + + my $desc2 = do { + no warnings 'once'; + no strict 'refs'; + + $cnt++; + + eval "sub UNIVERSAL::some_unimethod_$cnt {}; 1" or die $@; + + my $rv = describe_class_methods($class); + + delete ${"UNIVERSAL::"}{"some_unimethod_$cnt"}; + + $rv + }; + + delete $_->{cumulative_gen} for $desc, $desc2; + ok( + serialize( $desc ) + ne + serialize( $desc2 ), + "touching UNIVERSAL changed '$class' method availability" + ); + } + + my $bottom_most_V_D_C_A = refdesc( + describe_class_methods("DBIx::Class::MethodAttributes") + ->{methods} + ->{VALID_DBIC_CODE_ATTRIBUTE} + ->[0] + ); + + for my $class ( shuffle( qw( + DBICTest::AttrTest + DBICTest::AttrLegacy + DBICTest::SomeGrandParentClass + DBIx::Class::Schema + DBIx::Class::ResultSet + DBICTest::Schema::Track + ))) { + my $desc = describe_class_methods($class); + + is ( + refdesc( $desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ), + $bottom_most_V_D_C_A, + "Same physical structure returned for last VALID_DBIC_CODE_ATTRIBUTE via class $class" + ); + + is ( + refdesc( $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ), + $bottom_most_V_D_C_A, + "Same physical structure returned for bottom-most SUPER of VALID_DBIC_CODE_ATTRIBUTE via class $class" + ) if $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}; + } + + # check that describe_class_methods returns the right stuff + # ( on the simpler class ) + my $expected_AttrTest_ISA = [qw( + DBICTest::SomeParentClass + DBICTest::SomeGrandParentClass + DBICTest::AnotherParentClass + DBIx::Class::MethodAttributes + )]; + + my $expected_desc = { + class => "DBICTest::AttrTest", + + # sum and/or is_deeply are buggy on old List::Util/Test::More + # do the sum by hand ourselves to be sure + cumulative_gen => do { + require Math::BigInt; + my $gen = Math::BigInt->new(0); + + $gen += DBIx::Class::_Util::get_real_pkg_gen($_) for ( + 'UNIVERSAL', + 'DBICTest::AttrTest', + @$expected_AttrTest_ISA, + ); + + $gen; + }, + mro => { + type => 'c3', + is_c3 => 1, + }, + isa => $expected_AttrTest_ISA, + methods => { + FETCH_CODE_ATTRIBUTES => [ + { + attributes => {}, + name => "FETCH_CODE_ATTRIBUTES", + via_class => "DBIx::Class::MethodAttributes" + }, + ], + MODIFY_CODE_ATTRIBUTES => [ + { + attributes => {}, + name => "MODIFY_CODE_ATTRIBUTES", + via_class => "DBIx::Class::MethodAttributes" + }, + ], + VALID_DBIC_CODE_ATTRIBUTE => [ + { + attributes => {}, + name => "VALID_DBIC_CODE_ATTRIBUTE", + via_class => "DBICTest::SomeGrandParentClass", + }, + { + attributes => {}, + name => "VALID_DBIC_CODE_ATTRIBUTE", + via_class => "DBICTest::AnotherParentClass" + }, + { + attributes => {}, + name => "VALID_DBIC_CODE_ATTRIBUTE", + via_class => "DBIx::Class::MethodAttributes" + }, + ], + _attr_cache => [ + { + attributes => {}, + name => "_attr_cache", + via_class => "DBIx::Class::MethodAttributes" + }, + ], + attr => [ + { + attributes => { + DBIC_attr1 => 1, + DBIC_attr2 => 1, + DBIC_attr3 => 1, + lvalue => 1, + method => 1 + }, + name => "attr", + via_class => "DBICTest::AttrTest" + } + ], + can => [ + { + attributes => {}, + name => "can", + via_class => "UNIVERSAL", + }, + ], + isa => [ + { + attributes => {}, + name => "isa", + via_class => "UNIVERSAL", + }, + ], + VERSION => [ + { + attributes => {}, + name => "VERSION", + via_class => "UNIVERSAL", + }, + ], + ( DBIx::Class::_ENV_::OLD_MRO ? () : ( + DOES => [{ + attributes => {}, + name => "DOES", + via_class => "UNIVERSAL", + }], + ) ), + }, + }; + + $expected_desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE} + = $expected_desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE}; + + is_deeply ( + describe_class_methods("DBICTest::AttrTest"), + $expected_desc, + 'describe_class_methods returns correct data', + ); +} if ($skip_threads) { SKIP: { skip "Skipping the thread test: $skip_threads", 1 } add_more_attrs(); } -else { - threads->create(sub { +else { SKIP: { + + my $t = threads->create(sub { - threads->create(sub { + my $t = threads->create(sub { add_more_attrs(); select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls - })->join; + 42; + + }) || do { + die "Unable to start thread: $!" + unless $! == Errno::EAGAIN(); + + SKIP: { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 } + + return 42 ; + }; + + my $rv = $t->join; select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls - })->join; -} + $rv; + }) || do { + die "Unable to start thread: $!" + unless $! == Errno::EAGAIN(); + + skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1; + }; + + is ( + $t->join, + 42, + 'Thread stack exitted succesfully' + ); +}} done_testing; From 3b0202245e84a09a41ac31a13b80547a300a227e Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 6 Jun 2016 14:59:44 +0200 Subject: [PATCH 128/262] And yet another INDIRECT guard missed in both e5053694 and d99f2db7 --- lib/DBIx/Class/ResultSource.pm | 2 ++ lib/DBIx/Class/_Util.pm | 21 +++++++++++++++++++-- 2 files changed, 21 insertions(+), 2 deletions(-) diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index eb56b01f9..c51c45d5f 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -804,6 +804,8 @@ See also L. =cut sub add_unique_constraints { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + my $self = shift; my @constraints = @_; diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 11034e24e..bb06ec2cb 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -930,12 +930,29 @@ sub fail_on_internal_call { ; }; + my @fr2; + # need to make allowance for a proxy-yet-direct call + my $check_fr = ( + $fr->[0] eq 'DBIx::Class::ResultSourceProxy' + and + @fr2 = (CORE::caller(2)) + and + ( + ( $fr->[3] =~ /([^:])+$/ )[0] + eq + ( $fr2[3] =~ /([^:])+$/ )[0] + ) + ) + ? \@fr2 + : $fr + ; + if ( $argdesc and - $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ + $check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ and - $fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there + $check_fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there ) { DBIx::Class::Exception->throw( sprintf ( "Illegal internal call of indirect proxy-method %s() with argument '%s': examine the last lines of the proxy method deparse below to determine what to call directly instead at %s on line %d\n\n%s\n\n Stacktrace starts", From a0216b74a2adae244ebc89beef5df673e0bb79a3 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 5 Jun 2016 12:00:43 +0200 Subject: [PATCH 129/262] Base more tests on DBICTest::BaseSchema (needed further up) --- t/102load_classes.t | 2 +- t/39load_namespaces_1.t | 2 +- t/39load_namespaces_2.t | 2 +- t/39load_namespaces_3.t | 2 +- t/39load_namespaces_4.t | 2 +- t/39load_namespaces_exception.t | 2 +- t/39load_namespaces_rt41083.t | 4 ++-- t/39load_namespaces_stress.t | 2 +- t/row/inflate_result.t | 2 +- 9 files changed, 10 insertions(+), 10 deletions(-) diff --git a/t/102load_classes.t b/t/102load_classes.t index ef99b3aec..d391b3423 100644 --- a/t/102load_classes.t +++ b/t/102load_classes.t @@ -11,7 +11,7 @@ my $warnings; eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICTest::Schema; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; __PACKAGE__->load_classes; }; ok(!$@, 'Loaded all loadable classes') or diag $@; diff --git a/t/39load_namespaces_1.t b/t/39load_namespaces_1.t index c6355a718..f7fb08ee2 100644 --- a/t/39load_namespaces_1.t +++ b/t/39load_namespaces_1.t @@ -11,7 +11,7 @@ my $warnings; eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICNSTest; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; __PACKAGE__->load_namespaces; }; ok(!$@, 'load_namespaces doesnt die') or diag $@; diff --git a/t/39load_namespaces_2.t b/t/39load_namespaces_2.t index e38dfd594..1e73c7f6e 100644 --- a/t/39load_namespaces_2.t +++ b/t/39load_namespaces_2.t @@ -13,7 +13,7 @@ my $warnings; eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICNSTest; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; __PACKAGE__->load_namespaces( result_namespace => 'Rslt', resultset_namespace => 'RSet', diff --git a/t/39load_namespaces_3.t b/t/39load_namespaces_3.t index 144feb6cb..1b63baa83 100644 --- a/t/39load_namespaces_3.t +++ b/t/39load_namespaces_3.t @@ -12,7 +12,7 @@ use DBICTest; # do not remove even though it is not used lives_ok (sub { warnings_exist ( sub { package DBICNSTestOther; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; __PACKAGE__->load_namespaces( result_namespace => [ '+DBICNSTest::Rslt', '+DBICNSTest::OtherRslt' ], resultset_namespace => '+DBICNSTest::RSet', diff --git a/t/39load_namespaces_4.t b/t/39load_namespaces_4.t index d0e82ed71..789ed5097 100644 --- a/t/39load_namespaces_4.t +++ b/t/39load_namespaces_4.t @@ -13,7 +13,7 @@ my $warnings; eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICNSTest; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; __PACKAGE__->load_namespaces( default_resultset_class => 'RSBase' ); }; ok(!$@) or diag $@; diff --git a/t/39load_namespaces_exception.t b/t/39load_namespaces_exception.t index e0d65ece5..14bf34222 100644 --- a/t/39load_namespaces_exception.t +++ b/t/39load_namespaces_exception.t @@ -11,7 +11,7 @@ plan tests => 1; eval { package DBICNSTest; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; __PACKAGE__->load_namespaces( result_namespace => 'Bogus', resultset_namespace => 'RSet', diff --git a/t/39load_namespaces_rt41083.t b/t/39load_namespaces_rt41083.t index 0e33420ea..f59d59758 100644 --- a/t/39load_namespaces_rt41083.t +++ b/t/39load_namespaces_rt41083.t @@ -32,7 +32,7 @@ sub _verify_sources { eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICNSTest::RtBug41083; - use base 'DBIx::Class::Schema'; + use base 'DBICTest::BaseSchema'; __PACKAGE__->load_namespaces( result_namespace => 'Result_A', resultset_namespace => 'ResultSet_A', @@ -52,7 +52,7 @@ sub _verify_sources { eval { local $SIG{__WARN__} = sub { $warnings .= shift }; package DBICNSTest::RtBug41083; - use base 'DBIx::Class::Schema'; + use base 'DBICTest::BaseSchema'; __PACKAGE__->load_namespaces( default_resultset_class => 'ResultSet' ); diff --git a/t/39load_namespaces_stress.t b/t/39load_namespaces_stress.t index ff64dbfa0..bfef36056 100644 --- a/t/39load_namespaces_stress.t +++ b/t/39load_namespaces_stress.t @@ -27,7 +27,7 @@ EOM { package DBICTest::NS::Stress::Schema; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; sub _findallmod { return $_[1] eq ( __PACKAGE__ . '::Result' ) diff --git a/t/row/inflate_result.t b/t/row/inflate_result.t index f2f6b8078..9fa49ac18 100644 --- a/t/row/inflate_result.t +++ b/t/row/inflate_result.t @@ -60,7 +60,7 @@ sub do_admin_stuff { package My::Schema; -use base qw/DBIx::Class::Schema/; +use base qw/DBICTest::BaseSchema/; My::Schema->register_class( Admin => 'My::Schema::Result::User::Admin' ); My::Schema->register_class( User => 'My::Schema::Result::User' ); From 55586a638f3cf21cc18c977cf1126828a84e9d2b Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 7 Jun 2016 17:22:11 +0200 Subject: [PATCH 130/262] (travis) Mini-utility to download travis reports I've had enough waiting for their shit site :/ --- maint/travis_buildlog_downloader | 41 ++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) create mode 100755 maint/travis_buildlog_downloader diff --git a/maint/travis_buildlog_downloader b/maint/travis_buildlog_downloader new file mode 100755 index 000000000..b67ed151f --- /dev/null +++ b/maint/travis_buildlog_downloader @@ -0,0 +1,41 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +# H::T does not support gzip/deflate out of the box, but you know what? +# THAT'S OK BECAUSE TRAVIS' LOGSERVER DOESN'T EITHER +use HTTP::Tiny; + +use JSON::PP; + +( my $build_id = $ARGV[0]||'' ) =~ /^[0-9]+$/ + or die "Expecting a numeric build id as argument\n"; + +my $base_url = "http://api.travis-ci.org/builds/$build_id"; +print "Retrieving $base_url\n"; + +my $resp = ( my $ua = HTTP::Tiny->new )->get( $base_url ); +die "Unable to retrieve $resp->{url}: $resp->{status}\n$resp->{content}\n\n" + unless $resp->{success}; + +my @job_ids = ( map + { ($_->{id}||'') =~ /^([0-9]+)$/ } + @{( eval { decode_json( $resp->{content} )->{matrix} } || [] )} +) or die "Unable to find any job ids:\n$resp->{content}\n\n"; + +my $dir = "TravisCI_build_$build_id"; + +mkdir $dir + unless -d $dir; + +for my $job_id (@job_ids) { + my $log_url = "http://api.travis-ci.org/jobs/$job_id/log.txt"; + my $dest_fn = "$dir/job_$job_id.log"; + + print "Retrieving $log_url into $dest_fn\n"; + + $resp = $ua->mirror( $log_url, $dest_fn ); + warn "Error retrieving $resp->{url}: $resp->{status}\n$resp->{content}\n\n" + unless $resp->{success}; +} From fe21f2224c1dcf8c1107bde8ea7b21e6ca7b994c Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 7 Jun 2016 19:21:54 +0200 Subject: [PATCH 131/262] (travis) Report the perl (and vm state) early before deps can fail --- maint/travis-ci_scripts/30_before_script.bash | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index f590ff0b4..091e15555 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -25,6 +25,11 @@ if is_cperl ; then fi + +# announce what are we running +echo_err "$(ci_vm_state_text)" + + # FIXME - this is a kludge in place of proper MVDT testing. For the time # being simply use the minimum versions of our DBI/DBDstack, to avoid # fuckups like 0.08260 (went unnoticed for 5 months) @@ -239,9 +244,6 @@ if [[ "$CLEANTEST" = "true" ]] && perl -MModule::Build::Tiny -e1 &>/dev/null ; t exit 1 fi -# announce what are we running echo_err " ===================== DEPENDENCY CONFIGURATION COMPLETE ===================== -$(tstamp) Configuration phase seems to have taken $(date -ud "@$SECONDS" '+%H:%M:%S') (@$SECONDS) - -$(ci_vm_state_text)" +$(tstamp) Configuration phase seems to have taken $(date -ud "@$SECONDS" '+%H:%M:%S') (@$SECONDS)" From e66f0ee02df23037e2b0f26bc6ae26a758e5c419 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 2 Jun 2016 19:55:31 +0200 Subject: [PATCH 132/262] (travis) Add cperl master to the smoke roster, bump to 5.22.3 --- .travis.yml | 19 ++++++++--- maint/travis-ci_scripts/20_install.bash | 32 ++++++++++--------- maint/travis-ci_scripts/30_before_script.bash | 30 +++++++---------- 3 files changed, 43 insertions(+), 38 deletions(-) diff --git a/.travis.yml b/.travis.yml index fe1c57154..2b0d8b946 100644 --- a/.travis.yml +++ b/.travis.yml @@ -223,10 +223,10 @@ matrix: ### # Start of the allow_failures block - # MAKE SURE TO KEEP THE FLAGS IDENTICAL TO STOCK 5.22.1 ABOVE + # MAKE SURE TO KEEP THE FLAGS IDENTICAL TO STOCK 5.latest.comparable ABOVE # allows for easier side-by-side comparison # vcpu=1 for even more stable results - - perl: "cperl-5.22.2_thr_qm" + - perl: "cperl-5.22.3_thr_qm" # explicit new infra spec preparing for a future forced upgrade # also need to pull in a sufficiently new compiler for quadmath.h sudo: required @@ -236,9 +236,19 @@ matrix: - CLEANTEST=true - POISON_ENV=true - MVDT=false - - BREWVER=cperl-5.22.2 + - BREWVER=cperl-5.22.3 - BREWOPTS="-Duseithreads -Dusequadmath" + - perl: "cperl-master_thr" + sudo: false + dist: precise + env: + - CLEANTEST=true + - POISON_ENV=true + - MVDT=false + - BREWVER=cperl-master + - BREWOPTS="-Duseithreads" + # threaded oldest possible with blead CPAN - perl: "devcpan_5.8.1_thr_mb" sudo: false @@ -349,7 +359,8 @@ matrix: allow_failures: # these run with various dev snapshots - allowed to fail - - perl: cperl-5.22.2_thr_qm + - perl: cperl-5.22.3_thr_qm + - perl: cperl-master_thr - perl: devcpan_5.8.1_thr_mb - perl: devcpan_5.8.1 - perl: devcpan_5.8.3_mb diff --git a/maint/travis-ci_scripts/20_install.bash b/maint/travis-ci_scripts/20_install.bash index 4fc50d01a..947bf1e7a 100755 --- a/maint/travis-ci_scripts/20_install.bash +++ b/maint/travis-ci_scripts/20_install.bash @@ -32,9 +32,14 @@ if [[ -n "$BREWVER" ]] ; then BREWSRC="$BREWVER" if is_cperl; then - # FFS perlbrew ( see http://wollmers-perl.blogspot.de/2015/10/install-cperl-with-perlbrew.html ) - wget -qO- https://github.com/perl11/cperl/archive/$BREWVER.tar.gz > /tmp/cperl-$BREWVER.tar.gz - BREWSRC="/tmp/cperl-$BREWVER.tar.gz" + if [[ "$BREWVER" == "cperl-master" ]] ; then + git clone --single-branch --depth=1 --branch=master https://github.com/perl11/cperl /tmp/cperl-master + BREWSRC="/tmp/cperl-master" + else + # FFS perlbrew ( see http://wollmers-perl.blogspot.de/2015/10/install-cperl-with-perlbrew.html ) + wget -qO- https://github.com/perl11/cperl/archive/$BREWVER.tar.gz > /tmp/cperl-$BREWVER.tar.gz + BREWSRC="/tmp/cperl-$BREWVER.tar.gz" + fi elif [[ "$BREWVER" == "schmorp_stableperl" ]] ; then BREWSRC="http://stableperl.schmorp.de/dist/stableperl-5.22.0-1.001.tar.gz" fi @@ -43,6 +48,7 @@ if [[ -n "$BREWVER" ]] ; then "perlbrew install --as $BREWVER --notest --noman --verbose $BREWOPTS -j${perlbrew_jopt:-1} $BREWSRC" # FIXME work around https://github.com/perl11/cperl/issues/144 + # (still affecting 5.22.3) if is_cperl && ! [[ -f ~/perl5/perlbrew/perls/$BREWVER/bin/perl ]] ; then ln -s ~/perl5/perlbrew/perls/$BREWVER/bin/cperl ~/perl5/perlbrew/perls/$BREWVER/bin/perl fi @@ -141,21 +147,17 @@ if [[ "$POISON_ENV" = "true" ]] ; then ### emulate a local::lib-like env - # FIXME - work around https://github.com/perl11/cperl/issues/145 - if ! is_cperl ; then - # 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" - - # move it somewhere as following cpanm will clobber it - run_or_err "Moving latest stable DBIC from CPAN to /tmp" "mv ~/.cpanm/latest-build/DBIx-Class-*/lib /tmp/stable_dbic_lib" + # 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="/tmp/stable_dbic_lib:$PERL5LIB" + # move it somewhere as following cpanm will clobber it + run_or_err "Moving latest stable DBIC from CPAN to /tmp" "mv ~/.cpanm/latest-build/DBIx-Class-*/lib /tmp/stable_dbic_lib" - # perldoc -l searches $(pwd)/lib in addition to PERL5LIB etc, hence the cd / - echo_err "Latest stable DBIC (without deps) locatable via \$PERL5LIB at $(cd / && perldoc -l DBIx::Class)" - fi + export PERL5LIB="/tmp/stable_dbic_lib:$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)" fi if [[ "$CLEANTEST" != "true" ]] ; then diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 091e15555..71bf1623c 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -12,8 +12,6 @@ if [[ "$DEVREL_DEPS" == "true" ]] ; then fi # Need a shitton of patches to run on cperl (luckily all provided) -# Also need to have YAML in place, otherwise the distroprefs are not readable -# (cperl 5.22.2 comes with YAML already) if is_cperl ; then run_or_err "Downloading and installing cperl distroprefs" ' @@ -21,6 +19,12 @@ if is_cperl ; then tar -C $HOME/.cpan --strip-components 1 -zx distroprefs-master/prefs distroprefs-master/sources ' + # Argh -DFORTIFY_INC!!! + # FIXME - remove when M::I is gone + export PERL5LIB="$PERL5LIB:." + + # Also need to have YAML in place, otherwise the distroprefs are not readable + # (cperl 5.22.2 comes with YAML already) perl -M5.022002 -e1 &>/dev/null || installdeps YAML fi @@ -101,24 +105,12 @@ if [[ "$CLEANTEST" = "true" ]]; then # the point is to have a *really* clean perl (the ones # we build are guaranteed to be clean, without side # effects from travis preinstalls) + # + # trick cpanm into executing true as shell - we just need the find+unpack + [[ -d ~/.cpanm/latest-build/DBIx-Class-*/inc ]] || run_or_err "Downloading latest stable DBIC inc/ from CPAN" \ + "SHELL=/bin/true cpanm --look DBIx::Class" - # work around https://github.com/perl11/cperl/issues/145 (no cpanm) - if is_cperl ; then - - wget -qO- $( wget -qO- http://cpanmetadb.plackperl.org/v1.0/package/DBIx::Class | grep distfile | sed "s|distfile:\s*|$CPAN_MIRROR/authors/id/|" ) \ - | tar -zx --strip-components 1 --wildcards '*/inc' - - # FIXME - kill this when M::I is gone - # Argh -DFORTIFY_INC!!! - export PERL5LIB="$PERL5LIB:." - - else - # trick cpanm into executing true as shell - we just need the find+unpack - [[ -d ~/.cpanm/latest-build/DBIx-Class-*/inc ]] || run_or_err "Downloading latest stable DBIC inc/ from CPAN" \ - "SHELL=/bin/true cpanm --look DBIx::Class" - - mv ~/.cpanm/latest-build/DBIx-Class-*/inc . - fi + mv ~/.cpanm/latest-build/DBIx-Class-*/inc . # The first CPAN which is somewhat sane is around 1.94_56 (perl 5.12) # The problem is that the first sane version also brings a *lot* of From ee3a37d38c54973f7e4b65273d776bbad54f6101 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 8 Jun 2016 09:47:56 +0200 Subject: [PATCH 133/262] (travis) Work around a bad tradeoff in cperl-5.24-to-be https://github.com/perl11/cperl/issues/153#issuecomment-224515895 http://irclog.perlgeek.de/perl11/2016-06-08#i_12624951 --- maint/travis-ci_scripts/30_before_script.bash | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 71bf1623c..10932d3a9 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -27,6 +27,11 @@ if is_cperl ; then # (cperl 5.22.2 comes with YAML already) perl -M5.022002 -e1 &>/dev/null || installdeps YAML + # Work around cperl's Test::More being typed, by getting the CPAN one + # https://github.com/perl11/cperl/issues/153#issuecomment-224515895 + # ( in the long term this is sadly a nail in cperl's coffin :/ ) + installdeps Test::More + fi From c2fb4a8c6dab173c717e9decc48df4efef6a5abf Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 10 Jun 2016 08:13:30 +0200 Subject: [PATCH 134/262] (travis) Revert parts of e66f0ee0 and ee3a37d3 The typing of @array * $int got relaxed, and it turns out c5.22.2 worked just fine *without* distroprefs, so I never noticed them being ignored --- maint/travis-ci_scripts/30_before_script.bash | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 10932d3a9..2a5532451 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -24,13 +24,8 @@ if is_cperl ; then export PERL5LIB="$PERL5LIB:." # Also need to have YAML in place, otherwise the distroprefs are not readable - # (cperl 5.22.2 comes with YAML already) - perl -M5.022002 -e1 &>/dev/null || installdeps YAML - - # Work around cperl's Test::More being typed, by getting the CPAN one - # https://github.com/perl11/cperl/issues/153#issuecomment-224515895 - # ( in the long term this is sadly a nail in cperl's coffin :/ ) - installdeps Test::More + # work around https://github.com/perl11/cperl/issues/155#issuecomment-224862978 + perl -MYAML -e1 &>/dev/null || installdeps YAML fi From cc7e60178124eedbbdce941b61ee8925263c6319 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 10 Jun 2016 08:31:56 +0200 Subject: [PATCH 135/262] (travis) Temporarily disable {halt_on_failure} for cperl It is not clear whether there is a way around the root cause: https://github.com/rurban/distroprefs/commit/30792f7e95ca76ac1c1e73d0662dce22168c9df9#commitcomment-17817389 --- maint/travis-ci_scripts/20_install.bash | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/maint/travis-ci_scripts/20_install.bash b/maint/travis-ci_scripts/20_install.bash index 947bf1e7a..3a4ff7b7b 100755 --- a/maint/travis-ci_scripts/20_install.bash +++ b/maint/travis-ci_scripts/20_install.bash @@ -85,7 +85,7 @@ CPAN_CFG_SCRIPT=" *CPAN::FirstTime::conf_sites = sub {}; CPAN::Config->load; \$CPAN::Config->{urllist} = [qw{ $CPAN_MIRROR }]; - \$CPAN::Config->{halt_on_failure} = 1; + \$CPAN::Config->{halt_on_failure} = $( is_cperl && echo -n 0 || echo -n 1 ); CPAN::Config->commit; " run_or_err "Configuring CPAN.pm" "perl -e '$CPAN_CFG_SCRIPT'" From 5b87fc0f74c6f7de9d4b544ef31104fac7b2a5a9 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 9 Jun 2016 11:06:39 +0200 Subject: [PATCH 136/262] Add extra maint tooling - got tired of writing this smoke cmd by hand --- maint/poisonsmoke.bash | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) create mode 100755 maint/poisonsmoke.bash diff --git a/maint/poisonsmoke.bash b/maint/poisonsmoke.bash new file mode 100755 index 000000000..c3c637ce8 --- /dev/null +++ b/maint/poisonsmoke.bash @@ -0,0 +1,34 @@ +#!/bin/bash + +set -e + +[[ -e Makefile.PL ]] || ( echo "Not in the right dir" && exit 1 ) + +clear +echo + +export TRAVIS=true +export TRAVIS_REPO_SLUG="x/dbix-class" +export DBI_DSN="dbi:ODBC:server=NonexistentServerAddress" +export DBI_DRIVER="ADO" + +toggle_booleans=( \ + $( grep -ohP '\bDBIC_[0-9_A-Z]+' -r lib/ --exclude-dir Optional | sort -u | grep -vP '^(DBIC_TRACE(_PROFILE)?|DBIC_.+_DEBUG)$' ) \ + DBIC_SHUFFLE_UNORDERED_RESULTSETS \ + DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION \ + DBICTEST_RUN_ALL_TESTS \ + DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER \ +) + +for var in "${toggle_booleans[@]}" +do + if [[ -z "${!var}" ]] ; then + export $var=1 + echo "POISON_ENV: setting $var to 1" + fi +done + +provecmd="nice prove -QlrswTj10" + +echo -e "\nExecuting \`$provecmd\` via $(which perl)\n" +$provecmd From 2d9a96fd40eb4be24a9a254953e1e3cd8e20ea3a Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 10 Jun 2016 08:22:38 +0200 Subject: [PATCH 137/262] Fix m2m regression from 8a67d9cf (simple but deadly) --- lib/DBIx/Class/Relationship/ManyToMany.pm | 2 +- t/relationship/core.t | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm index fdfb5ddaa..c7cde16d7 100644 --- a/lib/DBIx/Class/Relationship/ManyToMany.pm +++ b/lib/DBIx/Class/Relationship/ManyToMany.pm @@ -161,7 +161,7 @@ EOC ) if ( @_ > 1 or - ( @_ and ref $_[0] ne 'HASH' ) + ( defined $_[0] and ref $_[0] ne 'HASH' ) ); my $guard; diff --git a/t/relationship/core.t b/t/relationship/core.t index be8d7c91d..de6afd7c7 100644 --- a/t/relationship/core.t +++ b/t/relationship/core.t @@ -195,7 +195,8 @@ warnings_like { qr/\Qsearch( %condition ) is deprecated/ ], 'Warning properly bubbled from search()'; -$cd->set_producers([$schema->resultset('Producer')->all]); +# the undef-attr-arg at the end is deliberate: this is what FormFu does +$cd->set_producers([$schema->resultset('Producer')->all], undef); is( $cd->producers->count(), $prod_before_count+2, 'many_to_many set_$rel(\@objs) count ok' ); $cd->set_producers([$schema->resultset('Producer')->find(1)]); From 5e67be2621ad5b3c2d5d6927b85d344ed436cd2b Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 14 Jun 2016 09:18:48 +0200 Subject: [PATCH 138/262] Name describe_class_methods arguments earlier The attribute::get() caching seems to only add noise in benchmarks, so remove that. Same for the pre-check on recursion - remove that as well --- lib/DBIx/Class/_Util.pm | 51 ++++++++--------------------------------- 1 file changed, 10 insertions(+), 41 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index bb06ec2cb..371db28c7 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -96,11 +96,7 @@ BEGIN { $class, map {( $_, # refaddr is sufficient, ignore names entirely - @{ - ( $mro_recursor_stack->{cache} || {} )->{attrs}{$_} - ||= - [ attributes::get( $methlist{$_} ) ] - }, + attributes::get( $methlist{$_} ) )} sort keys %methlist ), } @@ -644,9 +640,10 @@ sub modver_gt_or_eq_and_lt ($$$) { our $describe_class_query_cache; sub describe_class_methods { + my ($class) = @_; croak "Expecting a class name" - if not defined $_[0] or $_[0] !~ $module_name_rx; + if not defined $class or $class !~ $module_name_rx; # use a cache on old MRO, since while we are recursing in this function # nothing can possibly change (the speedup is immense) @@ -663,10 +660,10 @@ sub modver_gt_or_eq_and_lt ($$$) { $my_gen += get_real_pkg_gen($_) for ( 'UNIVERSAL', - my ($class, @my_ISA) = @{ - $mro_recursor_stack->{cache}{$_[0]}{linear_isa} + ( $class, my @my_ISA ) = @{ + $mro_recursor_stack->{cache}{$class}{linear_isa} ||= - mro::get_linear_isa($_[0]) + mro::get_linear_isa($class) } ); @@ -689,33 +686,7 @@ sub modver_gt_or_eq_and_lt ($$$) { # ensure the cache is populated for the parents, code below can then # efficiently operate over the query_cache directly - for (reverse @my_ISA) { - my ($parent_gen, @parent_ISA); - - # and even more skips before calling out recursively - describe_class_methods($_) unless ( - $describe_class_query_cache->{$_}{cumulative_gen} - and - $parent_gen = get_real_pkg_gen($_) - and - ( - ( - (undef, @parent_ISA) = @{ - $mro_recursor_stack->{cache}{$_}{linear_isa} - ||= - mro::get_linear_isa($_) - } - ) == 1 - or - do { - $parent_gen += get_real_pkg_gen($_) for @parent_ISA; - 1; - } - ) - and - $describe_class_query_cache->{$_}{cumulative_gen} == $parent_gen - ); - } + describe_class_methods($_) for reverse @my_ISA; my ($methods_seen_via_ISA_on_old_mro, $current_node_refaddr); no strict 'refs'; @@ -787,11 +758,9 @@ sub modver_gt_or_eq_and_lt ($$$) { ) ? { via_class => $class, name => $_, - attributes => { map { $_ => 1 } @{ - $mro_recursor_stack->{cache}{attrs}{ refaddr \&{"${class}::${_}"} } - ||= - [ attributes::get( \&{"${class}::${_}"} ) ] - } }, + attributes => { + map { $_ => 1 } attributes::get( \&{"${class}::${_}"} ) + }, } : () } keys %{"${class}::"} ) From 085dbdd69f2b8c80e32698fc6b7e918addaf7fc9 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 14 Jun 2016 18:05:51 +0200 Subject: [PATCH 139/262] Fix describe_class_methods on non-mergeable DFS mro Instead of trying to deduplicate - simply track which methods are locally defined, and use that info combined with a reverse ISA-per-select-MRO to build the final stack. As a result the code is even more efficient and can now deal with real-life insane hierarchies like: https://metacpan.org/source/MJFLICK/DBIx-Class-Bootstrap-Simple-0.03/lib/DBIx/Class/Bootstrap/Simple.pm#L93 --- lib/DBIx/Class/_Util.pm | 18 +++++++++--------- xt/extra/internals/attributes.t | 26 ++++++++++++++++++++++++++ 2 files changed, 35 insertions(+), 9 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 371db28c7..35d11df47 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -699,15 +699,15 @@ sub modver_gt_or_eq_and_lt ($$$) { and - # on complex MI herarchies the method can be anywhere in the - # shadow stack - look through the entire slot, not just [0] - ( ! grep { - refaddr($_) == $current_node_refaddr - } @{ $slot->{methods}{ $_->{name} } || [] } ) + unshift @{ $slot->{methods}{$_->{name}} }, $_ and - unshift @{ $slot->{methods}{$_->{name}} }, $_ + ( + $_->{via_class} ne $class + or + $slot->{methods_defined_in_class}{$_->{name}} = $_ + ) and @@ -720,9 +720,9 @@ sub modver_gt_or_eq_and_lt ($$$) { ) for ( # what describe_class_methods for @my_ISA produced above - ( map { $_->[0] } map { - values %{ $describe_class_query_cache->{$_}{methods} } - } reverse @my_ISA ), + ( map { values %{ + $describe_class_query_cache->{$_}{methods_defined_in_class} || {} + } } reverse @my_ISA ), # our own non-cleaned subs + their attributes ( map { diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t index b26f5d53f..bed8efd1f 100644 --- a/xt/extra/internals/attributes.t +++ b/xt/extra/internals/attributes.t @@ -390,6 +390,9 @@ sub add_more_attrs { $expected_desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE} = $expected_desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE}; + $expected_desc->{methods_defined_in_class}{attr} + = $expected_desc->{methods}{attr}[0]; + is_deeply ( describe_class_methods("DBICTest::AttrTest"), $expected_desc, @@ -441,4 +444,27 @@ else { SKIP: { ); }} +# this doesn't really belong in this test, but screw it +{ + package DBICTest::WackyDFS; + use base qw( DBICTest::SomeGrandParentClass DBICTest::SomeParentClass ); +} + +is_deeply + describe_class_methods("DBICTest::WackyDFS")->{methods}{VALID_DBIC_CODE_ATTRIBUTE}, + [ + { + attributes => {}, + name => "VALID_DBIC_CODE_ATTRIBUTE", + via_class => "DBICTest::SomeGrandParentClass", + }, + { + attributes => {}, + name => "VALID_DBIC_CODE_ATTRIBUTE", + via_class => "DBIx::Class::MethodAttributes" + }, + ], + 'Expected description on unusable inheritance hierarchy' +; + done_testing; From d01688ccb3f9455ee7caeacc27d8ff106d7cad1c Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 13 Jun 2016 18:43:31 +0200 Subject: [PATCH 140/262] Properly handle UNIVERSAL ancestry in describe_class_methods Obscure but possible nevertheless. --- lib/DBIx/Class/_Util.pm | 65 ++++++++++++++++++++++++--------- xt/extra/internals/attributes.t | 15 +++++++- 2 files changed, 60 insertions(+), 20 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 35d11df47..1117d87bf 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -100,11 +100,25 @@ BEGIN { )} sort keys %methlist ), } - } ( 'UNIVERSAL', @{ - ( $mro_recursor_stack->{cache} || {} )->{$_[0]}{linear_isa} - ||= - mro::get_linear_isa($_[0]) - } ) ) ) ) + } ( + + @{ + ( $mro_recursor_stack->{cache} || {} )->{$_[0]}{linear_isa} + ||= + mro::get_linear_isa($_[0]) + }, + + (( + ( $mro_recursor_stack->{cache} || {} )->{$_[0]}{is_universal} + ||= + mro::is_universal($_[0]) + ) ? () : @{ + ( $mro_recursor_stack->{cache} || {} )->{UNIVERSAL}{linear_isa} + ||= + mro::get_linear_isa("UNIVERSAL") + } ), + + ) ) ) ) ); }; } @@ -658,23 +672,40 @@ sub modver_gt_or_eq_and_lt ($$$) { my $my_gen = 0; - $my_gen += get_real_pkg_gen($_) for ( - 'UNIVERSAL', - ( $class, my @my_ISA ) = @{ + $my_gen += get_real_pkg_gen($_) for ( my @full_ISA = ( + + @{ $mro_recursor_stack->{cache}{$class}{linear_isa} ||= mro::get_linear_isa($class) - } - ); + }, + + (( + $mro_recursor_stack->{cache}{$class}{is_universal} + ||= + mro::is_universal($class) + ) ? () : @{ + $mro_recursor_stack->{cache}{UNIVERSAL}{linear_isa} + ||= + mro::get_linear_isa("UNIVERSAL") + }), + + )); my $slot = $describe_class_query_cache->{$class} ||= {}; unless ( ($slot->{cumulative_gen}||0) == $my_gen ) { + # remove ourselves from ISA + shift @full_ISA; + # reset %$slot = ( class => $class, - isa => [ @my_ISA ], # copy before we shove UNIVERSAL into it + isa => [ + @{ $mro_recursor_stack->{cache}{$class}{linear_isa} } + [ 1 .. $#{$mro_recursor_stack->{cache}{$class}{linear_isa}} ] + ], mro => { type => mro::get_mro($class), }, @@ -682,11 +713,9 @@ sub modver_gt_or_eq_and_lt ($$$) { ); $slot->{mro}{is_c3} = ($slot->{mro}{type} eq 'c3') ? 1 : 0; - push @my_ISA, 'UNIVERSAL'; - # ensure the cache is populated for the parents, code below can then # efficiently operate over the query_cache directly - describe_class_methods($_) for reverse @my_ISA; + describe_class_methods($_) for reverse @full_ISA; my ($methods_seen_via_ISA_on_old_mro, $current_node_refaddr); no strict 'refs'; @@ -719,10 +748,10 @@ sub modver_gt_or_eq_and_lt ($$$) { ) for ( - # what describe_class_methods for @my_ISA produced above + # what describe_class_methods for @full_ISA produced above ( map { values %{ $describe_class_query_cache->{$_}{methods_defined_in_class} || {} - } } reverse @my_ISA ), + } } reverse @full_ISA ), # our own non-cleaned subs + their attributes ( map { @@ -744,7 +773,7 @@ sub modver_gt_or_eq_and_lt ($$$) { $rv->{$_->{name}}->{ refaddr( \&{ "$_->{via_class}::$_->{name}"} ) } = 1 for map { @$_ } map { values %{ $describe_class_query_cache->{$_}{methods} } } - @my_ISA; + @full_ISA; $rv; } and @@ -779,7 +808,7 @@ sub modver_gt_or_eq_and_lt ($$$) { $slot->{cumulative_gen} = 0; $slot->{cumulative_gen} += get_real_pkg_gen($_) - for $class, @my_ISA; + for $class, @full_ISA; } } diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t index bed8efd1f..0bd2e478a 100644 --- a/xt/extra/internals/attributes.t +++ b/xt/extra/internals/attributes.t @@ -32,6 +32,9 @@ use DBICTest; my $pkg_gen_history = {}; +{ package UEBERVERSAL; sub ueber {} } +@UNIVERSAL::ISA = "UEBERVERSAL"; + sub grab_pkg_gen ($) { push @{ $pkg_gen_history->{$_[0]} }, [ DBIx::Class::_Util::get_real_pkg_gen($_[0]), @@ -225,11 +228,11 @@ sub add_more_attrs { $cnt++; - eval "sub UNIVERSAL::some_unimethod_$cnt {}; 1" or die $@; + eval "sub UEBERVERSAL::some_unimethod_$cnt {}; 1" or die $@; my $rv = describe_class_methods($class); - delete ${"UNIVERSAL::"}{"some_unimethod_$cnt"}; + delete ${"UEBERVERSAL::"}{"some_unimethod_$cnt"}; $rv }; @@ -292,6 +295,7 @@ sub add_more_attrs { my $gen = Math::BigInt->new(0); $gen += DBIx::Class::_Util::get_real_pkg_gen($_) for ( + 'UEBERVERSAL', 'UNIVERSAL', 'DBICTest::AttrTest', @$expected_AttrTest_ISA, @@ -356,6 +360,13 @@ sub add_more_attrs { via_class => "DBICTest::AttrTest" } ], + ueber => [ + { + attributes => {}, + name => "ueber", + via_class => "UEBERVERSAL", + } + ], can => [ { attributes => {}, From 1c1795560d485d8c454e84b0a50f29957d113d66 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 14 Jun 2016 08:18:35 +0200 Subject: [PATCH 141/262] Account for 'poor man role application' method plumbing on 5.8 This also has the effect of greatly simplifying the OLD_MRO case --- lib/DBIx/Class/_Util.pm | 60 ++++++++++++--------------------- xt/extra/internals/attributes.t | 27 +++++++++++---- 2 files changed, 43 insertions(+), 44 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 1117d87bf..f1a36199a 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -71,34 +71,33 @@ BEGIN { ( $mro_recursor_stack->{cache} || {} )->{$_}{methlist} ||= do { my $class = $_; - no strict 'refs'; - my %methlist = + + # RV to be hashed up and turned into a number + join "\0", ( + $class, map - # this is essentially a uniq_by step - # it is crucial on OLD_MRO - {( Scalar::Util::refaddr($_) => $_ )} + {( + # stringification should be sufficient, ignore names/refaddr entirely + $_, + attributes::get( $_ ), + )} map - { + {( + # skip dummy C::C3 helper crefs + ! ( ( $Class::C3::MRO{$class} || {} )->{methods}{$_} ) + and ( ref(\ "${class}::"->{$_} ) ne 'GLOB' or defined( *{ "${class}::"->{$_} }{CODE} ) ) + ) ? ( \&{"${class}::$_"} ) : () } keys %{ "${class}::" } - ; - - # RV to be hashed up and turned into a number - join "\0", ( - $class, - map {( - $_, # refaddr is sufficient, ignore names entirely - attributes::get( $methlist{$_} ) - )} sort keys %methlist - ), + ); } } ( @@ -717,7 +716,7 @@ sub modver_gt_or_eq_and_lt ($$$) { # efficiently operate over the query_cache directly describe_class_methods($_) for reverse @full_ISA; - my ($methods_seen_via_ISA_on_old_mro, $current_node_refaddr); + my $current_node_refaddr; no strict 'refs'; # combine full ISA-order inherited and local method list into a @@ -756,33 +755,18 @@ sub modver_gt_or_eq_and_lt ($$$) { # our own non-cleaned subs + their attributes ( map { ( - # these 2 OR-ed checks are sufficient for 5.10+ + # need to account for dummy helper crefs under OLD_MRO ( - ref(\ "${class}::"->{$_} ) ne 'GLOB' + ! DBIx::Class::_ENV_::OLD_MRO or - defined( *{ "${class}::"->{$_} }{CODE} ) + ! ( ( $Class::C3::MRO{$class} || {} )->{methods}{$_} ) ) and - # need to account for dummy helper crefs under OLD_MRO + # these 2 OR-ed checks are sufficient for 5.10+ ( - ! DBIx::Class::_ENV_::OLD_MRO + ref(\ "${class}::"->{$_} ) ne 'GLOB' or - ( - $methods_seen_via_ISA_on_old_mro ||= do { - my $rv = {}; - $rv->{$_->{name}}->{ refaddr( \&{ "$_->{via_class}::$_->{name}"} ) } = 1 for - map { @$_ } map - { values %{ $describe_class_query_cache->{$_}{methods} } } - @full_ISA; - $rv; - } - and - ( - ! $methods_seen_via_ISA_on_old_mro->{$_} - or - ! $methods_seen_via_ISA_on_old_mro->{$_}{ refaddr( \&{"${class}::${_}"} ) } - ) - ) + defined( *{ "${class}::"->{$_} }{CODE} ) ) ) ? { via_class => $class, diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t index 0bd2e478a..4e36e72f5 100644 --- a/xt/extra/internals/attributes.t +++ b/xt/extra/internals/attributes.t @@ -1,7 +1,8 @@ BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } -use warnings; use strict; +use warnings; +no warnings 'once'; use Config; my $skip_threads; @@ -91,6 +92,9 @@ is_deeply @DBICTest::AttrTest::ISA = qw( DBICTest::SomeParentClass DBICTest::AnotherParentClass ); use mro 'c3'; + # pathological case - but can (and sadly does) happen + *VALID_DBIC_CODE_ATTRIBUTE = \&DBICTest::SomeGrandParentClass::VALID_DBIC_CODE_ATTRIBUTE; + ::grab_pkg_gen("DBICTest::AttrTest"); eval <<'EOS' or die $@; @@ -208,11 +212,15 @@ sub add_more_attrs { my $cnt; # check that class description is stable, and changes when needed + # + # FIXME - this list used to contain 'main', but that started failing as + # of the commit introducing this line with bizarre "unstable gen" errors + # Punting for the time being - will fix at some point in the future + # for my $class (qw( DBICTest::AttrTest DBICTest::AttrLegacy DBIx::Class - main )) { my $desc = describe_class_methods($class); @@ -223,7 +231,6 @@ sub add_more_attrs { ) for (1,2,3); my $desc2 = do { - no warnings 'once'; no strict 'refs'; $cnt++; @@ -323,7 +330,12 @@ sub add_more_attrs { via_class => "DBIx::Class::MethodAttributes" }, ], - VALID_DBIC_CODE_ATTRIBUTE => [ + VALID_DBIC_CODE_ATTRIBUTE => ( my $V_D_C_A_stack = [ + { + attributes => {}, + name => 'VALID_DBIC_CODE_ATTRIBUTE', + via_class => 'DBICTest::AttrTest' + }, { attributes => {}, name => "VALID_DBIC_CODE_ATTRIBUTE", @@ -339,7 +351,7 @@ sub add_more_attrs { name => "VALID_DBIC_CODE_ATTRIBUTE", via_class => "DBIx::Class::MethodAttributes" }, - ], + ]), _attr_cache => [ { attributes => {}, @@ -399,7 +411,10 @@ sub add_more_attrs { }; $expected_desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE} - = $expected_desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE}; + = $V_D_C_A_stack; + + $expected_desc->{methods_defined_in_class}{VALID_DBIC_CODE_ATTRIBUTE} + = $V_D_C_A_stack->[0]; $expected_desc->{methods_defined_in_class}{attr} = $expected_desc->{methods}{attr}[0]; From 1cf2ad8b03a2b1ad34183905475d1d9afd614aba Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 14 Jun 2016 10:35:50 +0200 Subject: [PATCH 142/262] Allow alternative mro-type specification on method listing This is needed for the mro sanity check further up --- lib/DBIx/Class/_Util.pm | 29 +++++++++++------ xt/extra/internals/attributes.t | 55 +++++++++++++++++++++++++++++++++ 2 files changed, 75 insertions(+), 9 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index f1a36199a..f4bda7346 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -653,11 +653,22 @@ sub modver_gt_or_eq_and_lt ($$$) { our $describe_class_query_cache; sub describe_class_methods { - my ($class) = @_; + my ($class, $requested_mro) = @_; croak "Expecting a class name" if not defined $class or $class !~ $module_name_rx; + $requested_mro ||= mro::get_mro($class); + + # mro::set_mro() does not bump pkg_gen - WHAT THE FUCK?! + my $query_cache_key = "$class|$requested_mro"; + + my $stack_cache_key = + ( mro::get_mro($class) eq $requested_mro ) + ? $class + : $query_cache_key + ; + # use a cache on old MRO, since while we are recursing in this function # nothing can possibly change (the speedup is immense) # (yes, people could be tie()ing the stash and adding methods on access @@ -674,9 +685,9 @@ sub modver_gt_or_eq_and_lt ($$$) { $my_gen += get_real_pkg_gen($_) for ( my @full_ISA = ( @{ - $mro_recursor_stack->{cache}{$class}{linear_isa} + $mro_recursor_stack->{cache}{$stack_cache_key}{linear_isa} ||= - mro::get_linear_isa($class) + mro::get_linear_isa($class, $requested_mro) }, (( @@ -691,7 +702,7 @@ sub modver_gt_or_eq_and_lt ($$$) { )); - my $slot = $describe_class_query_cache->{$class} ||= {}; + my $slot = $describe_class_query_cache->{$query_cache_key} ||= {}; unless ( ($slot->{cumulative_gen}||0) == $my_gen ) { @@ -702,15 +713,15 @@ sub modver_gt_or_eq_and_lt ($$$) { %$slot = ( class => $class, isa => [ - @{ $mro_recursor_stack->{cache}{$class}{linear_isa} } - [ 1 .. $#{$mro_recursor_stack->{cache}{$class}{linear_isa}} ] + @{ $mro_recursor_stack->{cache}{$stack_cache_key}{linear_isa} } + [ 1 .. $#{$mro_recursor_stack->{cache}{$stack_cache_key}{linear_isa}} ] ], mro => { - type => mro::get_mro($class), + type => $requested_mro, + is_c3 => ( ($requested_mro eq 'c3') ? 1 : 0 ), }, cumulative_gen => $my_gen, ); - $slot->{mro}{is_c3} = ($slot->{mro}{type} eq 'c3') ? 1 : 0; # ensure the cache is populated for the parents, code below can then # efficiently operate over the query_cache directly @@ -750,7 +761,7 @@ sub modver_gt_or_eq_and_lt ($$$) { # what describe_class_methods for @full_ISA produced above ( map { values %{ $describe_class_query_cache->{$_}{methods_defined_in_class} || {} - } } reverse @full_ISA ), + } } map { "$_|" . mro::get_mro($_) } reverse @full_ISA ), # our own non-cleaned subs + their attributes ( map { diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t index 4e36e72f5..1f9d7b58b 100644 --- a/xt/extra/internals/attributes.t +++ b/xt/extra/internals/attributes.t @@ -424,6 +424,61 @@ sub add_more_attrs { $expected_desc, 'describe_class_methods returns correct data', ); + + # ensure that asking with a different MRO will not perturb the cache + my $cached_desc = serialize( + $DBIx::Class::_Util::describe_class_query_cache->{"DBICTest::AttrTest|c3"} + ); + + # now try to ask for DFS explicitly, adjust our expectations + $expected_desc->{mro} = { type => 'dfs', is_c3 => 0 }; + + # due to DFS the last 2 entries of ISA and the VALID_DBIC_CODE_ATTRIBUTE + # sourcing-list will change places + splice @$_, -2, 2, @{$_}[-1, -2] + for $V_D_C_A_stack, $expected_AttrTest_ISA; + + is_deeply ( + # work around taint, see TODO below + { + %{describe_class_methods("DBICTest::AttrTest", "dfs")}, + cumulative_gen => $expected_desc->{cumulative_gen}, + }, + $expected_desc, + 'describing with explicit mro returns correct data' + ); + + # FIXME: TODO does not work on new T::B under threads sigh + # https://github.com/Test-More/test-more/issues/683 + unless( + ! DBIx::Class::_ENV_::OLD_MRO + and + ${^TAINT} + ) { + #local $TODO = "On 5.10+ -T combined with stash peeking invalidates the pkg_gen (wtf)" if ... + + ok( + ( + serialize( describe_class_methods("DBICTest::AttrTest") ) + eq + $cached_desc + ), + "Asking for alternative mro type did not invalidate cache" + ); + } + + # setting mro explicitly still matches what we expect + mro::set_mro("DBICTest::AttrTest", "dfs"); + + is_deeply ( + # in case set_mro starts increasing pkg_gen... + { + %{describe_class_methods("DBICTest::AttrTest")}, + cumulative_gen => $expected_desc->{cumulative_gen}, + }, + $expected_desc, + 'describing with implicit mro returns correct data' + ); } if ($skip_threads) { From 0c90b924a1f5b081a14a1d4f2fefaa48b9481a9f Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 14 Jun 2016 12:32:34 +0200 Subject: [PATCH 143/262] Remove preemptive DESTROY guard from 87f4bab0 / d63c9e64 It has been on CPAN sufficiently long, and would be needlesly pessimizing the upcoming sanity check framework. --- lib/DBIx/Class.pm | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index f76419d47..474d964ee 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -27,18 +27,6 @@ __PACKAGE__->mk_classaccessor( _skip_namespace_frames => '^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve|^Moose::Meta::' ); -# FIXME - this is not really necessary, and is in -# fact going to slow things down a bit -# However it is the right thing to do in order to get -# various install bases to highlight their brokenness -# Remove at some unknown point in the future -# -# The oddball BEGIN is there for... reason unknown -# It does make non-segfaulty difference on pre-5.8.5 perls, so shrug -BEGIN { - sub DESTROY { &DBIx::Class::_Util::detected_reinvoked_destructor }; -} - sub component_base_class { 'DBIx::Class' } # *DO NOT* change this URL nor the identically named =head1 below From bb768302f9abecbd4a32090ba38d5938a009bd7b Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 16 Jun 2016 17:01:02 +0200 Subject: [PATCH 144/262] Remove code forgotten in 085dbdd69 --- lib/DBIx/Class/_Util.pm | 5 ----- 1 file changed, 5 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index f4bda7346..f6e04fe05 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -727,17 +727,12 @@ sub modver_gt_or_eq_and_lt ($$$) { # efficiently operate over the query_cache directly describe_class_methods($_) for reverse @full_ISA; - my $current_node_refaddr; no strict 'refs'; # combine full ISA-order inherited and local method list into a # "shadowing stack" ( - $current_node_refaddr = refaddr($_) - - and - unshift @{ $slot->{methods}{$_->{name}} }, $_ and From 7bba735de0eb5d431bb3b36e6aec4b19370f9158 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 17 Jun 2016 00:21:23 +0200 Subject: [PATCH 145/262] Remove useless eval in the leaktracer on 5.8.3+ As a bonus fix a subtle bug where the very first ref encountered was never traced, as the postincrement caused its slot to be deleted - ARGH! --- lib/DBIx/Class/_Util.pm | 3 +++ t/lib/DBICTest/Util/LeakTracer.pm | 17 +++++++++++------ 2 files changed, 14 insertions(+), 6 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index f6e04fe05..d0771248c 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -23,6 +23,9 @@ BEGIN { BROKEN_GOTO => ( "$]" < 5.008003 ) ? 1 : 0, + # perl -MScalar::Util=weaken -e 'weaken( $hash{key} = \"value" )' + BROKEN_WEAK_SCALARREF_VALUES => ( "$]" < 5.008003 ) ? 1 : 0, + HAS_ITHREADS => $Config{useithreads} ? 1 : 0, UNSTABLE_DOLLARAT => ( "$]" < 5.013002 ) ? 1 : 0, diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index 6f1bcb662..8002e6989 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -48,18 +48,23 @@ sub populate_weakregistry { for keys %$reg; } + return $target if ( + DBIx::Class::_ENV_::BROKEN_WEAK_SCALARREF_VALUES + and + ref $target eq 'SCALAR' + ); + if (! defined $weak_registry->{$refaddr}{weakref}) { + + # replace slot entirely $weak_registry->{$refaddr} = { stacktrace => stacktrace(1), weakref => $target, }; - # on perl < 5.8.3 sometimes a weaken can throw (can't find RT) - # so guard against that unlikely event - local $SIG{__DIE__} if $SIG{__DIE__}; - local $@; - eval { weaken( $weak_registry->{$refaddr}{weakref} ); $refs_traced++ } - or delete $weak_registry->{$refaddr}; + weaken( $weak_registry->{$refaddr}{weakref} ); + + $refs_traced++; } my $desc = refdesc $target; From dc71574729e5f45defc433ca2e11b7c2377eaf95 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 16 Jun 2016 17:40:44 +0200 Subject: [PATCH 146/262] Change the leaktracer to no longer rely on %Sub::Quote::QUOTED Frees up @haarg to do as he sees fit in the future --- lib/DBIx/Class/_Util.pm | 17 +++++++++++++++++ t/lib/DBICTest/Util/LeakTracer.pm | 4 ++-- 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index d0771248c..d7b1ce24d 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -185,6 +185,7 @@ BEGIN { Sub::Quote->VERSION(2.002); } # Override forcing no_defer, and adding naming consistency checks +our %refs_closed_over_by_quote_sub_installed_crefs; sub quote_sub { Carp::confess( "Anonymous quoting not supported by the DBIC sub_quote override - supply a sub name" ) if @_ < 2 @@ -217,6 +218,22 @@ sub quote_sub { no_defer => 1, }; + weaken ( + # just use a growing counter, no need to perform neither compaction + # nor any special ithread-level handling + $refs_closed_over_by_quote_sub_installed_crefs + { scalar keys %refs_closed_over_by_quote_sub_installed_crefs } + = $_ + ) for grep { + length ref $_ + and + ( + ! DBIx::Class::_ENV_::BROKEN_WEAK_SCALARREF_VALUES + or + ref $_ ne 'SCALAR' + ) + } values %{ $_[2] || {} }; + my $cref = Sub::Quote::quote_sub( $_[0], $_[1], $_[2]||{}, $sq_opts ); # FIXME FIXME FIXME diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index 8002e6989..b36843edd 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -250,13 +250,13 @@ sub assert_empty_weakregistry { # the symtable walk is very expensive # if we are $quiet (running in an END block) we do not really need to be - # that thorough - can get by with only %Sub::Quote::QUOTED + # that thorough - can get by with our own registry delete $weak_registry->{$_} for $quiet ? do { my $refs = {}; visit_refs ( # only look at the closed over stuffs - refs => [ grep { length ref $_ } map { values %{$_->[2]} } grep { ref $_ eq 'ARRAY' } values %Sub::Quote::QUOTED ], + refs => [ values %DBIx::Class::_Util::refs_closed_over_by_quote_sub_installed_crefs ], seen_refs => $refs, action => sub { 1 }, ); From 9642350a5e5cf25c6b185ad6782e6a2341bb1968 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 15 Jun 2016 12:31:53 +0200 Subject: [PATCH 147/262] Simplify our quote_sub override: Sub::Quote now has native attr support --- Makefile.PL | 2 +- lib/DBIx/Class/_Util.pm | 52 ++++++++++++++--------------------------- 2 files changed, 19 insertions(+), 35 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index ce145a702..b17c29ff7 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -86,7 +86,7 @@ my $runtime_requires = { 'Data::Page' => '2.00', 'Devel::GlobalDestruction' => '0.09', 'Hash::Merge' => '0.12', - 'Moo' => '2.000', + 'Moo' => '2.002', 'MRO::Compat' => '0.12', 'Module::Find' => '0.07', 'namespace::clean' => '0.24', diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index d7b1ce24d..dfa20c491 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -178,16 +178,10 @@ our @EXPORT_OK = qw( use constant UNRESOLVABLE_CONDITION => \ '1 = 0'; -BEGIN { - # add preliminary attribute support - # FIXME FIXME FIXME - # To be revisited when Moo with proper attr support ships - Sub::Quote->VERSION(2.002); -} # Override forcing no_defer, and adding naming consistency checks our %refs_closed_over_by_quote_sub_installed_crefs; sub quote_sub { - Carp::confess( "Anonymous quoting not supported by the DBIC sub_quote override - supply a sub name" ) if + Carp::confess( "Anonymous quoting not supported by the DBIC quote_sub override - supply a sub name" ) if @_ < 2 or ! defined $_[1] @@ -195,16 +189,27 @@ sub quote_sub { length ref $_[1] ; - Carp::confess( "The DBIC sub_quote override expects sub name '$_[0]' to be fully qualified" ) - unless $_[0] =~ /::/; + Carp::confess( "The DBIC quote_sub override expects sub name '$_[0]' to be fully qualified" ) + unless (my $stash) = $_[0] =~ /^(.+)::/; + + Carp::confess( + "The DBIC sub_quote override does not support 'no_install'" + ) if ( + $_[3] + and + $_[3]->{no_install} + ); - Carp::confess( "The DBIC sub_quote override expects the sub name '$_[0]' to match the supplied 'package' argument" ) if + Carp::confess( + 'The DBIC quote_sub override expects the namespace-part of sub name ' + . "'$_[0]' to match the supplied package argument '$_[3]->{package}'" + ) if ( $_[3] and defined $_[3]->{package} and - index( $_[0], $_[3]->{package} ) != 0 - ; + $stash ne $_[3]->{package} + ); my @caller = caller(0); my $sq_opts = { @@ -234,28 +239,7 @@ sub quote_sub { ) } values %{ $_[2] || {} }; - my $cref = Sub::Quote::quote_sub( $_[0], $_[1], $_[2]||{}, $sq_opts ); - - # FIXME FIXME FIXME - # To be revisited when Moo with proper attr support ships - if( - # external application does not work on things like :prototype(...), :lvalue, etc - my @attrs = grep { - $_ !~ /^[a-z]/ - or - Carp::confess( "The DBIC sub_quote override does not support applying of reserved attribute '$_'" ) - } @{ $sq_opts->{attributes} || []} - ) { - Carp::confess( "The DBIC sub_quote override does not allow mixing 'attributes' with 'no_install'" ) - if $sq_opts->{no_install}; - - # might be different from $sq_opts->{package}; - my ($install_into) = $_[0] =~ /(.+)::[^:]+$/; - - attributes->import( $install_into, $cref, @attrs ); - } - - $cref; + Sub::Quote::quote_sub( $_[0], $_[1], $_[2]||{}, $sq_opts ); } sub sigwarn_silencer ($) { From e400c82dcda5d575e6d745f23a1be5e8d1c2af14 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 17 Jun 2016 16:06:55 +0200 Subject: [PATCH 148/262] Remove changelog entries included in 0.082830 --- Changes | 29 ----------------------------- 1 file changed, 29 deletions(-) diff --git a/Changes b/Changes index fb7673d8e..c1faad945 100644 --- a/Changes +++ b/Changes @@ -20,8 +20,6 @@ Revision history for DBIx::Class an underlying search_rs(), as by design these arguments would be used only on the first call to ->related_resultset(), and ignored afterwards. Instead an exception (detailing the fix) is thrown. - - Another relatively invasive set of ::FilterColumn changes, covering - potential data loss (RT#111567). Please run your regression tests! - Increased checking for the correctness of the is_nullable attribute within the prefetch result parser may highlight previously unknown mismatches between your codebase and data source @@ -31,9 +29,6 @@ Revision history for DBIx::Class instead of silently discarding the argument * New Features - - When using non-scalars (e.g. arrays) as literal bind values it is no - longer necessary to explicitly specify a bindtype (this turned out - to be a mostly useless overprotection) - InflateColumn::DateTime now accepts the ecosystem-standard option 'time_zone', in addition to the DBIC-only 'timezone' (GH#28) - DBIx::Class::Optional::Dependencies now properly understands @@ -42,48 +37,24 @@ Revision history for DBIx::Class specific DateTime::Format dependencies * Fixes - - Ensure failing on_connect* / on_disconnect* are dealt with properly, - notably on_connect* failures now properly abort the entire connect - Fix incorrect SQL generated with invalid {rows} on complex resultset operations, generally more robust handling of rows/offset attrs - Fix incorrect $storage state on unexpected RDBMS disconnects and other failure events, preventing clean reconnection (RT#110429) - - Ensure leaving an exception stack via Return::MultiLevel or something - similar produces a large warning - Make sure exception objects stringifying to '' are properly handled and warned about (GH#15) - - Fix silencing of exceptions thrown by custom inflate_result() methods - - Fix complex prefetch when ordering over foreign boolean columns - ( Pg can't MAX(boolcol) despite being able to ORDER BY boolcol ) - Fix incorrect data returned in a corner case of partial-select HRI invocation (no known manifestations of this bug in the field, see commit message for description of exact failure scenario) - Fix corner case of stringify-only overloaded objects being used in create()/populate() - - Remove spurious exception warping in ::Replicated::execute_reliably - (RT#113339) - - Fix infinite loop on ->svp_release("nonexistent_savepoint") (GH#97) - - Fix spurious ROLLBACK statements when a TxnScopeGuard fails a commit - of a transaction with deferred FK checks: a guard is now inactivated - immediately before the commit is attempted (RT#107159) - - Fix use of ::Schema::Versioned combined with a user-supplied - $dbh->{HandleError} (GH#101) - - Fix spurious warning on MSSQL cursor invalidation retries (RT#102166) - - Fix parsing of DSNs containing driver arguments (GH#99) - - Work around unreliable $sth->finish() on INSERT ... RETURNING within - DBD::Firebird on some compiler/driver combinations (RT#110979) - - Really fix savepoint rollbacks on older DBD::SQLite (fix in 0.082800 - was not sufficient to cover up RT#67843) - Fix several corner cases with Many2Many over custom relationships - - Fix the Sybase ASE storage incorrectly attempting to retrieve an - autoinc value when inserting rows containing blobs (GH#82) * Misc - Add explicit test for pathological example of asymmetric IC::DT setup working with copy() in t/icdt/engine_specific/sybase.t (GH#84) - Fix t/54taint.t failing on local::lib's with upgraded Carp on 5.8.* - Fix invalid variable names in ResultSource::View examples - - Typo fixes from downstream debian packagers (RT#112007) - Skip tests in a way more intelligent and speedy manner when optional dependencies are missing - Make the Optional::Dependencies error messages cpanm-friendly From df9da3541a831d9333c9eccb058e40e905a4b3c6 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 4 Nov 2015 04:18:01 +0100 Subject: [PATCH 149/262] Add changelog entry on 90c9dd1d, 757891ed and 89203568 Sample (not ideal - could be *SO* much better ) timings from included bencher: Before (0.0828xx): 62951 byte-long query generated (via as_query()) in: 4.975237 seconds (take 1) 62951 byte-long query generated (via as_query()) in: 4.995723 seconds (take 2) 62951 byte-long query generated (via as_query()) in: 4.964793 seconds (take 3) 62951 byte-long query generated (via as_query()) in: 4.96168 seconds (take 4) 62951 byte-long query generated (via as_query()) in: 4.991396 seconds (take 5) 62951 byte-long query generated (via as_query()) in: 4.988478 seconds (take 6) 62951 byte-long query generated (via as_query()) in: 4.977612 seconds (take 7) 62951 byte-long query generated (via as_query()) in: 4.98648 seconds (take 8) 62951 byte-long query generated (via as_query()) in: 4.999984 seconds (take 9) After: 62951 byte-long query generated (via as_query()) in: 0.429634 seconds (take 1) 62951 byte-long query generated (via as_query()) in: 0.416169 seconds (take 2) 62951 byte-long query generated (via as_query()) in: 0.430782 seconds (take 3) 62951 byte-long query generated (via as_query()) in: 0.416879 seconds (take 4) 62951 byte-long query generated (via as_query()) in: 0.426492 seconds (take 5) 62951 byte-long query generated (via as_query()) in: 0.428975 seconds (take 6) 62951 byte-long query generated (via as_query()) in: 0.413018 seconds (take 7) 62951 byte-long query generated (via as_query()) in: 0.428731 seconds (take 8) 62951 byte-long query generated (via as_query()) in: 0.413206 seconds (take 9) --- Changes | 2 + .../Benchmarks/benchmark_join_optimizer.pl | 48 +++++++++++++++++++ 2 files changed, 50 insertions(+) create mode 100755 examples/Benchmarks/benchmark_join_optimizer.pl diff --git a/Changes b/Changes index c1faad945..5eecbe865 100644 --- a/Changes +++ b/Changes @@ -31,6 +31,8 @@ Revision history for DBIx::Class * New Features - InflateColumn::DateTime now accepts the ecosystem-standard option 'time_zone', in addition to the DBIC-only 'timezone' (GH#28) + - Massively optimised literal SQL snippet scanner - fixes all known + slowdowns ( in some cases 50x ) of very complex prefetch/selects - DBIx::Class::Optional::Dependencies now properly understands combinations of requirements and does the right thing with e.g. ->req_list_for([qw( rdbms_oracle ic_dt )]) bringing in the Oracle diff --git a/examples/Benchmarks/benchmark_join_optimizer.pl b/examples/Benchmarks/benchmark_join_optimizer.pl new file mode 100755 index 000000000..68b4a5065 --- /dev/null +++ b/examples/Benchmarks/benchmark_join_optimizer.pl @@ -0,0 +1,48 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use Time::HiRes qw(gettimeofday tv_interval); +use Digest::SHA 'sha1_hex'; + +use lib 't/lib'; +BEGIN { $ENV{DBICTEST_ANFANG_DEFANG} = 1 }; +use DBICTest; + +my $schema = DBICTest->init_schema( + quote_names => 1, + cursor_class => 'DBIx::Class::Cursor::Cached' +); + +use Cache::FileCache; +my $c = Cache::FileCache->new({ namespace => 'SchemaClass' }); + +for my $i (1..9) { + + my $t0 = [gettimeofday]; + + # getting a fresh rs makes sure we do not cache anything + my $rs = $schema->resultset("Artist")->search({},{ + cache_object => $c, + cache_for => 999999999999, + prefetch => { + cds => [ + ( { tracks => { cd_single => { artist => { cds => { tracks => 'cd_single' } } } } } ) x 50, + ], + }, + rows => 2, + }); + + my $q = ${$rs->as_query}->[0]; + + print STDERR "@{[ length $q]} byte-long query generated (via as_query() in: ".tv_interval($t0) . " seconds (take $i)\n"; + + # stuff below can be made even faster, but another time + next; + + $t0 = [ gettimeofday ]; + + my $x = $rs->all_hri; + print STDERR "Got collapsed results (via HRI) in: ".tv_interval($t0) . " seconds (take $i)\n"; +} From f0c2d11fdca96cbd78a572dba40d33a229ee0b9e Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 18 Jun 2016 11:51:10 +0200 Subject: [PATCH 150/262] Slight POD correction --- lib/DBIx/Class/Storage/DBI/SQLite.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/DBIx/Class/Storage/DBI/SQLite.pm b/lib/DBIx/Class/Storage/DBI/SQLite.pm index dcebce754..28cadaac3 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLite.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLite.pm @@ -63,7 +63,7 @@ Even if you upgrade DBIx::Class (which works around the bug starting from version 0.08210) you may still have corrupted/incorrect data in your database. DBIx::Class warned about this condition for several years, hoping to give anyone affected sufficient notice of the potential issues. The warning was -removed in version 0.082900. +removed in 2015/v0.082820. =back From 02154caf0cf887228849fd0d88e0d6636ef21f8c Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 19 Jun 2016 07:48:27 +0200 Subject: [PATCH 151/262] Ensure describe_environment does not break its output in half --- t/00describe_environment.t | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/t/00describe_environment.t b/t/00describe_environment.t index 9a973dec0..ed0378bb8 100644 --- a/t/00describe_environment.t +++ b/t/00describe_environment.t @@ -501,6 +501,11 @@ $final_out .= "=============================\n$discl\n\n"; diag $final_out; +# *very* large printouts may not finish flushing before the test exits +# injecting a ... ok in the middle of the diag +# http://www.cpantesters.org/cpan/report/fbdac74c-35ca-11e6-ab41-c893a58a4b8c +select( undef, undef, undef, 0.2 ); + exit 0; From 304409e12f0c26662204e662f69a67f04283840b Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 20 Jun 2016 09:21:50 +0200 Subject: [PATCH 152/262] Proper changelog after I bothced it in e400c82d --- Changes | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/Changes b/Changes index 5eecbe865..c73756951 100644 --- a/Changes +++ b/Changes @@ -50,6 +50,7 @@ Revision history for DBIx::Class commit message for description of exact failure scenario) - Fix corner case of stringify-only overloaded objects being used in create()/populate() + - Fix spurious warning on MSSQL cursor invalidation retries (RT#102166) - Fix several corner cases with Many2Many over custom relationships * Misc @@ -67,6 +68,44 @@ Revision history for DBIx::Class - Config::Any is no longer a core dep, but instead is migrated to a new optdep group 'config_file_reader' +0.082840 2016-06-20 07:02 (UTC) + * New Features + - When using non-scalars (e.g. arrays) as literal bind values it is no + longer necessary to explicitly specify a bindtype (this turned out + to be a mostly useless overprotection) + + * Fixes + - Ensure leaving an exception stack via Return::MultiLevel or something + similar produces a large warning + - Another relatively invasive set of ::FilterColumn changes, covering + potential data loss (RT#111567). Please run your regression tests! + - Ensure failing on_connect* / on_disconnect* are dealt with properly, + notably on_connect* failures now properly abort the entire connect + - Fix use of ::Schema::Versioned combined with a user-supplied + $dbh->{HandleError} (GH#101) + - Fix parsing of DSNs containing driver arguments (GH#99) + - Fix silencing of exceptions thrown by custom inflate_result() methods + - Fix complex prefetch when ordering over foreign boolean columns + ( Pg can't MAX(boolcol) despite being able to ORDER BY boolcol ) + - Fix infinite loop on ->svp_release("nonexistent_savepoint") (GH#97) + - Fix spurious ROLLBACK statements when a TxnScopeGuard fails a commit + of a transaction with deferred FK checks: a guard is now inactivated + immediately before the commit is attempted (RT#107159) + - Fix the Sybase ASE storage incorrectly attempting to retrieve an + autoinc value when inserting rows containing blobs (GH#82) + - Remove spurious exception warping in ::Replicated::execute_reliably + (RT#113339) + - Work around unreliable $sth->finish() on INSERT ... RETURNING within + DBD::Firebird on some compiler/driver combinations (RT#110979) + - Fix leaktest failures with upcoming version of Sub::Quote + - Really fix savepoint rollbacks on older DBD::SQLite (fix in 0.082800 + was not sufficient to cover up RT#67843) + + * Misc + - Test suite is now officially certified to work under very high random + parallelism: META x_parallel_test_certified set to true accordingly + - Typo fixes from downstream debian packagers (RT#112007) + 0.082821 2016-02-11 17:58 (UTC) * Fixes - Fix t/52leaks.t failures on compilerless systems (RT#104429) From 591df363660658ed30e60438c5251ca480925a6f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= Date: Sat, 18 Jun 2016 12:37:10 +0100 Subject: [PATCH 153/262] Restore 'timezone' field in column info ( extends eef9b484 ) The keys in the column info hash are semi-public API, and 'timezone' in particular is used by DBIx::Class::InflateColumn::DateTime::WithTimeZone. Keep documenting time_zone as the main name, but note that it's stored under both keys. --- lib/DBIx/Class/InflateColumn/DateTime.pm | 16 ++++++++++++---- t/icdt/offline_pg.t | 7 +++++++ 2 files changed, 19 insertions(+), 4 deletions(-) diff --git a/lib/DBIx/Class/InflateColumn/DateTime.pm b/lib/DBIx/Class/InflateColumn/DateTime.pm index 4f08c1f14..b284a640a 100644 --- a/lib/DBIx/Class/InflateColumn/DateTime.pm +++ b/lib/DBIx/Class/InflateColumn/DateTime.pm @@ -39,7 +39,10 @@ If you want to set a specific time zone and locale for that field, use: Note: DBIC before 0.082900 only accepted C, and silently discarded any C arguments. For backwards compatibility, C will -continue being accepted as a synonym for C. +continue being accepted as a synonym for C, and the value will +continue to be available in the +L<< C hash|DBIx::Class::ResultSource/column_info >> +under both names. If you want to inflate no matter what data_type your column is, use inflate_datetime or inflate_date: @@ -165,10 +168,15 @@ sub register_column { } } + # Store the time zone under both 'timezone' for backwards compatibility and + # 'time_zone' for DateTime ecosystem consistency if ( defined $info->{timezone} ) { - $self->throw_exception("Cannot specify both 'timezone' and 'time_zone' in '$column' column defintion.") - if defined $info->{time_zone}; - $info->{time_zone} = delete $info->{timezone}; + $self->throw_exception("Conflicting 'timezone' and 'time_zone' values in '$column' column defintion.") + if defined $info->{time_zone} and $info->{time_zone} ne $info->{timezone}; + $info->{time_zone} = $info->{timezone}; + } + elsif ( defined $info->{time_zone} ) { + $info->{timezone} = $info->{time_zone}; } # shallow copy to avoid unfounded(?) Devel::Cycle complaints diff --git a/t/icdt/offline_pg.t b/t/icdt/offline_pg.t index 1a04fce6d..bfd931ce6 100644 --- a/t/icdt/offline_pg.t +++ b/t/icdt/offline_pg.t @@ -23,6 +23,13 @@ DBICTest::Schema->load_classes('EventTZPg'); my $parser = $s->storage->datetime_parser; is( $parser, 'DateTime::Format::Pg', 'datetime_parser is as expected'); + my $colinfo = $s->source('EventTZPg')->column_info('created_on'); + is ( + $colinfo->{timezone}, + $colinfo->{time_zone}, + 'Legacy timezone key is still present in colinfo', + ); + ok (!$s->storage->_dbh, 'still not connected'); } From 8f163090e4e2002e1fbf48db0bb1e3745e0d70d4 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 20 Jun 2016 19:00:09 +0200 Subject: [PATCH 154/262] Minor improvements to the maint helper scripts --- maint/poisonsmoke.bash | 12 +++++++++--- maint/travis_buildlog_downloader | 12 ++++++------ 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/maint/poisonsmoke.bash b/maint/poisonsmoke.bash index c3c637ce8..d8b984c37 100755 --- a/maint/poisonsmoke.bash +++ b/maint/poisonsmoke.bash @@ -24,11 +24,17 @@ for var in "${toggle_booleans[@]}" do if [[ -z "${!var}" ]] ; then export $var=1 - echo "POISON_ENV: setting $var to 1" + echo -n "$var " fi done +echo -e "\n\n^^ variables above **automatically** set to '1'" provecmd="nice prove -QlrswTj10" -echo -e "\nExecuting \`$provecmd\` via $(which perl)\n" -$provecmd +echo -e " +Executing \`$provecmd $@\` via $(which perl) within the following environment: + +$(env | grep -P 'TEST|HARNESS|MAKE|TRAVIS|PERL|DBIC|PATH|SHELL' | LC_ALL=C sort | cat -v) +" + +$provecmd "$@" diff --git a/maint/travis_buildlog_downloader b/maint/travis_buildlog_downloader index b67ed151f..3287d3591 100755 --- a/maint/travis_buildlog_downloader +++ b/maint/travis_buildlog_downloader @@ -19,19 +19,19 @@ my $resp = ( my $ua = HTTP::Tiny->new )->get( $base_url ); die "Unable to retrieve $resp->{url}: $resp->{status}\n$resp->{content}\n\n" unless $resp->{success}; -my @job_ids = ( map - { ($_->{id}||'') =~ /^([0-9]+)$/ } +my @jobs = ( map + { ( ($_->{id}||'') =~ /^([0-9]+)$/ ) ? [ $1 => $_->{number} ] : () } @{( eval { decode_json( $resp->{content} )->{matrix} } || [] )} -) or die "Unable to find any job ids:\n$resp->{content}\n\n"; +) or die "Unable to find any jobs:\n$resp->{content}\n\n"; my $dir = "TravisCI_build_$build_id"; mkdir $dir unless -d $dir; -for my $job_id (@job_ids) { - my $log_url = "http://api.travis-ci.org/jobs/$job_id/log.txt"; - my $dest_fn = "$dir/job_$job_id.log"; +for my $job (@jobs) { + my $log_url = "http://api.travis-ci.org/jobs/$job->[0]/log.txt"; + my $dest_fn = "$dir/job_$job->[1].$job->[0].log"; print "Retrieving $log_url into $dest_fn\n"; From 3605497bcb83ef83a4859a84e52c03f77f3cd626 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 20 Jun 2016 22:58:32 +0200 Subject: [PATCH 155/262] Add 'PERL_VERSION' foldable constant, switch lib-ish things over No point changing the many $] references in .t's themselves --- lib/DBIx/Class/ResultSource/RowParser/Util.pm | 2 +- lib/DBIx/Class/_Util.pm | 21 ++++++++++-------- t/lib/DBICTest/Util.pm | 22 +++++++++++-------- 3 files changed, 26 insertions(+), 19 deletions(-) diff --git a/lib/DBIx/Class/ResultSource/RowParser/Util.pm b/lib/DBIx/Class/ResultSource/RowParser/Util.pm index 68f7e6b3d..a64df955d 100644 --- a/lib/DBIx/Class/ResultSource/RowParser/Util.pm +++ b/lib/DBIx/Class/ResultSource/RowParser/Util.pm @@ -6,7 +6,7 @@ use warnings; use DBIx::Class::_Util qw( perlstring dump_value ); -use constant HAS_DOR => ( "$]" < 5.010 ? 0 : 1 ); +use constant HAS_DOR => ( ( DBIx::Class::_ENV_::PERL_VERSION < 5.010 ) ? 0 : 1 ); use base 'Exporter'; our @EXPORT_OK = qw( diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index dfa20c491..76f9b3589 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -6,8 +6,6 @@ use DBIx::Class::StartupCheck; # load es early as we can, usually a noop use warnings; use strict; -use constant SPURIOUS_VERSION_CHECK_WARNINGS => ( "$]" < 5.010 ? 1 : 0); - my $mro_recursor_stack; BEGIN { @@ -16,19 +14,24 @@ BEGIN { use Config; + use constant { + PERL_VERSION => "$]", + OS_NAME => "$^O", + }; + use constant { # but of course - BROKEN_FORK => ($^O eq 'MSWin32') ? 1 : 0, + BROKEN_FORK => (OS_NAME eq 'MSWin32') ? 1 : 0, - BROKEN_GOTO => ( "$]" < 5.008003 ) ? 1 : 0, + BROKEN_GOTO => ( PERL_VERSION < 5.008003 ) ? 1 : 0, # perl -MScalar::Util=weaken -e 'weaken( $hash{key} = \"value" )' - BROKEN_WEAK_SCALARREF_VALUES => ( "$]" < 5.008003 ) ? 1 : 0, + BROKEN_WEAK_SCALARREF_VALUES => ( PERL_VERSION < 5.008003 ) ? 1 : 0, HAS_ITHREADS => $Config{useithreads} ? 1 : 0, - UNSTABLE_DOLLARAT => ( "$]" < 5.013002 ) ? 1 : 0, + UNSTABLE_DOLLARAT => ( PERL_VERSION < 5.013002 ) ? 1 : 0, ( map # @@ -47,11 +50,9 @@ BEGIN { ), IV_SIZE => $Config{ivsize}, - - OS_NAME => $^O, }; - if ( "$]" < 5.009_005) { + if ( PERL_VERSION < 5.009_005) { require MRO::Compat; constant->import( OLD_MRO => 1 ); @@ -149,6 +150,8 @@ BEGIN { sub PEEPEENESS () { &$sigh } } +use constant SPURIOUS_VERSION_CHECK_WARNINGS => ( DBIx::Class::_ENV_::PERL_VERSION < 5.010 ? 1 : 0); + # FIXME - this is not supposed to be here # Carp::Skip to the rescue soon use DBIx::Class::Carp '^DBIx::Class|^DBICTest'; diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 46b8c2f4a..dc3440600 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -5,7 +5,11 @@ use strict; use ANFANG; -use DBICTest::RunMode; +use Config; +use Carp qw(cluck confess croak); +use Fcntl qw( :DEFAULT :flock ); +use Scalar::Util qw( blessed refaddr openhandle ); +use DBIx::Class::_Util qw( scope_guard parent_dir ); use constant { @@ -19,20 +23,20 @@ use constant { # add an escape for these perls ON SMOKERS - a user/CI will still get death # constname a homage to http://theoatmeal.com/comics/working_home PEEPEENESS => ( + ( + DBIx::Class::_ENV_::PERL_VERSION >= 5.013005 + and + DBIx::Class::_ENV_::PERL_VERSION <= 5.013006 + ) + and + require DBICTest::RunMode + and DBICTest::RunMode->is_smoker and ! DBICTest::RunMode->is_ci - and - ( "$]" >= 5.013005 and "$]" <= 5.013006) ), }; -use Config; -use Carp qw(cluck confess croak); -use Fcntl qw( :DEFAULT :flock ); -use Scalar::Util qw( blessed refaddr openhandle ); -use DBIx::Class::_Util qw( scope_guard parent_dir ); - use base 'Exporter'; our @EXPORT_OK = qw( dbg stacktrace class_seems_loaded From 44c1a75dd318ee6d943c91939c1b595ecc1d625b Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 21 Jun 2016 14:46:25 +0200 Subject: [PATCH 156/262] Fix false-positives in the no-external-evals assert ( ddcc02d14 ) If there is no eval frame above the exception action - there is nothing to report to the user --- t/lib/DBICTest/BaseSchema.pm | 32 +++++++++++++++++++++++++++++--- 1 file changed, 29 insertions(+), 3 deletions(-) diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index 4fa2f208a..726ce10f2 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -15,11 +15,26 @@ use namespace::clean; if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { my $ea = __PACKAGE__->exception_action( sub { - my ( $fr_num, $disarmed, $throw_exception_fr_num ); + # Can not rely on $^S here at all - the exception_action + # itself is always called in an eval so that the goto-guard + # can work (see 7cb35852) + + my ( $fr_num, $disarmed, $throw_exception_fr_num, $eval_fr_num ); while( ! $disarmed and my @fr = caller(++$fr_num) ) { $throw_exception_fr_num ||= ( - $fr[3] eq 'DBIx::Class::ResultSource::throw_exception' + $fr[3] =~ /^DBIx::Class::(?:ResultSource|Schema|Storage|Exception)::throw(?:_exception)?$/ + and + # there may be evals in the throwers themselves - skip those + ( $eval_fr_num ) = ( undef ) + and + $fr_num + ); + + # now that the above stops un-setting us, we can find the first + # ineresting eval + $eval_fr_num ||= ( + $fr[3] eq '(eval)' and $fr_num ); @@ -52,7 +67,15 @@ if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { '', ' You almost certainly used eval/try instead of dbic_internal_try()', " Adjust *one* of the eval-ish constructs in the callstack starting" . DBICTest::Util::stacktrace($throw_exception_fr_num||()) - ) unless $disarmed; + ) if ( + ! $disarmed + and + ( + $eval_fr_num + or + ! $throw_exception_fr_num + ) + ); DBIx::Class::Exception->throw( $_[0] ); }); @@ -65,6 +88,9 @@ if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { # without this there would be false positives everywhere :( die @_ if ( + # blindly rethrow if nobody is waiting for us + ( defined $^S and ! $^S ) + or (caller(0))[0] !~ $interesting_ns_rx or ( From ba35e8ece022fd1277c2c508ace28d5908f74d9c Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 21 Jun 2016 11:07:45 +0200 Subject: [PATCH 157/262] Minor cosmetic fix of describe_environment --- t/00describe_environment.t | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/t/00describe_environment.t b/t/00describe_environment.t index ed0378bb8..04d7136a5 100644 --- a/t/00describe_environment.t +++ b/t/00describe_environment.t @@ -413,9 +413,10 @@ my $max_ver_len = max map ; my $max_marker_len = max map { length $_ } ( '$INC[999]', keys %$seen_markers ); +# Note - must be less than 76 chars wide to account for the diag() prefix my $discl = <<'EOD'; -List of loadable modules within both the core and *OPTIONAL* dependency chains +List of loadable modules within both *OPTIONAL* and core dependency chains present on this system (modules sourced from ./blib, ./lib, ./t, and ./xt with versions identical to their parent namespace were omitted for brevity) From 2c038b0a90ff69084cbdac688105eaa68036d18d Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 21 Jun 2016 08:41:10 +0200 Subject: [PATCH 158/262] Fix describe_env failure on nonexistent @INC on Win32 Despite this code undergoing wide CPAN testing last year, and having zero functional changes since, there were *still* bugs lurking inside :/ --- t/00describe_environment.t | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/t/00describe_environment.t b/t/00describe_environment.t index 04d7136a5..0beb5b0f1 100644 --- a/t/00describe_environment.t +++ b/t/00describe_environment.t @@ -530,12 +530,18 @@ sub abs_unix_path { # File::Spec's rel2abs does not resolve symlinks # we *need* to look at the filesystem to be sure - my $abs_fn = abs_path($_[0]); + # + # But looking at the FS for non-existing basenames *may* + # throw on some OSes so be extra paranoid: + # http://www.cpantesters.org/cpan/report/26a6e42f-6c23-1014-b7dd-5cd275d8a230 + # + my $abs_fn = eval { abs_path($_[0]) } || ''; - if ( $^O eq 'MSWin32' and $abs_fn ) { + if ( $abs_fn and $^O eq 'MSWin32' ) { # sometimes we can get a short/longname mix, normalize everything to longnames - $abs_fn = Win32::GetLongPathName($abs_fn); + $abs_fn = Win32::GetLongPathName($abs_fn) + if -e $abs_fn; # Fixup (native) slashes in Config not matching (unixy) slashes in INC $abs_fn =~ s|\\|/|g; @@ -549,7 +555,7 @@ sub shorten_fn { my $abs_fn = abs_unix_path($fn); - if (my $p = subpath_of_known_path( $fn ) ) { + if ($abs_fn and my $p = subpath_of_known_path( $fn ) ) { $abs_fn =~ s| (? Date: Tue, 21 Jun 2016 16:24:29 +0200 Subject: [PATCH 159/262] Bring out the big-paranoia-harness - make describe_env infallible As desmonstrated by the previous commit: testing is no substitute for proper defensive programs. Stop-gap until this is spun off on its own --- t/00describe_environment.t | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/t/00describe_environment.t b/t/00describe_environment.t index 0beb5b0f1..87b4697b8 100644 --- a/t/00describe_environment.t +++ b/t/00describe_environment.t @@ -48,6 +48,15 @@ use strict; use warnings; use Test::More 'no_plan'; + +# Things happen... unfortunately +$SIG{__DIE__} = sub { + die unless defined $^S and ! $^S; + + diag "Something horrible happened while assembling the diag data\n$_[0]"; + exit 0; +}; + use Config; use File::Find 'find'; use Digest::MD5 (); From 12a184d0a0c1868708e43aaabefe08f9e7ac9ec4 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 21 Jun 2016 16:34:14 +0200 Subject: [PATCH 160/262] Revert TempExtlib ( b46b85376 ) - new Sub::Quote shipped --- Makefile.PL | 39 +------------------------ lib/DBIx/Class/Optional/Dependencies.pm | 4 --- lib/DBIx/Class/StartupCheck.pm | 33 --------------------- xt/extra/lean_startup.t | 1 - 4 files changed, 1 insertion(+), 76 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index b17c29ff7..5ef99487c 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -21,40 +21,6 @@ BEGIN { $Module::Install::AUTHOR = 0 if (grep { $ENV{"PERL5_${_}_IS_RUNNING"} } (qw/CPANM CPANPLUS CPAN/) ); } -## -## TEMPORARY (and non-portable) -## Get trial Moo -## -BEGIN { - my $target_libdir = 'lib/DBIx/Class/_TempExtlib'; - - if ( ($Module::Install::AUTHOR or $ENV{TRAVIS}) and ! $ENV{MAKELEVEL} ) { - - `rm -rf $target_libdir`; - `mkdir $target_libdir`; - for ( - [ 'Sub::Quote' => master => 'https://github.com/moose/Moo.git' ], - ) { - my $tdir = "/tmp/dbictemplib/$_->[0]/"; - - `rm -rf $tdir`; - - `GIT_SSH=maint/careless_ssh.bash git clone --bare --quiet --branch=$_->[1] --depth=1 $_->[2] $tdir`; - printf "\nIncluding %s git rev %s\n", - $_->[0], - scalar `GIT_DIR=$tdir git rev-parse $_->[1]`, - ; - `git archive --format=tar --remote=file://$tdir $_->[1] lib/ | tar --strip-components=1 -xC $target_libdir`; - - #`rm -rf $tdir`; - } - - unshift @INC, $target_libdir; - - no_index directory => $target_libdir; - } -} - name 'DBIx-Class'; version_from 'lib/DBIx/Class.pm'; perl_version '5.008001'; @@ -86,7 +52,7 @@ my $runtime_requires = { 'Data::Page' => '2.00', 'Devel::GlobalDestruction' => '0.09', 'Hash::Merge' => '0.12', - 'Moo' => '2.002', + 'Moo' => '2.002002', 'MRO::Compat' => '0.12', 'Module::Find' => '0.07', 'namespace::clean' => '0.24', @@ -94,9 +60,6 @@ my $runtime_requires = { 'SQL::Abstract' => '1.81', 'Try::Tiny' => '0.07', - # Temp to satisfy TemptExtlib - 'Role::Tiny' => '2.000002', - # Technically this is not a core dependency - it is only required # by the MySQL codepath. However this particular version is bundled # since 5.10.0 and is a pure-perl module anyway - let it slide diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm index 4a1535663..4bb44ff7f 100644 --- a/lib/DBIx/Class/Optional/Dependencies.pm +++ b/lib/DBIx/Class/Optional/Dependencies.pm @@ -7,10 +7,6 @@ BEGIN { require warnings and warnings->import; require strict and strict->import; } - - # Temporary to satisfy TempExtlib under tests - require DBIx::Class::StartupCheck - if $0 =~ /\.t$/; } sub croak { diff --git a/lib/DBIx/Class/StartupCheck.pm b/lib/DBIx/Class/StartupCheck.pm index 7a44a4baf..17ca65f79 100644 --- a/lib/DBIx/Class/StartupCheck.pm +++ b/lib/DBIx/Class/StartupCheck.pm @@ -1,40 +1,7 @@ package DBIx::Class::StartupCheck; -# Temporary - tempextlib use warnings; use strict; -use namespace::clean; -BEGIN { - # There can be only one of these, make sure we get the bundled part and - # *not* something off the site lib - for (qw( - Sub::Quote - )) { - (my $incfn = "$_.pm") =~ s|::|/|g; - - if ($INC{$incfn}) { - die "\n\t*TEMPORARY* TRIAL RELEASE REQUIREMENTS VIOLATED\n\n" - . "Unable to continue - a part of the bundled templib contents " - . "was already loaded (likely an older version from CPAN). " - . "Make sure that @{[ __PACKAGE__ ]} is loaded before $_\n" - . "\nUsually it is sufficient to add PERL5OPT=\"-M@{[ __PACKAGE__ ]}\" " - . "to your environment in order to resolve this problem\n" - . "\n\tThis is temporary and *WILL NOT* be necessary for the official " - . "DBIC release\n\n" - ; - } - } - - require File::Spec; - our ($HERE) = File::Spec->rel2abs( - File::Spec->catdir( (File::Spec->splitpath(__FILE__))[1], '_TempExtlib' ) - ) =~ /^(.*)$/; # screw you, taint mode - - die "TempExtlib $HERE does not seem to exist - perhaps you need to run `perl Makefile.PL` in the DBIC checkout?\n" - unless -d $HERE; - - unshift @INC, $HERE; -} 1; diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index 7c5df0a3e..c5ed8ccb3 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -135,7 +135,6 @@ BEGIN { Sub::Defer Sub::Quote attributes - File::Spec Scalar::Util Storable From c47451b7bcac767f6c3a7d9e348991a40b196f1a Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 23 Jun 2016 14:18:06 +0200 Subject: [PATCH 161/262] Extra test of UNIVERSAL handling in describe_class_methods While parents of UNIVERSAL *do* "inherit" some of UNIVERSAL's methods, making this circularity apparent is out of scope for this tool. Doing otherwise will complicate consumer code for no apparent benefit. Thus add an explicit test that "this is how it is". --- xt/extra/internals/attributes.t | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t index 1f9d7b58b..6567ec6bc 100644 --- a/xt/extra/internals/attributes.t +++ b/xt/extra/internals/attributes.t @@ -35,6 +35,7 @@ my $pkg_gen_history = {}; { package UEBERVERSAL; sub ueber {} } @UNIVERSAL::ISA = "UEBERVERSAL"; +sub UNIVERSAL::uni { "unistuff" } sub grab_pkg_gen ($) { push @{ $pkg_gen_history->{$_[0]} }, [ @@ -379,6 +380,13 @@ sub add_more_attrs { via_class => "UEBERVERSAL", } ], + uni => [ + { + attributes => {}, + name => "uni", + via_class => "UNIVERSAL", + } + ], can => [ { attributes => {}, @@ -479,6 +487,27 @@ sub add_more_attrs { $expected_desc, 'describing with implicit mro returns correct data' ); + + # check that a UNIVERSAL-parent interrogation makes sense + # ( it should not list anything from UNIVERSAL itself ) + is_deeply ( + describe_class_methods("UEBERVERSAL"), + { + # should be cached by now, thus safe to rely on...? + cumulative_gen => DBIx::Class::_Util::get_real_pkg_gen('UEBERVERSAL'), + + class => 'UEBERVERSAL', + mro => { is_c3 => 0, type => 'dfs' }, + isa => [], + methods => { + ueber => $expected_desc->{methods}{ueber} + }, + methods_defined_in_class => { + ueber => $expected_desc->{methods}{ueber}[0] + }, + }, + "Expected description of a parent-of-UNIVERSAL class (pathological case)", + ); } if ($skip_threads) { From 293cb2f1de2a488aa6062036deac8a562e8e16c6 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 3 Jun 2016 16:12:32 +0200 Subject: [PATCH 162/262] Add true/false non-singleton boolean objects This will be needed for the sanitychecker on OLD_MRO --- lib/DBIx/Class/_Util.pm | 15 +++++++++++++++ xt/extra/internals/bool.t | 23 +++++++++++++++++++++++ 2 files changed, 38 insertions(+) create mode 100644 xt/extra/internals/bool.t diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 76f9b3589..7af21026d 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -173,6 +173,7 @@ our @EXPORT_OK = qw( fail_on_internal_wantarray fail_on_internal_call refdesc refcount hrefaddr set_subname describe_class_methods scope_guard detected_reinvoked_destructor + true false is_exception dbic_internal_try visit_namespaces quote_sub qsub perlstring serialize deep_clone dump_value uniq parent_dir mkdir_p @@ -369,6 +370,20 @@ sub dump_value ($) { $dump_str; } +### +### This is *NOT* boolean.pm - deliberately not using a singleton +### +{ + package # hide from pause + DBIx::Class::_Util::_Bool; + use overload + bool => sub { ${$_[0]} }, + fallback => 1, + ; +} +sub true () { my $x = 1; bless \$x, "DBIx::Class::_Util::_Bool" } +sub false () { my $x = 0; bless \$x, "DBIx::Class::_Util::_Bool" } + sub scope_guard (&) { croak 'Calling scope_guard() in void context makes no sense' if ! defined wantarray; diff --git a/xt/extra/internals/bool.t b/xt/extra/internals/bool.t new file mode 100644 index 000000000..473a562f6 --- /dev/null +++ b/xt/extra/internals/bool.t @@ -0,0 +1,23 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; +use DBIx::Class::_Util qw( true false ); +use Scalar::Util 'refaddr'; + +my @things = ( true, false, true, false, true, false ); + +for (my $i = 0; $i < $#things; $i++ ) { + for my $j ( $i+1 .. $#things ) { + cmp_ok + refaddr( $things[$i] ), + '!=', + refaddr( $things[$j] ), + "Boolean thingy '$i' distinct from '$j'", + ; + } +} + +done_testing; From 501d6e066f4a0007c70749fccaac3777d645c623 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 4 Jun 2016 11:23:17 +0200 Subject: [PATCH 163/262] Raise the global lock timeouts 15 minutes on my laptop on battery with all assertions no longer cuts it :( --- t/lib/DBICTest/Util.pm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index dc3440600..3e250ccaf 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -76,7 +76,7 @@ sub dbg ($) { # This figure esentially means "how long can a single test hold a # resource before everyone else gives up waiting and aborts" or # in other words "how long does the longest test-group legitimally run?" -my $lock_timeout_minutes = 15; # yes, that's long, I know +my $lock_timeout_minutes = 30; # yes, that's long, I know my $wait_step_seconds = 0.25; sub await_flock ($$) { @@ -109,6 +109,9 @@ sub await_flock ($$) { } } + print STDERR "Lock timeout of $lock_timeout_minutes minutes reached: " + unless $res; + return $res; } @@ -282,7 +285,7 @@ sub slurp_bytes ($) { sub rm_rf ($) { - croak "No valid argument supplied to rm_rf()" unless length "$_[0]"; + croak "No argument supplied to rm_rf()" unless length "$_[0]"; return unless -e $_[0]; From 8eac247d3f1150abf238ae6a119860cdc8cf02b9 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 29 Jun 2016 15:32:00 +0200 Subject: [PATCH 164/262] Expand signature of describe_class_methods for forward compat It is likely extra options/attrs will need to be passed down the road - hence do not lock ourselves into positional args --- lib/DBIx/Class/_Util.pm | 10 ++++++++-- xt/extra/internals/attributes.t | 2 +- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 7af21026d..1c9c4b067 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -675,9 +675,15 @@ sub modver_gt_or_eq_and_lt ($$$) { our $describe_class_query_cache; sub describe_class_methods { - my ($class, $requested_mro) = @_; + my $args = ( + ref $_[0] eq 'HASH' ? $_[0] + : ( @_ == 1 and ! length ref $_[0] ) ? { class => $_[0] } + : { @_ } + ); + + my ($class, $requested_mro) = @{$args}{qw( class use_mro )}; - croak "Expecting a class name" + croak "Expecting a class name either as the sole argument or a 'class' option" if not defined $class or $class !~ $module_name_rx; $requested_mro ||= mro::get_mro($class); diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t index 6567ec6bc..2717b00f1 100644 --- a/xt/extra/internals/attributes.t +++ b/xt/extra/internals/attributes.t @@ -449,7 +449,7 @@ sub add_more_attrs { is_deeply ( # work around taint, see TODO below { - %{describe_class_methods("DBICTest::AttrTest", "dfs")}, + %{ describe_class_methods({ class => "DBICTest::AttrTest", use_mro => "dfs" }) }, cumulative_gen => $expected_desc->{cumulative_gen}, }, $expected_desc, From 2603b49536d45448ac98cd8aa7c7393867cb0db2 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 30 Jun 2016 00:40:15 +0200 Subject: [PATCH 165/262] Add hash-based ISA lookup to RV of describe_class_methods --- lib/DBIx/Class/_Util.pm | 9 +++++---- xt/extra/internals/attributes.t | 23 +++++++++++++---------- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 1c9c4b067..37d4ad77d 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -734,13 +734,11 @@ sub modver_gt_or_eq_and_lt ($$$) { unless ( ($slot->{cumulative_gen}||0) == $my_gen ) { - # remove ourselves from ISA - shift @full_ISA; - # reset %$slot = ( class => $class, - isa => [ + isa => { map { $_ => 1 } @full_ISA }, + linear_isa => [ @{ $mro_recursor_stack->{cache}{$stack_cache_key}{linear_isa} } [ 1 .. $#{$mro_recursor_stack->{cache}{$stack_cache_key}{linear_isa}} ] ], @@ -751,6 +749,9 @@ sub modver_gt_or_eq_and_lt ($$$) { cumulative_gen => $my_gen, ); + # remove ourselves from ISA + shift @full_ISA; + # ensure the cache is populated for the parents, code below can then # efficiently operate over the query_cache directly describe_class_methods($_) for reverse @full_ISA; diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t index 2717b00f1..5169d237f 100644 --- a/xt/extra/internals/attributes.t +++ b/xt/extra/internals/attributes.t @@ -286,13 +286,18 @@ sub add_more_attrs { # check that describe_class_methods returns the right stuff # ( on the simpler class ) - my $expected_AttrTest_ISA = [qw( + my $expected_AttrTest_linear_ISA = [qw( DBICTest::SomeParentClass DBICTest::SomeGrandParentClass DBICTest::AnotherParentClass DBIx::Class::MethodAttributes )]; + my $expected_AttrTest_full_ISA = { map { $_ => 1 } ( + qw( UEBERVERSAL UNIVERSAL DBICTest::AttrTest ), + @$expected_AttrTest_linear_ISA, + )}; + my $expected_desc = { class => "DBICTest::AttrTest", @@ -302,12 +307,8 @@ sub add_more_attrs { require Math::BigInt; my $gen = Math::BigInt->new(0); - $gen += DBIx::Class::_Util::get_real_pkg_gen($_) for ( - 'UEBERVERSAL', - 'UNIVERSAL', - 'DBICTest::AttrTest', - @$expected_AttrTest_ISA, - ); + $gen += DBIx::Class::_Util::get_real_pkg_gen($_) + for keys %$expected_AttrTest_full_ISA; $gen; }, @@ -315,7 +316,8 @@ sub add_more_attrs { type => 'c3', is_c3 => 1, }, - isa => $expected_AttrTest_ISA, + linear_isa => $expected_AttrTest_linear_ISA, + isa => $expected_AttrTest_full_ISA, methods => { FETCH_CODE_ATTRIBUTES => [ { @@ -444,7 +446,7 @@ sub add_more_attrs { # due to DFS the last 2 entries of ISA and the VALID_DBIC_CODE_ATTRIBUTE # sourcing-list will change places splice @$_, -2, 2, @{$_}[-1, -2] - for $V_D_C_A_stack, $expected_AttrTest_ISA; + for $V_D_C_A_stack, $expected_AttrTest_linear_ISA; is_deeply ( # work around taint, see TODO below @@ -498,7 +500,8 @@ sub add_more_attrs { class => 'UEBERVERSAL', mro => { is_c3 => 0, type => 'dfs' }, - isa => [], + isa => { UEBERVERSAL => 1 }, + linear_isa => [], methods => { ueber => $expected_desc->{methods}{ueber} }, From 953f8eb062bd84ffcb5b59d9a0d27d1db55f3927 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 30 Jun 2016 00:49:39 +0200 Subject: [PATCH 166/262] Use a single cache struct for entirety of describe_class_methods This will allow influencing the cache from outside like shown below, (but please, DO NOT DO SO), and in turn will make sanity checks on 5.8 somewhat acceptable *by default* \o/ $...::__describe_class_query_cache->{"!internal!"} = {}; --- lib/DBIx/Class/_Util.pm | 62 ++++++++++++++++++--------------- xt/extra/internals/attributes.t | 2 +- 2 files changed, 34 insertions(+), 30 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 37d4ad77d..a8c78d4b3 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -6,7 +6,10 @@ use DBIx::Class::StartupCheck; # load es early as we can, usually a noop use warnings; use strict; -my $mro_recursor_stack; +# For the love of everything that is crab-like: DO NOT reach into this +# The entire thing is really fragile and should not be screwed with +# unless absolutely and unavoidably necessary +our $__describe_class_query_cache; BEGIN { package # hide from pause @@ -68,18 +71,22 @@ BEGIN { require Digest::MD5; require Math::BigInt; + my $cur_class; + no strict 'refs'; + # the non-assign-unless-there-is-a-hash is deliberate - ( $mro_recursor_stack->{cache} || {} )->{$_[0]}{gen} ||= ( + ( $__describe_class_query_cache->{'!internal!'} || {} )->{$_[0]}{gen} ||= ( Math::BigInt->new( '0x' . ( Digest::MD5::md5_hex( join "\0", map { - ( $mro_recursor_stack->{cache} || {} )->{$_}{methlist} ||= do { + ( $__describe_class_query_cache->{'!internal!'} || {} )->{$_}{methlist} ||= ( - my $class = $_; - no strict 'refs'; + $cur_class = $_ + + and # RV to be hashed up and turned into a number join "\0", ( - $class, + $cur_class, map {( # stringification should be sufficient, ignore names/refaddr entirely @@ -89,34 +96,34 @@ BEGIN { map {( # skip dummy C::C3 helper crefs - ! ( ( $Class::C3::MRO{$class} || {} )->{methods}{$_} ) + ! ( ( $Class::C3::MRO{$cur_class} || {} )->{methods}{$_} ) and ( - ref(\ "${class}::"->{$_} ) ne 'GLOB' + ref(\ "${cur_class}::"->{$_} ) ne 'GLOB' or - defined( *{ "${class}::"->{$_} }{CODE} ) + defined( *{ "${cur_class}::"->{$_} }{CODE} ) ) ) - ? ( \&{"${class}::$_"} ) + ? ( \&{"${cur_class}::$_"} ) : () } - keys %{ "${class}::" } - ); - } + keys %{ "${cur_class}::" } + ) + ) } ( @{ - ( $mro_recursor_stack->{cache} || {} )->{$_[0]}{linear_isa} + ( $__describe_class_query_cache->{'!internal!'} || {} )->{$_[0]}{linear_isa} ||= mro::get_linear_isa($_[0]) }, (( - ( $mro_recursor_stack->{cache} || {} )->{$_[0]}{is_universal} + ( $__describe_class_query_cache->{'!internal!'} || {} )->{$_[0]}{is_universal} ||= mro::is_universal($_[0]) ) ? () : @{ - ( $mro_recursor_stack->{cache} || {} )->{UNIVERSAL}{linear_isa} + ( $__describe_class_query_cache->{'!internal!'} || {} )->{UNIVERSAL}{linear_isa} ||= mro::get_linear_isa("UNIVERSAL") } ), @@ -670,9 +677,6 @@ sub modver_gt_or_eq_and_lt ($$$) { } { - # FIXME - should be a private my(), but I'm too uncertain whether - # all bases are covered - our $describe_class_query_cache; sub describe_class_methods { my $args = ( @@ -691,7 +695,7 @@ sub modver_gt_or_eq_and_lt ($$$) { # mro::set_mro() does not bump pkg_gen - WHAT THE FUCK?! my $query_cache_key = "$class|$requested_mro"; - my $stack_cache_key = + my $internal_cache_key = ( mro::get_mro($class) eq $requested_mro ) ? $class : $query_cache_key @@ -705,32 +709,32 @@ sub modver_gt_or_eq_and_lt ($$$) { # we use the cache for linear_isa lookups on new MRO as well - it adds # a *tiny* speedup, and simplifies the code a lot # - local $mro_recursor_stack->{cache} = {} - unless $mro_recursor_stack->{cache}; + local $__describe_class_query_cache->{'!internal!'} = {} + unless $__describe_class_query_cache->{'!internal!'}; my $my_gen = 0; $my_gen += get_real_pkg_gen($_) for ( my @full_ISA = ( @{ - $mro_recursor_stack->{cache}{$stack_cache_key}{linear_isa} + $__describe_class_query_cache->{'!internal!'}{$internal_cache_key}{linear_isa} ||= mro::get_linear_isa($class, $requested_mro) }, (( - $mro_recursor_stack->{cache}{$class}{is_universal} + $__describe_class_query_cache->{'!internal!'}{$class}{is_universal} ||= mro::is_universal($class) ) ? () : @{ - $mro_recursor_stack->{cache}{UNIVERSAL}{linear_isa} + $__describe_class_query_cache->{'!internal!'}{UNIVERSAL}{linear_isa} ||= mro::get_linear_isa("UNIVERSAL") }), )); - my $slot = $describe_class_query_cache->{$query_cache_key} ||= {}; + my $slot = $__describe_class_query_cache->{$query_cache_key} ||= {}; unless ( ($slot->{cumulative_gen}||0) == $my_gen ) { @@ -739,8 +743,8 @@ sub modver_gt_or_eq_and_lt ($$$) { class => $class, isa => { map { $_ => 1 } @full_ISA }, linear_isa => [ - @{ $mro_recursor_stack->{cache}{$stack_cache_key}{linear_isa} } - [ 1 .. $#{$mro_recursor_stack->{cache}{$stack_cache_key}{linear_isa}} ] + @{ $__describe_class_query_cache->{'!internal!'}{$internal_cache_key}{linear_isa} } + [ 1 .. $#{$__describe_class_query_cache->{'!internal!'}{$internal_cache_key}{linear_isa}} ] ], mro => { type => $requested_mro, @@ -784,7 +788,7 @@ sub modver_gt_or_eq_and_lt ($$$) { # what describe_class_methods for @full_ISA produced above ( map { values %{ - $describe_class_query_cache->{$_}{methods_defined_in_class} || {} + $__describe_class_query_cache->{$_}{methods_defined_in_class} || {} } } map { "$_|" . mro::get_mro($_) } reverse @full_ISA ), # our own non-cleaned subs + their attributes diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t index 5169d237f..6c1998d65 100644 --- a/xt/extra/internals/attributes.t +++ b/xt/extra/internals/attributes.t @@ -437,7 +437,7 @@ sub add_more_attrs { # ensure that asking with a different MRO will not perturb the cache my $cached_desc = serialize( - $DBIx::Class::_Util::describe_class_query_cache->{"DBICTest::AttrTest|c3"} + $DBIx::Class::_Util::__describe_class_query_cache->{"DBICTest::AttrTest|c3"} ); # now try to ask for DFS explicitly, adjust our expectations From 92705f7f05161f7dba36d9b09dc6e893af7b2773 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 27 Jun 2016 10:29:27 +0200 Subject: [PATCH 167/262] Expand describe_class_methods testing yet again This should be the end of adjustments, so many corner cases... --- lib/DBIx/Class/_Util.pm | 22 ++- ...{attributes.t => describe_class_methods.t} | 133 +++++++++++++++--- 2 files changed, 131 insertions(+), 24 deletions(-) rename xt/extra/internals/{attributes.t => describe_class_methods.t} (83%) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index a8c78d4b3..b4fa5fb55 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -91,7 +91,15 @@ BEGIN { {( # stringification should be sufficient, ignore names/refaddr entirely $_, - attributes::get( $_ ), + do { + my @attrs; + local $@; + local $SIG{__DIE__} if $SIG{__DIE__}; + # attributes::get may throw on blessed-false crefs :/ + eval { @attrs = attributes::get( $_ ); 1 } + or warn "Unable to determine attributes of coderef $_ due to the following error: $@"; + @attrs; + }, )} map {( @@ -810,9 +818,15 @@ sub modver_gt_or_eq_and_lt ($$$) { ) ? { via_class => $class, name => $_, - attributes => { - map { $_ => 1 } attributes::get( \&{"${class}::${_}"} ) - }, + attributes => { map { $_ => 1 } do { + my @attrs; + local $@; + local $SIG{__DIE__} if $SIG{__DIE__}; + # attributes::get may throw on blessed-false crefs :/ + eval { @attrs = attributes::get( \&{"${class}::${_}"} ); 1 } + or warn "Unable to determine attributes of the \\&${class}::$_ method due to following error: $@"; + @attrs; + } }, } : () } keys %{"${class}::"} ) diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/describe_class_methods.t similarity index 83% rename from xt/extra/internals/attributes.t rename to xt/extra/internals/describe_class_methods.t index 6c1998d65..5a187cc2b 100644 --- a/xt/extra/internals/attributes.t +++ b/xt/extra/internals/describe_class_methods.t @@ -25,7 +25,10 @@ BEGIN { use Test::More; use Test::Exception; -use DBIx::Class::_Util qw( quote_sub describe_class_methods serialize refdesc ); +use DBIx::Class::_Util qw( + quote_sub describe_class_methods + serialize refdesc sigwarn_silencer +); use List::Util 'shuffle'; use Errno (); @@ -557,27 +560,117 @@ else { SKIP: { ); }} -# this doesn't really belong in this test, but screw it +# check "crosed-over" mro { - package DBICTest::WackyDFS; - use base qw( DBICTest::SomeGrandParentClass DBICTest::SomeParentClass ); + { + package DBICTest::WackyDFS; + use base qw( DBICTest::SomeGrandParentClass DBICTest::SomeParentClass ); + } + + is_deeply + describe_class_methods("DBICTest::WackyDFS")->{methods}{VALID_DBIC_CODE_ATTRIBUTE}, + [ + { + attributes => {}, + name => "VALID_DBIC_CODE_ATTRIBUTE", + via_class => "DBICTest::SomeGrandParentClass", + }, + { + attributes => {}, + name => "VALID_DBIC_CODE_ATTRIBUTE", + via_class => "DBIx::Class::MethodAttributes" + }, + ], + 'Expected description on unusable inheritance hierarchy' + ; } -is_deeply - describe_class_methods("DBICTest::WackyDFS")->{methods}{VALID_DBIC_CODE_ATTRIBUTE}, - [ - { - attributes => {}, - name => "VALID_DBIC_CODE_ATTRIBUTE", - via_class => "DBICTest::SomeGrandParentClass", - }, - { - attributes => {}, - name => "VALID_DBIC_CODE_ATTRIBUTE", - via_class => "DBIx::Class::MethodAttributes" - }, - ], - 'Expected description on unusable inheritance hierarchy' -; +# check pathological cases ( combinations of cases from +# Package::Stash and Devel::Isa::Explainer ) +{ + { + package DBICTest::Exotic; + + use constant CSCALAR => 1; + use constant CSCALARREF => \1; + use constant CARRAYREF => []; + use constant CHASHREF => {}; + use constant CSUB => sub { }; + + sub subnormal { } + sub substub; + sub subnormalproto () { } + sub substubproto (); + + sub Bsubnormal { } + sub Bsubstub; + sub Bsubnormalproto () { } + sub Bsubstubproto (); + + our @OURARRAY; + our %OURHASH; + our $OURSCALAR; + + *someXSUB = \&DBIx::Class::_Util::deep_clone; + + *EMPTYGLOB = *EMPTYGLOB; + + our @GLOBCOLLISION; + our %GLOBCOLLISION; + sub GLOBCOLLISION { } + + no strict 'refs'; + ${'DBICTest::'}{stubUNDEF} = undef; + ${'DBICTest::'}{stubSCALAR} = 1; + + bless $_, "0" + for map + { \&{"DBICTest::Exotic::Bsub$_"} } + qw( normal stub ) + ; + + bless $_, __PACKAGE__ + for map + { \&{"DBICTest::Exotic::Bsub$_"} } + qw( normalproto stubproto ) + ; + + package DBICTest::Exotic::SubPackage; + *CHILDGLOB = *CHILDGLOB; + } + + my $expected = [ sort + qw( + CSCALAR CSCALARREF CARRAYREF CHASHREF CSUB + GLOBCOLLISION someXSUB + ), + (map + {( "Bsub$_", "sub$_" )} + qw( normal stub normalproto stubproto ) + ), + ]; + + # FIXME because attributes::get() has an error in its signature parser + local $SIG{__WARN__} = sigwarn_silencer qr/Unable to determine attributes of/; + + is_deeply + [ sort keys %{ + describe_class_methods('DBICTest::Exotic')->{methods_defined_in_class} + } ], + $expected, + 'All expected methods recognized in pathological cases' + ; + + # blow the cache + *DBICTest::Exotic::zzz_extra_method = sub {}; + + is_deeply + [ sort keys %{ + describe_class_methods('DBICTest::Exotic')->{methods_defined_in_class} + } ], + [ @$expected, 'zzz_extra_method' ], + 'All expected methods yet again recognized in pathological cases' + ; +} done_testing; From 7db939decd3929e2800c7ab5ec883cb859b68927 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 1 Jul 2016 12:22:48 +0200 Subject: [PATCH 168/262] Audit all local() calls within lib/ and t/lib Correct some of them to fire less frequently (local is *expensive*) --- lib/DBIx/Class/ResultSource.pm | 2 +- lib/DBIx/Class/Schema.pm | 4 ++-- lib/DBIx/Class/Storage/BlockRunner.pm | 3 ++- lib/DBIx/Class/Storage/DBI.pm | 4 +++- lib/DBIx/Class/Storage/DBI/Firebird/Common.pm | 2 ++ lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm | 9 +++++---- lib/DBIx/Class/Storage/DBIHacks.pm | 3 ++- t/lib/DBICTest.pm | 4 ++-- t/lib/DBICTest/BaseSchema.pm | 2 +- t/lib/DBICTest/Util.pm | 5 ++--- 10 files changed, 22 insertions(+), 16 deletions(-) diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index c51c45d5f..725f30d42 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -2371,7 +2371,7 @@ sub DESTROY { # however beware - on older perls the exception seems randomly untrappable # due to some weird race condition during thread joining :((( local $SIG{__DIE__} if $SIG{__DIE__}; - local $@; + local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT; eval { weaken $_[0]->{schema}; diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index fff27ddd2..3bcc37f00 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -1058,7 +1058,7 @@ sub throw_exception { my $guard = scope_guard { return if $guard_disarmed; - local $SIG{__WARN__}; + local $SIG{__WARN__} if $SIG{__WARN__}; Carp::cluck(" !!! DBIx::Class INTERNAL PANIC !!! @@ -1436,7 +1436,7 @@ sub DESTROY { # due to some weird race condition during thread joining :((( if (length ref $srcs->{$source_name} and refcount($srcs->{$source_name}) > 1) { local $SIG{__DIE__} if $SIG{__DIE__}; - local $@; + local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT; eval { $srcs->{$source_name}->schema($self); weaken $srcs->{$source_name}; diff --git a/lib/DBIx/Class/Storage/BlockRunner.pm b/lib/DBIx/Class/Storage/BlockRunner.pm index 9b5bdbc6b..9d191c873 100644 --- a/lib/DBIx/Class/Storage/BlockRunner.pm +++ b/lib/DBIx/Class/Storage/BlockRunner.pm @@ -190,7 +190,8 @@ sub _run { ) or ! do { - local $self->storage->{_in_do_block_retry_handler} = 1; + local $self->storage->{_in_do_block_retry_handler} = 1 + unless $self->storage->{_in_do_block_retry_handler}; $self->retry_handler->($self) } ); diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 6c2940c88..132c8d4e6 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -1304,7 +1304,9 @@ sub _determine_driver { if ((not $self->_driver_determined) && (not $self->{_in_determine_driver})) { my $started_connected = 0; - local $self->{_in_determine_driver} = 1; + + local $self->{_in_determine_driver} = 1 + unless $self->{_in_determine_driver}; if (ref($self) eq __PACKAGE__) { my $driver; diff --git a/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm b/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm index 3677ec3be..e5e36ab00 100644 --- a/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm +++ b/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm @@ -54,6 +54,8 @@ sub _dbh_get_autoinc_seq { $table_name = $self->sql_maker->quote_char ? $table_name : uc($table_name); local $dbh->{LongReadLen} = 100000; + + # FIXME - this is likely *WRONG* local $dbh->{LongTruncOk} = 1; my $sth = $dbh->prepare(<<'EOF'); diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm index 838c8daa6..61767ba2b 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm @@ -297,11 +297,12 @@ sub _dbh_execute { return shift->$next(@_) if $self->transaction_depth; - # cheat the blockrunner we are just about to create - # we do want to rerun things regardless of outer state - local $self->{_in_do_block}; + # Cheat the blockrunner we are just about to create: + # We *do* want to rerun things regardless of outer state + local $self->{_in_do_block} + if $self->{_in_do_block}; - return DBIx::Class::Storage::BlockRunner->new( + DBIx::Class::Storage::BlockRunner->new( storage => $self, wrap_txn => 0, retry_handler => sub { diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm index 26cc4c88b..c700d54eb 100644 --- a/lib/DBIx/Class/Storage/DBIHacks.pm +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -228,7 +228,8 @@ sub _adjust_select_args_for_complex_prefetch { my $inner_subq = do { # must use it here regardless of user requests (vastly gentler on optimizer) - local $self->{_use_join_optimizer} = 1; + local $self->{_use_join_optimizer} = 1 + unless $self->{_use_join_optimizer}; # throw away multijoins since we def. do not care about those inside the subquery # $inner_aliastypes *will* be redefined at this point diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index 2e265b5e4..b43d4bff8 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -20,8 +20,8 @@ BEGIN { # prove) but I do not know it offhand, especially on older environments # Go with the safer option if ($INC{'Test/Builder.pm'}) { - local $| = 1; - print "#\n"; + select( ( select(\*STDOUT), $|=1 )[0] ); + print STDOUT "#\n"; } } diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index 726ce10f2..53036d3d1 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -262,7 +262,7 @@ sub connection { # we need to work with a forced fresh clone so that we do not upset any state # of the main $schema (some tests examine it quite closely) local $SIG{__WARN__} = sub {}; - local $SIG{__DIE__}; + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; # this will either give us an undef $locktype or will determine things diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 3e250ccaf..1529f90d5 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -104,8 +104,7 @@ sub await_flock ($$) { # prove -lj10 xt/extra/internals/ # select( ( select(\*STDOUT), $|=1 )[0] ); - - print "#\n"; + print STDOUT "#\n"; } } @@ -126,7 +125,7 @@ sub local_umask ($) { croak "Setting umask failed: $!" unless defined $old_umask; scope_guard(sub { - local ($@, $!, $?); + local ( $!, $^E, $?, $@ ); eval { defined(umask $old_umask) or die "nope"; From 759a7f44196c25be4409dc417be9160048d1f261 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 24 Jun 2016 18:31:01 +0200 Subject: [PATCH 169/262] Fill in missing documentation in ::Schema / ::ResultSource --- lib/DBIx/Class/ResultSource.pm | 9 +++++--- lib/DBIx/Class/Schema.pm | 41 +++++++++++++++++++++++++++++----- 2 files changed, 42 insertions(+), 8 deletions(-) diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 725f30d42..a7645ef9b 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -1098,12 +1098,15 @@ Store a collection of resultset attributes, that will be set on every L produced from this result source. B: C comes with its own set of issues and -bugs! While C isn't deprecated per se, its usage is -not recommended! +bugs! Notably the contents of the attributes are B, which +greatly hinders composability (things like L can not possibly be respected). +While C isn't deprecated per se, you are strongly urged +to seek alternatives. Since relationships use attributes to link tables together, the "default" attributes you set may cause unpredictable and undesired behavior. Furthermore, -the defaults cannot be turned off, so you are stuck with them. +the defaults B, so you are stuck with them. In most cases, what you should actually be using are project-specific methods: diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 3bcc37f00..9b5b56bb1 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -18,12 +18,16 @@ use Devel::GlobalDestruction; use namespace::clean; __PACKAGE__->mk_group_accessors( inherited => qw( storage exception_action ) ); -__PACKAGE__->mk_classaccessor('class_mappings' => {}); -__PACKAGE__->mk_classaccessor('source_registrations' => {}); __PACKAGE__->mk_classaccessor('storage_type' => '::DBI'); __PACKAGE__->mk_classaccessor('stacktrace' => $ENV{DBIC_TRACE} || 0); __PACKAGE__->mk_classaccessor('default_resultset_attributes' => {}); +# These two should have been private from the start but too late now +# Undocumented on purpose, hopefully it won't ever be necessary to +# screw with them +__PACKAGE__->mk_classaccessor('class_mappings' => {}); +__PACKAGE__->mk_classaccessor('source_registrations' => {}); + =head1 NAME DBIx::Class::Schema - composable schemas @@ -427,6 +431,30 @@ both types of refs here in order to play nice with your Config::[class] or your choice. See L for an example of this. +=head2 default_resultset_attributes + +=over 4 + +=item Arguments: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES> + +=item Return Value: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES> + +=item Default value: None + +=back + +Like L stores a collection +of resultset attributes, to be used as defaults for B ResultSet +instance schema-wide. The same list of CAVEATS and WARNINGS applies, with +the extra downside of these defaults being practically inescapable: you will +B be able to derive a ResultSet instance with these attributes unset. + +Example: + + package My::Schema; + use base qw/DBIx::Class::Schema/; + __PACKAGE__->default_resultset_attributes( { software_limit => 1 } ); + =head2 exception_action =over 4 @@ -787,13 +815,13 @@ sub populate { =item Arguments: @args -=item Return Value: $new_schema +=item Return Value: $self =back Similar to L except sets the storage object and connection -data in-place on the Schema class. You should probably be calling -L to get a proper Schema object instead. +data B on C<$self>. You should probably be calling +L to get a properly L Schema object instead. =head3 Overloading @@ -918,6 +946,9 @@ sub compose_namespace { return $schema; } +# LEGACY: The intra-call to this was removed in 66d9ef6b and then +# the sub was de-documented way later in 249963d4. No way to be sure +# nothing on darkpan is calling it directly, so keeping as-is sub setup_connection_class { my ($class, $target, @info) = @_; $class->inject_base($target => 'DBIx::Class::DB'); From 4748528603469f1d60b4df0321d4ed6be6e5c724 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 29 Jun 2016 19:29:27 +0200 Subject: [PATCH 170/262] (travis) Add poisoning to the base non-clean build run --- .travis.yml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/.travis.yml b/.travis.yml index 2b0d8b946..26a7a1eae 100644 --- a/.travis.yml +++ b/.travis.yml @@ -70,23 +70,28 @@ matrix: # In genereal it is strongly recommended to keep things on the older # version indefinitely - there is little value in-depth smoking on # more recent software stacks + # Add moderate (not complete) poisoning, as these will run on PR-related + # builds, therefore contributors will get notified about *most* issues - perl: "5.8" sudo: required dist: precise env: - CLEANTEST=false + - POISON_ENV=true - perl: "5.10" sudo: required dist: precise env: - CLEANTEST=false + - POISON_ENV=true - perl: "5.22-extras" sudo: required dist: precise env: - CLEANTEST=false + - POISON_ENV=true # CLEANTEST of minimum supported with non-tracing poisoning, single thread (hence the sudo) - perl: "5.8.3_nt_mb" From 4c0829325108ab553f442e1553469db9d6ef5851 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 3 Jul 2016 10:43:20 +0200 Subject: [PATCH 171/262] (travis) Properly diagnose potential OOM in 50_after_success.bash Idea originally introduced in ac4e80df --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 26a7a1eae..b37c43109 100644 --- a/.travis.yml +++ b/.travis.yml @@ -432,7 +432,7 @@ script: after_success: # Check if we can assemble a dist properly if not in CLEANTEST # - - maint/getstatus maint/travis-ci_scripts/50_after_success.bash + - maint/getstatus maint/travis-ci_scripts/50_after_success.bash || ( maint/travis-ci_scripts/50_after_failure.bash && /bin/false ) after_failure: # Final sysinfo printout on fail From 394f81ad61a22517728069dc5da1695eb21d56f8 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 13 Jul 2016 17:57:18 +0200 Subject: [PATCH 172/262] (travis) Switch to our own copy of the Firebird ODBC driver Sourceforge is just way too unstable --- maint/travis-ci_scripts/10_before_install.bash | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/maint/travis-ci_scripts/10_before_install.bash b/maint/travis-ci_scripts/10_before_install.bash index 4fa1338a5..157320ef4 100755 --- a/maint/travis-ci_scripts/10_before_install.bash +++ b/maint/travis-ci_scripts/10_before_install.bash @@ -178,9 +178,13 @@ if [[ "$CLEANTEST" != "true" ]]; then "echo \"CREATE DATABASE '/var/lib/firebird/2.5/data/dbic_test.fdb';\" | sudo isql-fb -u sysdba -p 123" then + + # Do not upgrade to a newer ODBC driver - smoking on an old + # and buggy POS is much more valuable + # run_or_err "Fetching and building Firebird ODBC driver" ' cd "$(mktemp -d)" - wget -qO- http://sourceforge.net/projects/firebird/files/firebird-ODBC-driver/2.0.2-Release/OdbcFb-Source-2.0.2.153.gz/download | tar -zx + wget -qO- https://github.com/dbsrgits/Firebird-ODBC-driver/archive/2.0.2.153.tar.gz | tar -zx --strip-components 1 cd Builds/Gcc.lin perl -p -i -e "s|/usr/lib64|/usr/lib/x86_64-linux-gnu|g" ../makefile.environ make -f makefile.linux From bced0adbd0c36588cbe2665bbba353a7445f0b79 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 13 Jul 2016 17:51:00 +0200 Subject: [PATCH 173/262] Silence inactionable warning (mainly on travis) --- t/lib/DBICTest/Util/LeakTracer.pm | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index b36843edd..49621ebc0 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -161,7 +161,16 @@ sub visit_refs { } values %{ scalar PadWalker::closed_over($r) } ] }); # scalar due to RT#92269 } 1; - } or warn "Could not descend into @{[ refdesc $r ]}: $@\n"; + } or ( + # this is some bizarre old DBI autosplit thing, no point mentioning it + $@ !~ m{ ^Can't \s locate \s (?: + auto/DBI/FIRSTKEY.al + | + \Qobject method "FIRSTKEY" via package "DBI"\E + )}x + and + warn "Could not descend into @{[ refdesc $r ]}: $@\n" + ); } $visited_cnt; } From 4ee643f5a0b025634b15077d4d82028a6ee8e21b Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 30 Jun 2016 21:55:55 +0200 Subject: [PATCH 174/262] Fix POISON_ENV warning missed in both 5c33c8be and 44c1a75d --- t/lib/DBICTest/BaseSchema.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index 53036d3d1..aaaf955ca 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -96,7 +96,7 @@ if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { ( caller(0) eq 'main' and - (caller(1))[0] !~ $interesting_ns_rx + ( (caller(1))[0] || '' ) !~ $interesting_ns_rx ) ); From c40b5744f85a8ffc2da494464655936387c04251 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 14 Jul 2016 13:03:26 +0200 Subject: [PATCH 175/262] Add more forceful (STDERR-direct) warning emitter Switch some of the most critical announements to it --- lib/DBIx/Class/Schema.pm | 8 ++-- lib/DBIx/Class/_Util.pm | 92 +++++++++++++++++++++++++++++-------- t/35exception_inaction.t | 1 + t/36double_destroy.t | 61 ++++++++++++++++++++++++ t/storage/txn_scope_guard.t | 25 ---------- 5 files changed, 138 insertions(+), 49 deletions(-) create mode 100644 t/36double_destroy.t diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 9b5b56bb1..702d472c3 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -12,7 +12,7 @@ use Scalar::Util qw/weaken blessed/; use DBIx::Class::_Util qw( refcount quote_sub scope_guard is_exception dbic_internal_try - fail_on_internal_call + fail_on_internal_call emit_loud_diag ); use Devel::GlobalDestruction; use namespace::clean; @@ -1089,8 +1089,8 @@ sub throw_exception { my $guard = scope_guard { return if $guard_disarmed; - local $SIG{__WARN__} if $SIG{__WARN__}; - Carp::cluck(" + emit_loud_diag( emit_dups => 1, msg => " + !!! DBIx::Class INTERNAL PANIC !!! The exception_action() handler installed on '$self' @@ -1103,7 +1103,7 @@ anything for other software that might be affected by a similar problem. !!! FIX YOUR ERROR HANDLING !!! -This guard was activated beginning" +This guard was activated starting", ); }; diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index b4fa5fb55..8bca63519 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -151,13 +151,11 @@ BEGIN { # to be outfits with *COPY PASTED* pieces of lib/DBIx/Class/Storage/* # in their production codebases. There is no point in breaking these # if whatever they used actually continues to work - my $warned; my $sigh = sub { - - require Carp; - my $cluck = "The @{[ (caller(1))[3] ]} constant is no more - adjust your code" . Carp::longmess(); - - warn $cluck unless $warned->{$cluck}++; + DBIx::Class::_Util::emit_loud_diag( + skip_frames => 1, + msg => "The @{[ (caller(1))[3] ]} constant is no more - adjust your code" + ); 0; }; @@ -187,7 +185,7 @@ our @EXPORT_OK = qw( sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt fail_on_internal_wantarray fail_on_internal_call refdesc refcount hrefaddr set_subname describe_class_methods - scope_guard detected_reinvoked_destructor + scope_guard detected_reinvoked_destructor emit_loud_diag true false is_exception dbic_internal_try visit_namespaces quote_sub qsub perlstring serialize deep_clone dump_value uniq @@ -385,6 +383,61 @@ sub dump_value ($) { $dump_str; } +my $seen_loud_screams; +sub emit_loud_diag { + my $args = { ref $_[0] eq 'HASH' ? %{$_[0]} : @_ }; + + unless ( defined $args->{msg} and length $args->{msg} ) { + emit_loud_diag( + msg => "No 'msg' value supplied to emit_loud_diag()" + ); + exit 70; + } + + my $msg = "\n$0: $args->{msg}"; + + # when we die - we usually want to keep doing it + $args->{emit_dups} = !!$args->{confess} + unless exists $args->{emit_dups}; + + local $Carp::CarpLevel = + ( $args->{skip_frames} || 0 ) + + + $Carp::CarpLevel + + + # hide our own frame + 1 + ; + + my $longmess = Carp::longmess(); + + # different object references will thwart deduplication without this + ( my $key = "${msg}\n${longmess}" ) =~ s/\b0x[0-9a-f]+\b/0x.../gi; + + return $seen_loud_screams->{$key} if + $seen_loud_screams->{$key}++ + and + ! $args->{emit_dups} + ; + + $msg .= $longmess + unless $msg =~ /\n\z/; + + print STDERR "$msg\n" + or + print STDOUT "\n!!!STDERR ISN'T WRITABLE!!!:$msg\n"; + + return $seen_loud_screams->{$key} + unless $args->{confess}; + + # increment *again*, because... Carp. + $Carp::CarpLevel++; + + # not $msg - Carp will reapply the longmess on its own + Carp::confess($args->{msg}); +} + + ### ### This is *NOT* boolean.pm - deliberately not using a singleton ### @@ -420,8 +473,9 @@ sub scope_guard (&) { 1; } or - Carp::cluck( - "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@" + DBIx::Class::_Util::emit_loud_diag( + emit_dups => 1, + msg => "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@\n " ); } } @@ -486,18 +540,16 @@ sub is_exception ($) { and length( my $class = ref $e ) ) { - carp_unique( sprintf( - "Objects of external exception class '%s' stringify to '' (the " + carp_unique( + "Objects of external exception class '$class' stringify to '' (the " . 'empty string), implementing the so called null-object-pattern. ' . 'Given Perl\'s "globally cooperative" exception handling using this ' . 'class of exceptions is extremely dangerous, as it may (and often ' . 'does) result in silent discarding of errors. DBIx::Class tries to ' . 'work around this as much as possible, but other parts of your ' . 'software stack may not be even aware of the problem. Please submit ' - . 'a bugreport against the distribution containing %s', - - ($class) x 2, - )); + . "a bugreport against the distribution containing '$class'", + ); $not_blank = 1; } @@ -610,10 +662,10 @@ sub is_exception ($) { for keys %$destruction_registry; if (! length ref $_[0]) { - printf STDERR '%s() expects a blessed reference %s', - (caller(0))[3], - Carp::longmess, - ; + emit_loud_diag( + emit_dups => 1, + msg => (caller(0))[3] . '() expects a blessed reference' + ); return undef; # don't know wtf to do } elsif (! defined $destruction_registry->{ my $addr = refaddr($_[0]) } ) { @@ -621,7 +673,7 @@ sub is_exception ($) { return 0; } else { - carp_unique ( sprintf ( + emit_loud_diag( msg => sprintf ( 'Preventing *MULTIPLE* DESTROY() invocations on %s - an *EXTREMELY ' . 'DANGEROUS* condition which is *ALMOST CERTAINLY GLOBAL* within your ' . 'application, affecting *ALL* classes without active protection against ' diff --git a/t/35exception_inaction.t b/t/35exception_inaction.t index 2a3023b62..0f775f402 100644 --- a/t/35exception_inaction.t +++ b/t/35exception_inaction.t @@ -72,6 +72,7 @@ ESCAPE: $schema->storage->ensure_connected; $schema->storage->_dbh->disconnect; + # silences "exitting sub via last" local $SIG{__WARN__} = sub {}; $schema->exception_action(sub { diff --git a/t/36double_destroy.t b/t/36double_destroy.t new file mode 100644 index 000000000..f070d142c --- /dev/null +++ b/t/36double_destroy.t @@ -0,0 +1,61 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; +use File::Temp (); + +use DBICTest::Util 'tmpdir'; +use DBIx::Class::_Util 'scope_guard'; + +use DBICTest; + +open(my $stderr_copy, '>&', *STDERR) or die "Unable to dup STDERR: $!"; +my $tf = File::Temp->new( UNLINK => 1, DIR => tmpdir() ); + +my $output; + +# ensure Devel::StackTrace-refcapture-like effects are countered +{ + my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); + my $g = $s->txn_scope_guard; + + my @arg_capture; + { + local $SIG{__WARN__} = sub { + package DB; + my $frnum; + while (my @f = CORE::caller(++$frnum) ) { + push @arg_capture, @DB::args; + } + }; + + undef $g; + 1; + } + + my $guard = scope_guard { + close STDERR; + open(STDERR, '>&', $stderr_copy); + $output = do { local (@ARGV, $/) = $tf; <> }; + close $tf; + unlink $tf; + undef $tf; + close $stderr_copy; + }; + + close STDERR; + open(STDERR, '>&', $tf) or die "Unable to reopen STDERR: $!"; + + # this should emit on stderr + @arg_capture = (); +} + +like( + $output, + qr/\QPreventing *MULTIPLE* DESTROY() invocations on DBIx::Class::Storage::TxnScopeGuard/, + 'Proper warning emitted on STDERR' +); + +done_testing; diff --git a/t/storage/txn_scope_guard.t b/t/storage/txn_scope_guard.t index e9e69a34e..09efcd7f6 100644 --- a/t/storage/txn_scope_guard.t +++ b/t/storage/txn_scope_guard.t @@ -239,29 +239,4 @@ require DBICTest::AntiPattern::NullObject; is(scalar @w, 0, 'no warnings \o/'); } -# ensure Devel::StackTrace-refcapture-like effects are countered -{ - my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); - my $g = $s->txn_scope_guard; - - my @arg_capture; - { - local $SIG{__WARN__} = sub { - package DB; - my $frnum; - while (my @f = CORE::caller(++$frnum) ) { - push @arg_capture, @DB::args; - } - }; - - undef $g; - 1; - } - - warnings_exist - { @arg_capture = () } - qr/\QPreventing *MULTIPLE* DESTROY() invocations on DBIx::Class::Storage::TxnScopeGuard/ - ; -} - done_testing; From 17d4e610368c12634f026bdcc25d782756361171 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 13 Jul 2016 18:28:23 +0200 Subject: [PATCH 176/262] Insulate DBIC::Carp from rogue can() overrides --- lib/DBIx/Class/Carp.pm | 37 +++++++++++++++++++++++++++++++++++-- 1 file changed, 35 insertions(+), 2 deletions(-) diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm index fbd37e5b4..9474dc1c3 100644 --- a/lib/DBIx/Class/Carp.pm +++ b/lib/DBIx/Class/Carp.pm @@ -9,11 +9,44 @@ use warnings; use Carp (); $Carp::Internal{ (__PACKAGE__) }++; +use Scalar::Util (); + +# Because... sigh +# There are cases out there where a user provides a can() that won't actually +# work as perl intends it. Since this is a reporting library, we *have* to be +# extra paranoid ( e.g. https://rt.cpan.org/Ticket/Display.html?id=90715 ) +sub __safe_can ($$) { + local $@; + local $SIG{__DIE__} if $SIG{__DIE__}; + + my $cref; + eval { + $cref = $_[0]->can( $_[1] ); + + # in case the can() isn't an actual UNIVERSAL::can() + die "Return value of $_[0]" . "->can(q($_[1])) is true yet not a code reference...\n" + if $cref and Scalar::Util::reftype($cref) ne 'CODE'; + + 1; + } or do { + undef $cref; + + # can not use DBIC::_Util::emit_loud_diag - it uses us internally + printf STDERR + "\n$0: !!! INTERNAL PANIC !!!\nClass '%s' implements or inherits a broken can() - PLEASE FIX ASAP!: %s\n\n", + ( length ref $_[0] ? ref $_[0] : $_[0] ), + $@, + ; + }; + + $cref; +} + sub __find_caller { my ($skip_pattern, $class) = @_; my $skip_class_data = $class->_skip_namespace_frames - if ($class and $class->can('_skip_namespace_frames')); + if ($class and __safe_can($class, '_skip_namespace_frames') ); $skip_pattern = qr/$skip_pattern|$skip_class_data/ if $skip_class_data; @@ -40,7 +73,7 @@ sub __find_caller { ) ? $f[3] : undef; if ( - $f[0]->can('_skip_namespace_frames') + __safe_can( $f[0], '_skip_namespace_frames' ) and my $extra_skip = $f[0]->_skip_namespace_frames ) { From 86a432d4cc096062e2374f118ce38aa131799d6a Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 14 Jul 2016 14:50:02 +0200 Subject: [PATCH 177/262] Add a get_subname to _Util --- lib/DBIx/Class/Componentised.pm | 4 ++-- lib/DBIx/Class/_Util.pm | 11 +++++++++-- xt/extra/internals/namespaces_cleaned.t | 9 ++++----- 3 files changed, 15 insertions(+), 9 deletions(-) diff --git a/lib/DBIx/Class/Componentised.pm b/lib/DBIx/Class/Componentised.pm index 47797cce1..3adea571f 100644 --- a/lib/DBIx/Class/Componentised.pm +++ b/lib/DBIx/Class/Componentised.pm @@ -7,6 +7,7 @@ use warnings; use base 'Class::C3::Componentised'; use mro 'c3'; +use DBIx::Class::_Util 'get_subname'; use DBIx::Class::Carp '^DBIx::Class|^Class::C3::Componentised'; use namespace::clean; @@ -57,8 +58,7 @@ sub inject_base { or next; if ($sc ne $base_store_column) { - require B; - my $definer = B::svref_2object($sc)->STASH->NAME; + my ($definer) = get_subname($sc); push @broken, ($definer eq $existing_comp) ? $existing_comp : "$existing_comp (via $definer)" diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 8bca63519..a8785c08c 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -184,7 +184,7 @@ use base 'Exporter'; our @EXPORT_OK = qw( sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt fail_on_internal_wantarray fail_on_internal_call - refdesc refcount hrefaddr set_subname describe_class_methods + refdesc refcount hrefaddr set_subname get_subname describe_class_methods scope_guard detected_reinvoked_destructor emit_loud_diag true false is_exception dbic_internal_try visit_namespaces @@ -323,7 +323,14 @@ sub visit_namespaces { $visited_count; } -# FIXME In another life switch this to a polyfill like the one in namespace::clean +# FIXME In another life switch these to a polyfill like the ones in namespace::clean +sub get_subname ($) { + my $gv = B::svref_2object( $_[0] )->GV; + wantarray + ? ( $gv->STASH->NAME, $gv->NAME ) + : ( join '::', $gv->STASH->NAME, $gv->NAME ) + ; +} sub set_subname ($$) { # fully qualify name diff --git a/xt/extra/internals/namespaces_cleaned.t b/xt/extra/internals/namespaces_cleaned.t index e5d74acbd..19768a874 100644 --- a/xt/extra/internals/namespaces_cleaned.t +++ b/xt/extra/internals/namespaces_cleaned.t @@ -63,7 +63,7 @@ use Test::More; use DBICTest; use File::Find; use File::Spec; -use B qw/svref_2object/; +use DBIx::Class::_Util 'get_subname'; # makes sure we can load at least something use DBIx::Class; @@ -134,15 +134,14 @@ for my $mod (@modules) { # overload is a funky thing - it is not cleaned, and its imports are named funny next if $name =~ /^\(/; - my $gv = svref_2object($all_method_like{$name})->GV; - my $origin = $gv->STASH->NAME; + my ($origin, $cv_name) = get_subname($all_method_like{$name}); - is ($gv->NAME, $name, "Properly named $name method at $origin" . ($origin eq $mod + is ($cv_name, $name, "Properly named $name method at $origin" . ($origin eq $mod ? '' : " (inherited by $mod)" )); - next if $seen->{"${origin}:${name}"}++; + next if $seen->{"${origin}::${name}"}++; if ($origin eq $mod) { pass ("$name is a native $mod method"); From b090048f6d8bd2cba0bae8ea7ec26459dd20dca8 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 14 Jul 2016 15:20:03 +0200 Subject: [PATCH 178/262] Get rid of Package::Stash \o/ Internal tooling advanced sufficiently without planning for any of that: a good indicator things are on the right track! Read under -w --- Makefile.PL | 4 -- lib/DBIx/Class/CDBICompat/ColumnGroups.pm | 2 +- lib/DBIx/Class/ResultSetManager.pm | 32 +++++------ xt/extra/internals/namespaces_cleaned.t | 68 +++++++++++++---------- 4 files changed, 54 insertions(+), 52 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index 5ef99487c..df82cb744 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -85,10 +85,6 @@ my $test_requires = { # 'Sub::Uplevel' => '0.19', - # this is already a dep of n::c, but just in case - used by t/55namespaces_cleaned.t - # remove and do a manual glob-collection if n::c is no longer a dep - 'Package::Stash' => '0.28', - # needed for testing only, not for operation # we will move away from this dep eventually, perhaps to DBD::CSV or something %{ DBIx::Class::Optional::Dependencies->req_list_for('test_rdbms_sqlite') }, diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm index 47eefd5dd..6ead1f77f 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm @@ -98,7 +98,7 @@ sub _register_column_group { grep { $_ ne $class and - ($_->can($name)||0) == $existing_accessor + ( $Class::C3::MRO{$_} || {} )->{methods}{$name} } @{mro::get_linear_isa($class)} ) ) diff --git a/lib/DBIx/Class/ResultSetManager.pm b/lib/DBIx/Class/ResultSetManager.pm index 3ae9502c7..addc8c36f 100644 --- a/lib/DBIx/Class/ResultSetManager.pm +++ b/lib/DBIx/Class/ResultSetManager.pm @@ -2,9 +2,8 @@ package DBIx::Class::ResultSetManager; use strict; use warnings; use base 'DBIx::Class'; -use Package::Stash (); -use DBIx::Class::_Util 'set_subname'; +use DBIx::Class::_Util qw( set_subname describe_class_methods ); use namespace::clean; warn "DBIx::Class::ResultSetManager never left experimental status and @@ -56,25 +55,22 @@ sub _register_attributes { my $cache = $self->_attr_cache; return if keys %$cache == 0; - foreach my $meth (keys %{ { map - { $_ => 1 } + for my $meth( map - { Package::Stash->new($_)->list_all_symbols("CODE") } - @{ mro::get_linear_isa( ref $self || $self ) } - } } ) { - # *DO NOT* rely on P::S returning crefs in reverse mro order - # but instead ask the mro to redo the lookup + { $_->{name} } + grep + { $_->{attributes}{ResultSet} } + map + { $_->[0] } + values %{ describe_class_methods( ref $self || $self )->{methods} } + ) { # This codepath is extremely old, miht as well keep it running # as-is with no room for surprises - my $attrs = $cache->{$self->can($meth)}; - next unless $attrs; - if ($attrs->[0] eq 'ResultSet') { - no strict 'refs'; - my $resultset_class = $self->_setup_resultset_class; - my $name = join '::',$resultset_class, $meth; - *$name = set_subname $name, $self->can($meth); - delete ${"${self}::"}{$meth}; - } + no strict 'refs'; + my $resultset_class = $self->_setup_resultset_class; + my $name = join '::',$resultset_class, $meth; + *$name = set_subname $name, $self->can($meth); + delete ${"${self}::"}{$meth}; } } diff --git a/xt/extra/internals/namespaces_cleaned.t b/xt/extra/internals/namespaces_cleaned.t index 19768a874..700a90801 100644 --- a/xt/extra/internals/namespaces_cleaned.t +++ b/xt/extra/internals/namespaces_cleaned.t @@ -35,41 +35,48 @@ BEGIN { use strict; use warnings; -# FIXME This is a crock of shit, needs to go away -# currently here to work around https://rt.cpan.org/Ticket/Display.html?id=74151 -# kill with fire when PS::XS / RT#74151 is *finally* fixed -BEGIN { - my $PS_provider; - - if ( "$]" < 5.010 ) { - require Package::Stash::PP; - $PS_provider = 'Package::Stash::PP'; - } - else { - require Package::Stash; - $PS_provider = 'Package::Stash'; - } - eval <<"EOS" or die $@; - -sub stash_for (\$) { - $PS_provider->new(\$_[0]); -} -1; -EOS -} - use Test::More; use DBICTest; use File::Find; use File::Spec; -use DBIx::Class::_Util 'get_subname'; +use DBIx::Class::_Util qw( get_subname describe_class_methods ); # makes sure we can load at least something use DBIx::Class; use DBIx::Class::Carp; -my @modules = grep { +my @modules = map { + # FIXME: AS THIS IS CLEARLY A LACK OF DEFENSE IN describe_class_methods :FIXME + # FIXME !!! without this detaint I get the test into an infloop on 5.16.x + # (maybe other versions): https://travis-ci.org/ribasushi/dbix-class/jobs/144738784#L26762 + # + # or locally like: + # + # ~$ ulimit -v $(( 1024 * 256 )); perl -d:Confess -Ilib -Tl xt/extra/internals/namespaces_cleaned.t + # ... + # DBIx::Class::MethodAttributes::_attr_cache("DBIx::Class::Storage::DBI::ODBC::Firebird") called at lib/DBIx/Class/MethodAttributes.pm line 166 + # DBIx::Class::MethodAttributes::_attr_cache("DBIx::Class::Storage::DBI::ODBC::Firebird") called at lib/DBIx/Class/MethodAttributes.pm line 166 + # DBIx::Class::MethodAttributes::_attr_cache("DBIx::Class::Storage::DBI::ODBC::Firebird") called at lib/DBIx/Class/MethodAttributes.pm line 166 + # DBIx::Class::MethodAttributes::_attr_cache("DBIx::Class::Storage::DBI::ODBC::Firebird") called at lib/DBIx/Class/MethodAttributes.pm line 154 + # DBIx::Class::MethodAttributes::FETCH_CODE_ATTRIBUTES("DBIx::Class::Storage::DBI::ODBC::Firebird", CODE(0x42ac2b0)) called at /home/rabbit/perl5/perlbrew/perls/5.16.2/lib/5.16.2/x86_64-linux-thread-multi-ld/attributes.pm line 101 + # attributes::get(CODE(0x42ac2b0)) called at lib/DBIx/Class/_Util.pm line 885 + # eval {...} called at lib/DBIx/Class/_Util.pm line 885 + # DBIx::Class::_Util::describe_class_methods("DBIx::Class::Storage::DBI::ODBC::Firebird") called at xt/extra/internals/namespaces_cleaned.t line 129 + # Out of memory! + # Out of memory! + # Out of memory! + # ... + # Segmentation fault + # + # FIXME: AS THIS IS CLEARLY A LACK OF DEFENSE IN describe_class_methods :FIXME + # Sweeping it under the rug for now as this is an xt/ test, + # but someone *must* find what is going on eventually + # FIXME: AS THIS IS CLEARLY A LACK OF DEFENSE IN describe_class_methods :FIXME + + ( $_ =~ /(.+)/ ) + +} grep { my ($mod) = $_ =~ /(.+)/; # not all modules are loadable at all times @@ -115,10 +122,13 @@ for my $mod (@modules) { SKIP: { skip "$mod exempt from namespace checks",1 if $skip_idx->{$mod}; - my %all_method_like = (map - { %{stash_for($_)->get_all_symbols('CODE')} } - (reverse @{mro::get_linear_isa($mod)}) - ); + my %all_method_like = + map + { $_->[0]{name} => $mod->can( $_->[0]{name} ) } + grep + { $_->[0]{via_class} ne 'UNIVERSAL' } + values %{ describe_class_methods($mod)->{methods} } + ; my %parents = map { $_ => 1 } @{mro::get_linear_isa($mod)}; From 5f0174dc9a33d03e4333fdf60e765dce325bf80a Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 16 Jul 2016 13:29:40 +0200 Subject: [PATCH 179/262] Work around the FIXME in the previous commit Based on @haarg's excellent detective work: https://is.gd/perl_mro_taint_wtf --- lib/DBIx/Class/_Util.pm | 14 +++++++- xt/dist/strictures.t | 4 +-- xt/extra/internals/describe_class_methods.t | 2 +- xt/extra/internals/namespaces_cleaned.t | 38 +++------------------ 4 files changed, 20 insertions(+), 38 deletions(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index a8785c08c..6a93f65b4 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -34,6 +34,8 @@ BEGIN { HAS_ITHREADS => $Config{useithreads} ? 1 : 0, + TAINT_MODE => 0 + ${^TAINT}, # tri-state: 0, 1, -1 + UNSTABLE_DOLLARAT => ( PERL_VERSION < 5.013002 ) ? 1 : 0, ( map @@ -757,6 +759,16 @@ sub modver_gt_or_eq_and_lt ($$$) { croak "Expecting a class name either as the sole argument or a 'class' option" if not defined $class or $class !~ $module_name_rx; + croak( + "The supplied 'class' argument is tainted: this is *extremely* " + . 'dangerous, fix your code ASAP!!! ( for more details read through ' + . 'https://is.gd/perl_mro_taint_wtf )' + ) if ( + DBIx::Class::_ENV_::TAINT_MODE + and + Scalar::Util::tainted($class) + ); + $requested_mro ||= mro::get_mro($class); # mro::set_mro() does not bump pkg_gen - WHAT THE FUCK?! @@ -899,7 +911,7 @@ sub modver_gt_or_eq_and_lt ($$$) { if ( ! DBIx::Class::_ENV_::OLD_MRO and - ${^TAINT} + DBIx::Class::_ENV_::TAINT_MODE ) { $slot->{cumulative_gen} = 0; diff --git a/xt/dist/strictures.t b/xt/dist/strictures.t index 8d15f123b..5d8cb4e85 100644 --- a/xt/dist/strictures.t +++ b/xt/dist/strictures.t @@ -24,9 +24,9 @@ my $missing_groupdeps_present = grep # don't test syntax when RT#106935 is triggered (mainly CI) # FIXME - remove when RT is resolved my $tainted_relpath = ( - length $ENV{PATH} + DBIx::Class::_ENV_::TAINT_MODE and - ${^TAINT} + length $ENV{PATH} and grep { ! File::Spec->file_name_is_absolute($_) } diff --git a/xt/extra/internals/describe_class_methods.t b/xt/extra/internals/describe_class_methods.t index 5a187cc2b..5d7217b4e 100644 --- a/xt/extra/internals/describe_class_methods.t +++ b/xt/extra/internals/describe_class_methods.t @@ -466,7 +466,7 @@ sub add_more_attrs { unless( ! DBIx::Class::_ENV_::OLD_MRO and - ${^TAINT} + DBIx::Class::_ENV_::TAINT_MODE ) { #local $TODO = "On 5.10+ -T combined with stash peeking invalidates the pkg_gen (wtf)" if ... diff --git a/xt/extra/internals/namespaces_cleaned.t b/xt/extra/internals/namespaces_cleaned.t index 700a90801..2230957d2 100644 --- a/xt/extra/internals/namespaces_cleaned.t +++ b/xt/extra/internals/namespaces_cleaned.t @@ -39,45 +39,14 @@ use Test::More; use DBICTest; use File::Find; -use File::Spec; use DBIx::Class::_Util qw( get_subname describe_class_methods ); # makes sure we can load at least something use DBIx::Class; use DBIx::Class::Carp; -my @modules = map { - # FIXME: AS THIS IS CLEARLY A LACK OF DEFENSE IN describe_class_methods :FIXME - # FIXME !!! without this detaint I get the test into an infloop on 5.16.x - # (maybe other versions): https://travis-ci.org/ribasushi/dbix-class/jobs/144738784#L26762 - # - # or locally like: - # - # ~$ ulimit -v $(( 1024 * 256 )); perl -d:Confess -Ilib -Tl xt/extra/internals/namespaces_cleaned.t - # ... - # DBIx::Class::MethodAttributes::_attr_cache("DBIx::Class::Storage::DBI::ODBC::Firebird") called at lib/DBIx/Class/MethodAttributes.pm line 166 - # DBIx::Class::MethodAttributes::_attr_cache("DBIx::Class::Storage::DBI::ODBC::Firebird") called at lib/DBIx/Class/MethodAttributes.pm line 166 - # DBIx::Class::MethodAttributes::_attr_cache("DBIx::Class::Storage::DBI::ODBC::Firebird") called at lib/DBIx/Class/MethodAttributes.pm line 166 - # DBIx::Class::MethodAttributes::_attr_cache("DBIx::Class::Storage::DBI::ODBC::Firebird") called at lib/DBIx/Class/MethodAttributes.pm line 154 - # DBIx::Class::MethodAttributes::FETCH_CODE_ATTRIBUTES("DBIx::Class::Storage::DBI::ODBC::Firebird", CODE(0x42ac2b0)) called at /home/rabbit/perl5/perlbrew/perls/5.16.2/lib/5.16.2/x86_64-linux-thread-multi-ld/attributes.pm line 101 - # attributes::get(CODE(0x42ac2b0)) called at lib/DBIx/Class/_Util.pm line 885 - # eval {...} called at lib/DBIx/Class/_Util.pm line 885 - # DBIx::Class::_Util::describe_class_methods("DBIx::Class::Storage::DBI::ODBC::Firebird") called at xt/extra/internals/namespaces_cleaned.t line 129 - # Out of memory! - # Out of memory! - # Out of memory! - # ... - # Segmentation fault - # - # FIXME: AS THIS IS CLEARLY A LACK OF DEFENSE IN describe_class_methods :FIXME - # Sweeping it under the rug for now as this is an xt/ test, - # but someone *must* find what is going on eventually - # FIXME: AS THIS IS CLEARLY A LACK OF DEFENSE IN describe_class_methods :FIXME - - ( $_ =~ /(.+)/ ) - -} grep { - my ($mod) = $_ =~ /(.+)/; +my @modules = grep { + my $mod = $_; # not all modules are loadable at all times do { @@ -218,7 +187,8 @@ sub find_modules { $_ =~ m|lib/DBIx/Class/_TempExtlib| and return; s/\.pm$// or return; s/^ (?: lib | blib . (?:lib|arch) ) . //x; - push @modules, join ('::', File::Spec->splitdir($_)); + s/[\/\\]/::/g; + push @modules, ( $_ =~ /(.+)/ ); }, no_chdir => 1, }, ( From 6de819183a4d44d0bf0a7f9db9e62efe3cf020a6 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 16 Jul 2016 13:48:52 +0200 Subject: [PATCH 180/262] Add an explicit Sub::Quote dep in ::_Util Failures too confusing otherwise --- lib/DBIx/Class/_Util.pm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 6a93f65b4..f86be002e 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -175,10 +175,17 @@ use B (); use Carp 'croak'; use Storable 'nfreeze'; use Scalar::Util qw(weaken blessed reftype refaddr); -use Sub::Quote qw(qsub); use Sub::Name (); use attributes (); +# Usually versions are not specified anywhere aside the Makefile.PL +# (writing them out in-code is extremely obnoxious) +# However without a recent enough Moo the quote_sub override fails +# in very puzzling and hard to detect ways: so add a version check +# just this once +use Sub::Quote qw(qsub); +BEGIN { Sub::Quote->VERSION('2.002002') } + # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone' BEGIN { *deep_clone = \&Storable::dclone } From e10d9d292bb2b14a31b45f36bd25b6610bd2e71d Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 16 Jul 2016 13:52:00 +0200 Subject: [PATCH 181/262] Restore TODO checking for Taint + pkg_gen inconsitencies Now that https://github.com/Test-More/test-more/issues/683 we can bring the TODO back - will get an alert for an eventual fix... --- xt/extra/internals/describe_class_methods.t | 24 +++++++++++++++------ 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/xt/extra/internals/describe_class_methods.t b/xt/extra/internals/describe_class_methods.t index 5d7217b4e..1177ac8de 100644 --- a/xt/extra/internals/describe_class_methods.t +++ b/xt/extra/internals/describe_class_methods.t @@ -28,6 +28,7 @@ use Test::Exception; use DBIx::Class::_Util qw( quote_sub describe_class_methods serialize refdesc sigwarn_silencer + modver_gt_or_eq_and_lt ); use List::Util 'shuffle'; use Errno (); @@ -461,14 +462,23 @@ sub add_more_attrs { 'describing with explicit mro returns correct data' ); - # FIXME: TODO does not work on new T::B under threads sigh - # https://github.com/Test-More/test-more/issues/683 - unless( - ! DBIx::Class::_ENV_::OLD_MRO - and - DBIx::Class::_ENV_::TAINT_MODE + if ( + DBIx::Class::_ENV_::OLD_MRO + or + ! DBIx::Class::_ENV_::TAINT_MODE + or + ! $INC{"threads.pm"} + or + # $TODO did not work on T::B under threads in this range + # https://github.com/Test-More/test-more/issues/683 + ! modver_gt_or_eq_and_lt( 'Test::More', '1.300', '1.302027' ) ) { - #local $TODO = "On 5.10+ -T combined with stash peeking invalidates the pkg_gen (wtf)" if ... + local $TODO = "On 5.10+ -T combined with stash peeking invalidates the pkg_gen (wtf)" + if + DBIx::Class::_ENV_::TAINT_MODE + and + DBIx::Class::_ENV_::PERL_VERSION > 5.009 + ; ok( ( From c8215e2c5a1ae25191d4a7f6bcf7a3a1f89d6970 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 16 Jul 2016 13:59:30 +0200 Subject: [PATCH 182/262] Fix error-eating thinko from 6c7ca962 $@ is not visible in $SIG{__DIE__} --- t/00describe_environment.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/t/00describe_environment.t b/t/00describe_environment.t index 87b4697b8..fc1c6942e 100644 --- a/t/00describe_environment.t +++ b/t/00describe_environment.t @@ -51,7 +51,7 @@ use Test::More 'no_plan'; # Things happen... unfortunately $SIG{__DIE__} = sub { - die unless defined $^S and ! $^S; + die $_[0] unless defined $^S and ! $^S; diag "Something horrible happened while assembling the diag data\n$_[0]"; exit 0; From cc782be296444e609006f1bf8ea502e6f22a7d8d Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 20 Jul 2016 12:17:49 +0200 Subject: [PATCH 183/262] Fix false negatives in lean_startup.t Before this commit a 'use Devel::Dwarn' somewhere deep in e.g. ::SQLMaker would *not* have been detected. Also fix improperly applied C-ism: the following decidedly does not DTRT do 1 while { ... } I never noticed this being a problem until a fatfingered `>&1` turned into a `>1`, which in turn created a file named 1 in the current directory with garbage in it, which *in turn* the `do 1 ...` tried to execute. Sigh... --- xt/extra/lean_startup.t | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index c5ed8ccb3..435a5ba1a 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -29,7 +29,7 @@ BEGIN { # exclude our test suite, known "module require-rs" and eval frames $caller[1] =~ / (?: \A | [\/\\] ) x?t [\/\\] /x or - $caller[0] =~ /^ (?: base | parent | Class::C3::Componentised | Module::Inspector | Module::Runtime ) $/x + $caller[0] =~ /^ (?: base | parent | Class::C3::Componentised | Module::Inspector | Module::Runtime | DBIx::Class::Optional::Dependencies ) $/x or $caller[3] eq '(eval)', ) @@ -45,8 +45,6 @@ BEGIN { # the namespace, the shim thinks DBIC* tried to require this return $res if $req =~ /^v?[0-9.]+$/; - # exclude everything where the current namespace does not match the called function - # (this works around very weird XS-induced require callstack corruption) if ( !$initial_inc_contents->{$req} and @@ -55,19 +53,28 @@ BEGIN { @caller and $caller[0] =~ /^DBIx::Class/ - and - (CORE::caller($up))[3] =~ /\Q$caller[0]/ ) { local $stack{neutralize_override} = 1; - do 1 while CORE::caller(++$up); + # find last-most frame, to feed to T::B below + while( CORE::caller(++$up) ) { 1 } require('Test/More.pm'); local $Test::Builder::Level = $up + 1; + + # work around the trainwreck that is https://github.com/doy/package-stash-xs/pull/4 + local $::TODO = 'sigh' if ( + $INC{'Package/Stash/XS.pm'} + and + $req eq 'utf8' + ); + Test::More::fail ("Unexpected require of '$req' by $caller[0] ($caller[1] line $caller[2])"); - require('DBICTest/Util.pm'); - Test::More::diag( 'Require invoked' . DBICTest::Util::stacktrace() ); + unless( $::TODO ) { + require('DBICTest/Util.pm'); + Test::More::diag( 'Require invoked' . DBICTest::Util::stacktrace() ); + } } return $res; @@ -143,6 +150,11 @@ BEGIN { Class::C3::Componentised )); + # load Storable ourselves here - there are too many + # variations with DynaLoader and XSLoader making testing + # for it rather unstable + require Storable; + require DBIx::Class::Schema; assert_no_missing_expected_requires(); } From a8eaf44b3d65c08780571a811059e4b43b81ef6b Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 20 Jul 2016 14:13:49 +0200 Subject: [PATCH 184/262] Fix misleading error on deployment_statements in void ctx Due to how Context::Preserve operates the following would result in a non-sensical error: perl -MDBIx::Class::Schema -e ' DBIx::Class::Schema->connect("dbi:SQLite::memory:")->deployment_statements; 1 ' --- lib/DBIx/Class.pm | 12 ++++++++++-- lib/DBIx/Class/Storage/DBI.pm | 5 +++++ 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index 474d964ee..fe27d47d2 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -23,8 +23,16 @@ use mro 'c3'; use base qw/DBIx::Class::Componentised DBIx::Class::AccessorGroup/; use DBIx::Class::Exception; -__PACKAGE__->mk_classaccessor( _skip_namespace_frames => - '^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve|^Moose::Meta::' +__PACKAGE__->mk_classaccessor( + _skip_namespace_frames => join( '|', map { '^' . $_ } qw( + DBIx::Class + SQL::Abstract + SQL::Translator + Try::Tiny + Class::Accessor::Grouped + Context::Preserve + Moose::Meta:: + )), ); sub component_base_class { 'DBIx::Class' } diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 132c8d4e6..2734385bf 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -3107,6 +3107,11 @@ See L for a list of values for C<$sqlt_args>. sub deployment_statements { my ($self, $schema, $type, $version, $dir, $sqltargs) = @_; + + $self->throw_exception( + 'Calling deployment_statements() in void context makes no sense' + ) unless defined wantarray; + $type ||= $self->sqlt_type; $version ||= $schema->schema_version || '1.x'; $dir ||= './'; From 20c0d57b670cd7b739b8f8a6a72223b1eb53e531 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 22 Jul 2016 14:15:53 +0200 Subject: [PATCH 185/262] Abstract our internal capture_stderr test routine Will need it for even more tests later on, but not sufficiently often to warrant depending on Capture::Tiny - just go with what we need --- t/35exception_inaction.t | 31 ++++++------------------------- t/36double_destroy.t | 24 +++--------------------- t/lib/DBICTest/Util.pm | 32 +++++++++++++++++++++++++++++++- 3 files changed, 40 insertions(+), 47 deletions(-) diff --git a/t/35exception_inaction.t b/t/35exception_inaction.t index 0f775f402..6c032d681 100644 --- a/t/35exception_inaction.t +++ b/t/35exception_inaction.t @@ -12,9 +12,7 @@ BEGIN { } } -use DBICTest::Util 'tmpdir'; -use File::Temp (); -use DBIx::Class::_Util 'scope_guard'; +use DBICTest::Util 'capture_stderr'; use DBIx::Class::Schema; # Do not use T::B - the test is hard enough not to segfault as it is @@ -41,34 +39,17 @@ sub ok { return !!$_[0]; } -# yes, make it even dirtier -my $schema = 'DBIx::Class::Schema'; - -$schema->connection('dbi:SQLite::memory:'); # this is incredibly horrible... # demonstrate utter breakage of the reconnection/retry logic # -open(my $stderr_copy, '>&', *STDERR) or die "Unable to dup STDERR: $!"; -my $tf = File::Temp->new( UNLINK => 1, DIR => tmpdir() ); - -my $output; - +my $output = capture_stderr { ESCAPE: { - my $guard = scope_guard { - close STDERR; - open(STDERR, '>&', $stderr_copy); - $output = do { local (@ARGV, $/) = $tf; <> }; - close $tf; - unlink $tf; - undef $tf; - close $stderr_copy; - }; - - close STDERR; - open(STDERR, '>&', $tf) or die "Unable to reopen STDERR: $!"; + # yes, make it even dirtier + my $schema = 'DBIx::Class::Schema'; + $schema->connection('dbi:SQLite::memory:'); $schema->storage->ensure_connected; $schema->storage->_dbh->disconnect; @@ -88,7 +69,7 @@ ESCAPE: # NEITHER will this ok(0, "Nope"); -} +}}; ok(1, "Post-escape reached"); diff --git a/t/36double_destroy.t b/t/36double_destroy.t index f070d142c..8fc4cb706 100644 --- a/t/36double_destroy.t +++ b/t/36double_destroy.t @@ -4,16 +4,11 @@ use strict; use warnings; use Test::More; -use File::Temp (); -use DBICTest::Util 'tmpdir'; -use DBIx::Class::_Util 'scope_guard'; +use DBICTest::Util 'capture_stderr'; use DBICTest; -open(my $stderr_copy, '>&', *STDERR) or die "Unable to dup STDERR: $!"; -my $tf = File::Temp->new( UNLINK => 1, DIR => tmpdir() ); - my $output; # ensure Devel::StackTrace-refcapture-like effects are countered @@ -35,22 +30,9 @@ my $output; 1; } - my $guard = scope_guard { - close STDERR; - open(STDERR, '>&', $stderr_copy); - $output = do { local (@ARGV, $/) = $tf; <> }; - close $tf; - unlink $tf; - undef $tf; - close $stderr_copy; - }; - - close STDERR; - open(STDERR, '>&', $tf) or die "Unable to reopen STDERR: $!"; - # this should emit on stderr - @arg_capture = (); -} + $output = capture_stderr { @arg_capture = () }; +}; like( $output, diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 1529f90d5..7aeb805a0 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -41,7 +41,7 @@ use base 'Exporter'; our @EXPORT_OK = qw( dbg stacktrace class_seems_loaded local_umask slurp_bytes tmpdir find_co_root rm_rf - PEEPEENESS + capture_stderr PEEPEENESS check_customcond_args await_flock DEBUG_TEST_CONCURRENCY_LOCKS ); @@ -273,6 +273,36 @@ EOE }; } +sub capture_stderr (&) { + open(my $stderr_copy, '>&', *STDERR) or croak "Unable to dup STDERR: $!"; + + require File::Temp; + my $tf = File::Temp->new( UNLINK => 1, DIR => tmpdir() ); + + my $err_out; + + { + my $guard = scope_guard { + close STDERR; + + open(STDERR, '>&', $stderr_copy) or do { + my $msg = "\n\nPANIC!!!\nFailed restore of STDERR: $!\n"; + print $stderr_copy $msg; + print STDOUT $msg; + die; + }; + + close $stderr_copy; + }; + + close STDERR; + open( STDERR, '>&', $tf ); + + $_[0]->(); + } + + slurp_bytes( "$tf" ); +} sub slurp_bytes ($) { croak "Expecting a file name, not a filehandle" if openhandle $_[0]; From d46eac43287ebe244e4f622fb77fa2efa16402a9 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 25 Apr 2016 11:53:54 +0200 Subject: [PATCH 186/262] Rename variables/shuffle some code, preparing for next commits Zero functional changes Read under -w --- lib/DBIx/Class/AccessorGroup.pm | 27 ++++---- lib/DBIx/Class/Relationship/Accessor.pm | 27 +++++--- lib/DBIx/Class/Relationship/ManyToMany.pm | 25 ++++---- lib/DBIx/Class/ResultSourceProxy.pm | 11 ++-- lib/DBIx/Class/ResultSourceProxy/Table.pm | 29 +++++---- lib/DBIx/Class/Schema.pm | 77 +++++++++++++---------- 6 files changed, 108 insertions(+), 88 deletions(-) diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index 0ae4b5bde..c76a4564d 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -6,7 +6,7 @@ use warnings; use base qw( DBIx::Class::MethodAttributes Class::Accessor::Grouped ); use mro 'c3'; -use Scalar::Util qw/weaken blessed/; +use Scalar::Util 'blessed'; use DBIx::Class::_Util 'fail_on_internal_call'; use namespace::clean; @@ -24,24 +24,27 @@ sub mk_classaccessor { ; } -my $successfully_loaded_components; - sub get_component_class { my $class = $_[0]->get_inherited($_[1]); - # It's already an object, just go for it. - return $class if blessed $class; - - if (defined $class and ! $successfully_loaded_components->{$class} ) { + no strict 'refs'; + if ( + defined $class + and + # inherited CAG can't be set to undef effectively, so people may use '' + length $class + and + # It's already an object, just go for it. + ! defined blessed $class + and + ! ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} + ) { $_[0]->ensure_class_loaded($class); mro::set_mro( $class, 'c3' ); - no strict 'refs'; - $successfully_loaded_components->{$class} - = ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} - = do { \(my $anon = 'loaded') }; - weaken($successfully_loaded_components->{$class}); + ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} + = do { \(my $anon = 'loaded') }; } $class; diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index 025ab2466..d281e00ca 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -24,7 +24,9 @@ sub add_relationship_accessor { my ($class, $rel, $acc_type) = @_; if ($acc_type eq 'single') { + quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel); + my $self = shift; if (@_) { @@ -62,12 +64,13 @@ sub add_relationship_accessor { EOC } elsif ($acc_type eq 'filter') { - $class->throw_exception("No such column '$rel' to filter") - unless $class->result_source_instance->has_column($rel); - my $f_class = $class->result_source_instance - ->relationship_info($rel) - ->{class}; + my $rsrc = $class->result_source_instance; + + $rsrc->throw_exception("No such column '$rel' to filter") + unless $rsrc->has_column($rel); + + my $f_class = $rsrc->relationship_info($rel)->{class}; $class->inflate_column($rel, { inflate => sub { @@ -100,21 +103,25 @@ EOC } elsif ($acc_type eq 'multi') { + + quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel ); + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; + shift->related_resultset(%s)->search( @_ ) +EOC + + quote_sub "${class}::${rel}_rs", sprintf( <<'EOC', perlstring $rel ); DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; shift->related_resultset(%s)->search_rs( @_ ) EOC + quote_sub "${class}::add_to_${rel}", sprintf( <<'EOC', perlstring $rel ); DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; shift->create_related( %s => @_ ); EOC - quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel ); - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; - shift->related_resultset(%s)->search( @_ ) -EOC } else { $class->throw_exception("No such relationship accessor type '$acc_type'"); diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm index c7cde16d7..0c31ebba9 100644 --- a/lib/DBIx/Class/Relationship/ManyToMany.pm +++ b/lib/DBIx/Class/Relationship/ManyToMany.pm @@ -56,11 +56,23 @@ EOW } } + quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ); + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; + + my $rs = shift->%s( @_ ); + + wantarray ? $rs->all : $rs; +EOC + + my $qsub_attrs = { '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } }, '$carp_unique' => \$cu, }; + quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', map { perlstring $_ } ( "${class}::${meth}", $rel, $f_rel ) ), $qsub_attrs; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS @@ -84,17 +96,6 @@ EOW EOC - quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ); - - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; - - my $rs = shift->%s( @_ ); - - wantarray ? $rs->all : $rs; -EOC - - quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), $qsub_attrs; ( @_ >= 2 and @_ <= 3 ) or $_[0]->throw_exception( @@ -109,7 +110,7 @@ EOC my $guard; - # the API needs is always expected to return the far object, possibly + # the API is always expected to return the far object, possibly # creating it in the process if( not defined Scalar::Util::blessed( $far_obj ) ) { diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm index 94009a5a0..0f5e9d97c 100644 --- a/lib/DBIx/Class/ResultSourceProxy.pm +++ b/lib/DBIx/Class/ResultSourceProxy.pm @@ -7,21 +7,18 @@ use warnings; use base 'DBIx::Class'; use mro 'c3'; -use Scalar::Util 'blessed'; use DBIx::Class::_Util qw( quote_sub fail_on_internal_call ); use namespace::clean; __PACKAGE__->mk_group_accessors('inherited_ro_instance' => 'source_name'); -sub get_inherited_ro_instance { shift->get_inherited(@_) } +sub get_inherited_ro_instance { $_[0]->get_inherited($_[1]) } sub set_inherited_ro_instance { - my $self = shift; + $_[0]->throw_exception ("Cannot set '$_[1]' on an instance") + if length ref $_[0]; - $self->throw_exception ("Cannot set @{[shift]} on an instance") - if blessed $self; - - $self->set_inherited(@_); + $_[0]->set_inherited( $_[1], $_[2] ); } diff --git a/lib/DBIx/Class/ResultSourceProxy/Table.pm b/lib/DBIx/Class/ResultSourceProxy/Table.pm index d6bac68f4..c165f7702 100644 --- a/lib/DBIx/Class/ResultSourceProxy/Table.pm +++ b/lib/DBIx/Class/ResultSourceProxy/Table.pm @@ -9,8 +9,8 @@ use DBIx::Class::ResultSource::Table; use Scalar::Util 'blessed'; use namespace::clean; +# FIXME - both of these *PROBABLY* need to be 'inherited_ro_instance' type __PACKAGE__->mk_classaccessor(table_class => 'DBIx::Class::ResultSource::Table'); - # FIXME: Doesn't actually do anything yet! __PACKAGE__->mk_group_accessors( inherited => 'table_alias' ); @@ -20,32 +20,32 @@ sub _init_result_source_instance { $class->mk_group_accessors( inherited => 'result_source_instance' ) unless $class->can('result_source_instance'); - my $table = $class->result_source_instance; - return $table - if $table and $table->result_class eq $class; + # might be pre-made for us courtesy of DBIC::DB::result_source_instance() + my $rsrc = $class->result_source_instance; + + return $rsrc + if $rsrc and $rsrc->result_class eq $class; my $table_class = $class->table_class; $class->ensure_class_loaded($table_class); - if( $table ) { - $table = $table_class->new({ - %$table, + if( $rsrc ) { + $rsrc = $table_class->new({ + %$rsrc, result_class => $class, source_name => undef, schema => undef }); } else { - $table = $table_class->new({ + $rsrc = $table_class->new({ name => undef, result_class => $class, source_name => undef, }); } - $class->result_source_instance($table); - - return $table; + $class->result_source_instance($rsrc); } =head1 NAME @@ -78,8 +78,9 @@ Gets or sets the table name. =cut sub table { + return $_[0]->result_source_instance->name unless @_ > 1; + my ($class, $table) = @_; - return $class->result_source_instance->name unless $table; unless (blessed $table && $table->isa($class->table_class)) { @@ -99,9 +100,7 @@ sub table { $class->mk_group_accessors(inherited => 'result_source_instance') unless $class->can('result_source_instance'); - $class->result_source_instance($table); - - return $class->result_source_instance->name; + $class->result_source_instance($table)->name; } =head2 table_class diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 702d472c3..5b9d07c5d 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -616,21 +616,21 @@ source name. =cut sub source { - my $self = shift; + my ($self, $source_name) = @_; $self->throw_exception("source() expects a source name") - unless @_; - - my $source_name = shift; + unless $source_name; - my $sreg = $self->source_registrations; - return $sreg->{$source_name} if exists $sreg->{$source_name}; + my $source_registrations; - # if we got here, they probably passed a full class name - my $mapped = $self->class_mappings->{$source_name}; - $self->throw_exception("Can't find source for ${source_name}") - unless $mapped && exists $sreg->{$mapped}; - return $sreg->{$mapped}; + my $rsrc = + ( $source_registrations = $self->source_registrations )->{$source_name} + || + # if we got here, they probably passed a full class name + $source_registrations->{ $self->class_mappings->{$source_name} || '' } + || + $self->throw_exception( "Can't find source for ${source_name}" ) + ; } =head2 class @@ -1410,41 +1410,54 @@ has a source and you want to register an extra one. sub register_extra_source { shift->_register_source(@_, { extra => 1 }) } sub _register_source { - my ($self, $source_name, $source, $params) = @_; + my ($self, $source_name, $supplied_rsrc, $params) = @_; + + my $derived_rsrc = $supplied_rsrc->new({ + %$supplied_rsrc, + source_name => $source_name, + }); - $source = $source->new({ %$source, source_name => $source_name }); + # Do not move into the clone-hashref above: there are things + # on CPAN that do hook 'sub schema' + # https://metacpan.org/source/LSAUNDERS/DBIx-Class-Preview-1.000003/lib/DBIx/Class/ResultSource/Table/Previewed.pm#L9-38 + $derived_rsrc->schema($self); - $source->schema($self); - weaken $source->{schema} if ref($self); + weaken $derived_rsrc->{schema} + if length ref($self); my %reg = %{$self->source_registrations}; - $reg{$source_name} = $source; + $reg{$source_name} = $derived_rsrc; $self->source_registrations(\%reg); - return $source if $params->{extra}; + return $derived_rsrc if $params->{extra}; - my $rs_class = $source->result_class; - if ($rs_class and my $rsrc = dbic_internal_try { $rs_class->result_source_instance } ) { + my( $result_class, $result_class_level_rsrc ); + if ( + $result_class = $derived_rsrc->result_class + and + # There are known cases where $rs_class is *ONLY* an inflator, without + # any hint of a rsrc (e.g. DBIx::Class::KiokuDB::EntryProxy) + $result_class_level_rsrc = dbic_internal_try { $result_class->result_source_instance } + ) { my %map = %{$self->class_mappings}; - if ( - exists $map{$rs_class} + + carp ( + "$result_class already had a registered source which was replaced by " + . 'this call. Perhaps you wanted register_extra_source(), though it is ' + . 'more likely you did something wrong.' + ) if ( + exists $map{$result_class} and - $map{$rs_class} ne $source_name + $map{$result_class} ne $source_name and - $rsrc ne $_[2] # orig_source - ) { - carp - "$rs_class already had a registered source which was replaced by this call. " - . 'Perhaps you wanted register_extra_source(), though it is more likely you did ' - . 'something wrong.' - ; - } + $result_class_level_rsrc != $supplied_rsrc + ); - $map{$rs_class} = $source_name; + $map{$result_class} = $source_name; $self->class_mappings(\%map); } - return $source; + $derived_rsrc; } my $global_phase_destroy; From 7648acb5dd1f2f281ca84e2152efe314bcbf2c70 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 13 Jul 2016 15:45:37 +0200 Subject: [PATCH 187/262] Revert C3-fication d009cb7d and fixups 7f068248 and 983f766d While on its surface this was a good idea, it actually hides problems even more: by the time we arrive at a useful hook-point to check the current MRO, something likely already changed it from under us, and the old effects are all masked away for good. So instead scale back as much as possible, and set 'c3' where needed as lazily as practical. In order to satisfy the mro requirements imposed by 5e0eea35 we do the "flip" during the ->source() stage. Additionally we record the original setting any time we switch the mro on foreign classes (two such spots in the codebase). A later commit will use this information to add the final bit of sanity to this clusterfuck. --- lib/DBIx/Class/AccessorGroup.pm | 3 -- lib/DBIx/Class/Componentised.pm | 9 ---- lib/DBIx/Class/MethodAttributes.pm | 1 - lib/DBIx/Class/ResultSet.pm | 1 - lib/DBIx/Class/ResultSource.pm | 1 - lib/DBIx/Class/ResultSource/RowParser.pm | 1 - lib/DBIx/Class/ResultSource/Table.pm | 1 - lib/DBIx/Class/ResultSource/View.pm | 1 - lib/DBIx/Class/ResultSourceProxy.pm | 1 - lib/DBIx/Class/Schema.pm | 38 ++++++++++++++- lib/DBIx/Class/Storage/DBI.pm | 12 ++++- xt/extra/c3_mro.t | 60 +++++++++++------------- 12 files changed, 76 insertions(+), 53 deletions(-) diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index c76a4564d..77cf85255 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -4,7 +4,6 @@ use strict; use warnings; use base qw( DBIx::Class::MethodAttributes Class::Accessor::Grouped ); -use mro 'c3'; use Scalar::Util 'blessed'; use DBIx::Class::_Util 'fail_on_internal_call'; @@ -41,8 +40,6 @@ sub get_component_class { ) { $_[0]->ensure_class_loaded($class); - mro::set_mro( $class, 'c3' ); - ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} = do { \(my $anon = 'loaded') }; } diff --git a/lib/DBIx/Class/Componentised.pm b/lib/DBIx/Class/Componentised.pm index 3adea571f..b417de6bb 100644 --- a/lib/DBIx/Class/Componentised.pm +++ b/lib/DBIx/Class/Componentised.pm @@ -13,9 +13,6 @@ use namespace::clean; # this warns of subtle bugs introduced by UTF8Columns hacky handling of store_column # if and only if it is placed before something overriding store_column -# -# and also enforces C3 mro on all components -my $mro_already_set; sub inject_base { my $class = shift; my ($target, @complist) = @_; @@ -75,12 +72,6 @@ sub inject_base { unshift @target_isa, $comp; } - # only examine from $_[2] onwards - # C::C3::C already sets c3 on $_[1] - mro::set_mro( $_ => 'c3' ) for grep { - $mro_already_set->{$_} ? 0 : ( $mro_already_set->{$_} = 1 ) - } @_[1 .. $#_]; - $class->next::method(@_); } diff --git a/lib/DBIx/Class/MethodAttributes.pm b/lib/DBIx/Class/MethodAttributes.pm index 1b50ac9f4..7ffe56095 100644 --- a/lib/DBIx/Class/MethodAttributes.pm +++ b/lib/DBIx/Class/MethodAttributes.pm @@ -6,7 +6,6 @@ use warnings; use DBIx::Class::_Util qw( uniq refdesc visit_namespaces ); use Scalar::Util qw( weaken refaddr ); -use mro 'c3'; use namespace::clean; my ( $attr_cref_registry, $attr_cache_active ); diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 6dbc7caec..2c5131d7a 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -4,7 +4,6 @@ use strict; use warnings; use base 'DBIx::Class'; -use mro 'c3'; use DBIx::Class::Carp; use DBIx::Class::ResultSetColumn; diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index a7645ef9b..f6e3923cd 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -4,7 +4,6 @@ use strict; use warnings; use base 'DBIx::Class::ResultSource::RowParser'; -use mro 'c3'; use DBIx::Class::Carp; use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try fail_on_internal_call ); diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index aff2b8148..676a54896 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -5,7 +5,6 @@ use strict; use warnings; use base 'DBIx::Class'; -use mro 'c3'; use Try::Tiny; diff --git a/lib/DBIx/Class/ResultSource/Table.pm b/lib/DBIx/Class/ResultSource/Table.pm index e1dcc03ca..450be9a56 100644 --- a/lib/DBIx/Class/ResultSource/Table.pm +++ b/lib/DBIx/Class/ResultSource/Table.pm @@ -4,7 +4,6 @@ use strict; use warnings; use base 'DBIx::Class::ResultSource'; -use mro 'c3'; =head1 NAME diff --git a/lib/DBIx/Class/ResultSource/View.pm b/lib/DBIx/Class/ResultSource/View.pm index 59957902c..33398267b 100644 --- a/lib/DBIx/Class/ResultSource/View.pm +++ b/lib/DBIx/Class/ResultSource/View.pm @@ -4,7 +4,6 @@ use strict; use warnings; use base 'DBIx::Class::ResultSource'; -use mro 'c3'; __PACKAGE__->mk_group_accessors( 'simple' => qw(is_virtual view_definition deploy_depends_on) ); diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm index 0f5e9d97c..5f4bbe3d0 100644 --- a/lib/DBIx/Class/ResultSourceProxy.pm +++ b/lib/DBIx/Class/ResultSourceProxy.pm @@ -5,7 +5,6 @@ use strict; use warnings; use base 'DBIx::Class'; -use mro 'c3'; use DBIx::Class::_Util qw( quote_sub fail_on_internal_call ); use namespace::clean; diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 5b9d07c5d..f19c7bcc0 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -4,7 +4,6 @@ use strict; use warnings; use base 'DBIx::Class'; -use mro 'c3'; use DBIx::Class::Carp; use Try::Tiny; @@ -631,6 +630,43 @@ sub source { || $self->throw_exception( "Can't find source for ${source_name}" ) ; + + # DO NOT REMOVE: + # We need to prevent alterations of pre-existing $@ due to where this call + # sits in the overall stack ( *unless* of course there is an actual error + # to report ). set_mro does alter $@ (and yes - it *can* throw an exception) + # We do not use local because set_mro *can* throw an actual exception + # We do not use a try/catch either, as on one hand it would slow things + # down for no reason (we would always rethrow), but also because adding *any* + # try/catch block below will segfault various threading tests on older perls + # ( which in itself is a FIXME but ENOTIMETODIG ) + my $old_dollarat = $@; + + no strict 'refs'; + mro::set_mro($_, 'c3') for + grep + { + # some pseudo-sources do not have a result/resultset yet + defined $_ + and + ( + ( + ${"${_}::__INITIAL_MRO_UPON_DBIC_LOAD__"} + ||= mro::get_mro($_) + ) + ne + 'c3' + ) + } + map + { length ref $_ ? ref $_ : $_ } + ( $rsrc, $rsrc->result_class, $rsrc->resultset_class ) + ; + + # DO NOT REMOVE - see comment above + $@ = $old_dollarat; + + $rsrc; } =head2 class diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 2734385bf..9da3bd9ba 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -1321,7 +1321,17 @@ sub _determine_driver { if ($driver) { my $storage_class = "DBIx::Class::Storage::DBI::${driver}"; if ($self->load_optional_class($storage_class)) { - mro::set_mro($storage_class, 'c3'); + + no strict 'refs'; + mro::set_mro($storage_class, 'c3') if + ( + ${"${storage_class}::__INITIAL_MRO_UPON_DBIC_LOAD__"} + ||= mro::get_mro($storage_class) + ) + ne + 'c3' + ; + bless $self, $storage_class; $self->_rebless(); } diff --git a/xt/extra/c3_mro.t b/xt/extra/c3_mro.t index 398f51e48..fa63e0c3f 100644 --- a/xt/extra/c3_mro.t +++ b/xt/extra/c3_mro.t @@ -6,6 +6,7 @@ use strict; use Test::More; use DBICTest; use DBIx::Class::Optional::Dependencies; +use DBIx::Class::_Util 'uniq'; my @global_ISA_tail = qw( DBIx::Class @@ -16,16 +17,11 @@ my @global_ISA_tail = qw( Class::Accessor::Grouped ); -is( - mro::get_mro($_), - 'c3', - "Correct mro on base class '$_'", -) for grep { $_ =~ /^DBIx::Class/ } @global_ISA_tail; - { package AAA; use base "DBIx::Class::Core"; + use mro 'c3'; } { @@ -55,23 +51,27 @@ ok (! $@, "Correctly skipped injecting an indirect parent of class BBB"); my $art = DBICTest->init_schema->resultset("Artist")->next; -check_ancestry($_) for ( - ref( $art ), - ref( $art->result_source ), - ref( $art->result_source->resultset ), - ref( $art->result_source->schema ), - ( map - { ref $art->result_source->schema->source($_) } - $art->result_source->schema->sources - ), - qw( AAA BBB CCC ), - ((! DBIx::Class::Optional::Dependencies->req_ok_for('cdbicompat') ) ? () : do { - unshift @INC, 't/cdbi/testlib'; - map { eval "require $_" or die $@; $_ } qw( - Film Lazy Actor ActorAlias ImplicitInflate - ); - }), -); +check_ancestry($_) for uniq map + { length ref $_ ? ref $_ : $_ } + ( + $art, + $art->result_source, + $art->result_source->resultset, + ( map + { $_, $_->result_class, $_->resultset_class } + map + { $art->result_source->schema->source($_) } + $art->result_source->schema->sources + ), + qw( AAA BBB CCC ), + ((! DBIx::Class::Optional::Dependencies->req_ok_for('cdbicompat') ) ? () : do { + unshift @INC, 't/cdbi/testlib'; + map { eval "require $_" or die $@; $_ } qw( + Film Lazy Actor ActorAlias ImplicitInflate + ); + }), + ) +; use DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server; @@ -129,15 +129,11 @@ sub check_ancestry { "Correct end of \@ISA for '$class'" ); - # check the remainder - for my $c (@linear_ISA) { - # nothing to see there - next if $c =~ /^DBICTest::/; - - next if mro::get_mro($c) eq 'c3'; - - fail( "Incorrect mro '@{[ mro::get_mro($c) ]}' on '$c' (parent of '$class')" ); - } + is( + mro::get_mro($class), + 'c3', + "Expected mro on class '$class' automatically set", + ); } done_testing; From 534aff612dee17fe18831e445d464d942c27c172 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 7 Apr 2016 13:20:30 +0200 Subject: [PATCH 188/262] Add a clone method to ResultSource, switch obvious spots to it Not messing with the ::ResultSourceProxy::Table clusterfuck for now, too many things can go wrong. Instead will explicitly instrument the callsites in subsequent commits. Also add assertions this does not get routed around: such use will throw from here on out as long as one enables the necessary assert: ~$ DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE=1 perl -Ilib -MDBIx::Class -e ' bless ({}, "DBIx::Class::ResultSource") ' --- lib/DBIx/Class/DB.pm | 7 ++- lib/DBIx/Class/ResultSource.pm | 80 ++++++++++++++++++++++++++++------ lib/DBIx/Class/Schema.pm | 49 ++++++++++++--------- lib/DBIx/Class/_Util.pm | 56 ++++++++++++++++++++++++ t/zzzzzzz_perl_perf_bug.t | 2 + 5 files changed, 155 insertions(+), 39 deletions(-) diff --git a/lib/DBIx/Class/DB.pm b/lib/DBIx/Class/DB.pm index 235b6bf8e..ea4a5a6dc 100644 --- a/lib/DBIx/Class/DB.pm +++ b/lib/DBIx/Class/DB.pm @@ -222,15 +222,14 @@ sub result_source_instance { } my($source, $result_class) = @{$class->_result_source_instance}; - return unless blessed $source; + return undef unless blessed $source; if ($result_class ne $class) { # new class # Give this new class its own source and register it. - $source = $source->new({ - %$source, + $source = $source->clone( source_name => $class, result_class => $class - } ); + ); $class->_result_source_instance([$source, $class]); $class->_maybe_attach_source_to_schema($source); } diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index f6e3923cd..053b39856 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -115,20 +115,72 @@ Creates a new ResultSource object. Not normally called directly by end users. =cut -sub new { - my ($class, $attrs) = @_; - $class = ref $class if ref $class; - - my $new = bless { %{$attrs || {}} }, $class; - $new->{resultset_class} ||= 'DBIx::Class::ResultSet'; - $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} }; - $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}]; - $new->{_columns} = { %{$new->{_columns}||{}} }; - $new->{_relationships} = { %{$new->{_relationships}||{}} }; - $new->{name} ||= "!!NAME NOT SET!!"; - $new->{_columns_info_loaded} ||= 0; - $new->{sqlt_deploy_callback} ||= 'default_sqlt_deploy_hook'; - return $new; +{ + sub new { + my ($class, $attrs) = @_; + $class = ref $class if ref $class; + + my $self = bless { %{$attrs || {}} }, $class; + + + DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + and + # a constructor with 'name' as sole arg clearly isn't "inheriting" from anything + ( not ( keys(%$self) == 1 and exists $self->{name} ) ) + and + defined CORE::caller(1) + and + (CORE::caller(1))[3] !~ / ::new$ | ^ DBIx::Class :: (?: + ResultSourceProxy::Table::table + | + ResultSourceProxy::Table::_init_result_source_instance + | + ResultSource::clone + ) $ /x + and + local $Carp::CarpLevel = $Carp::CarpLevel + 1 + and + Carp::confess("Incorrect instantiation of '$self': you almost certainly wanted to call ->clone() instead"); + + + $self->{resultset_class} ||= 'DBIx::Class::ResultSet'; + $self->{name} ||= "!!NAME NOT SET!!"; + $self->{_columns_info_loaded} ||= 0; + $self->{sqlt_deploy_callback} ||= 'default_sqlt_deploy_hook'; + + $self->{$_} = { %{ $self->{$_} || {} } } + for qw( _columns _relationships resultset_attributes ); + + $self->{_ordered_columns} = [ @{ $self->{_ordered_columns} || [] } ]; + + $self; + } +} + +=head2 clone + + $rsrc_instance->clone( atribute_name => overriden_value ); + +A wrapper around L inheriting any defaults from the callee. This method +also not normally invoked directly by end users. + +=cut + +sub clone { + my $self = shift; + + $self->new({ + ( + (length ref $self) + ? %$self + : () + ), + ( + (@_ == 1 and ref $_[0] eq 'HASH') + ? %{ $_[0] } + : @_ + ), + }); } =pod diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index f19c7bcc0..153d7292f 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -957,19 +957,12 @@ sub compose_namespace { my $target_class = "${target}::${source_name}"; $self->inject_base($target_class, $orig_source->result_class, ($base || ()) ); - # register_source examines result_class, and then returns us a clone - my $new_source = $schema->register_source($source_name, bless - { %$orig_source, result_class => $target_class }, - ref $orig_source, + $schema->register_source( + $source_name, + $orig_source->clone( + result_class => $target_class + ), ); - - if ($target_class->can('result_source_instance')) { - # give the class a schema-less source copy - $target_class->result_source_instance( bless - { %$new_source, schema => ref $new_source->{schema} || $new_source->{schema} }, - ref $new_source, - ); - } } # Legacy stuff, not inserting INDIRECT assertions @@ -979,6 +972,24 @@ sub compose_namespace { Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; + # Give each composed class yet another *schema-less* source copy + # this is used for the freeze/thaw cycle + # + # This is not covered by any tests directly, but is indirectly exercised + # in t/cdbi/sweet/08pager by re-setting the schema on an existing object + # FIXME - there is likely a much cheaper way to take care of this + for my $source_name ($self->sources) { + + my $target_class = "${target}::${source_name}"; + + $target_class->result_source_instance( + $self->source($source_name)->clone( + result_class => $target_class, + schema => ( ref $schema || $schema ), + ) + ); + } + return $schema; } @@ -1083,13 +1094,10 @@ sub _copy_state_from { $self->class_mappings({ %{$from->class_mappings} }); $self->source_registrations({ %{$from->source_registrations} }); - foreach my $source_name ($from->sources) { - my $source = $from->source($source_name); - my $new = $source->new($source); - # we use extra here as we want to leave the class_mappings as they are - # but overwrite the source_registrations entry with the new source - $self->register_extra_source($source_name => $new); - } + # we use extra here as we want to leave the class_mappings as they are + # but overwrite the source_registrations entry with the new source + $self->register_extra_source( $_ => $from->source($_) ) + for $from->sources; if ($from->storage) { $self->storage($from->storage); @@ -1448,8 +1456,7 @@ sub register_extra_source { shift->_register_source(@_, { extra => 1 }) } sub _register_source { my ($self, $source_name, $supplied_rsrc, $params) = @_; - my $derived_rsrc = $supplied_rsrc->new({ - %$supplied_rsrc, + my $derived_rsrc = $supplied_rsrc->clone({ source_name => $source_name, }); diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index f86be002e..b640e7695 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -49,6 +49,7 @@ BEGIN { DBIC_SHUFFLE_UNORDERED_RESULTSETS DBIC_ASSERT_NO_INTERNAL_WANTARRAY DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS + DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE ) @@ -1078,4 +1079,59 @@ sub fail_on_internal_call { } } +if (DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE) { + + no warnings 'redefine'; + + my $next_bless = defined(&CORE::GLOBAL::bless) + ? \&CORE::GLOBAL::bless + : sub { CORE::bless($_[0], $_[1]) } + ; + + *CORE::GLOBAL::bless = sub { + my $class = (@_ > 1) ? $_[1] : CORE::caller(); + + # allow for reblessing (role application) + return $next_bless->( $_[0], $class ) + if defined blessed $_[0]; + + my $obj = $next_bless->( $_[0], $class ); + + my $calling_sub = (CORE::caller(1))[3] || ''; + + ( + # before 5.18 ->isa() will choke on the "0" package + # which we test for in several obscure cases, sigh... + !( DBIx::Class::_ENV_::PERL_VERSION < 5.018 ) + or + $class + ) + and + ( + ( + $calling_sub !~ /^ (?: + DBIx::Class::Schema::clone + | + DBIx::Class::DB::setup_schema_instance + )/x + and + $class->isa("DBIx::Class::Schema") + ) + or + ( + $calling_sub ne 'DBIx::Class::ResultSource::new' + and + $class->isa("DBIx::Class::ResultSource") + ) + ) + and + local $Carp::CarpLevel = $Carp::CarpLevel + 1 + and + Carp::confess("Improper instantiation of '$obj': you *MUST* call the corresponding constructor"); + + + $obj; + }; +} + 1; diff --git a/t/zzzzzzz_perl_perf_bug.t b/t/zzzzzzz_perl_perf_bug.t index 85dd77c1e..a9cc07f7e 100644 --- a/t/zzzzzzz_perl_perf_bug.t +++ b/t/zzzzzzz_perl_perf_bug.t @@ -6,6 +6,8 @@ use Test::More; BEGIN { + delete $ENV{DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE}; + plan skip_all => 'Skipping RH perl performance bug tests as DBIC_NO_WARN_BAD_PERL set' if ( $ENV{DBIC_NO_WARN_BAD_PERL} ); From 9e36e3eca459d22d7c768f945c891eacbc4349c0 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 13 May 2016 19:15:18 +0200 Subject: [PATCH 189/262] Fully separate parent and child resultsource metadata Ensure that all attributes are shallow-copied on "clone". Currently this means that the following are *NO LONGER* shared between rsrc clones: _unique_constraints _primaries source_info This seems just as cocky and reckless as the clusterfuck in 4006691d/RT#107462 and it most likely will have the same invisible-yet-dire consequences for various downstreams. However there is a plan in place several commits ahead allowing sidestepping the impossibility to debug a potential fallout. --- Changes | 3 +++ lib/DBIx/Class/ResultSource.pm | 23 +++++++++++++++-------- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/Changes b/Changes index c73756951..2abdb6eff 100644 --- a/Changes +++ b/Changes @@ -10,6 +10,9 @@ Revision history for DBIx::Class the maintainer believe this is safe, but this is a very complex area and reality may turn out to be different. If **ANYHTING** at all seems out of place, please file a report at once + - The unique constraint info (including the primary key columns) is no + longer shared between related (class and schema-level) ResultSource + instances - Neither exception_action() nor $SIG{__DIE__} handlers are invoked on recoverable errors. This ensures that the retry logic is fully insulated from changes in control flow, as the handlers are only diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 053b39856..4ebb4c0a8 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -16,12 +16,18 @@ use DBIx::Class::ResultSet; use namespace::clean; -__PACKAGE__->mk_group_accessors(simple => qw/ - source_name name source_info - _ordered_columns _columns _primaries _unique_constraints - _relationships resultset_attributes - column_info_from_storage sqlt_deploy_callback -/); +my @hashref_attributes = qw( + source_info resultset_attributes + _columns _unique_constraints _relationships +); +my @arrayref_attributes = qw( + _ordered_columns _primaries +); +__PACKAGE__->mk_group_accessors(simple => + @hashref_attributes, + @arrayref_attributes, + qw( source_name name column_info_from_storage sqlt_deploy_callback ), +); __PACKAGE__->mk_group_accessors(component_class => qw/ resultset_class @@ -149,9 +155,10 @@ Creates a new ResultSource object. Not normally called directly by end users. $self->{sqlt_deploy_callback} ||= 'default_sqlt_deploy_hook'; $self->{$_} = { %{ $self->{$_} || {} } } - for qw( _columns _relationships resultset_attributes ); + for @hashref_attributes; - $self->{_ordered_columns} = [ @{ $self->{_ordered_columns} || [] } ]; + $self->{$_} = [ @{ $self->{$_} || [] } ] + for @arrayref_attributes; $self; } From 0ff3368690783358903b3689a1a96ef21271f825 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 14 Apr 2016 09:27:33 +0200 Subject: [PATCH 190/262] Keep track of result source instance ancestry The oddball external registry (instead of directly-linked objects) is due to shit like 31399b48 For now this doesn't realy do anything: See several commits higher why this is needed in the first place. --- lib/DBIx/Class/ResultSource.pm | 61 ++++++++++++++++- lib/DBIx/Class/ResultSourceProxy/Table.pm | 20 ++++-- xt/extra/internals/rsrc_ancestry.t | 82 +++++++++++++++++++++++ 3 files changed, 156 insertions(+), 7 deletions(-) create mode 100644 xt/extra/internals/rsrc_ancestry.t diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 4ebb4c0a8..0a5d1fc07 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -9,7 +9,7 @@ use DBIx::Class::Carp; use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try fail_on_internal_call ); use SQL::Abstract 'is_literal_value'; use Devel::GlobalDestruction; -use Scalar::Util qw/blessed weaken isweak/; +use Scalar::Util qw( blessed weaken isweak refaddr ); # FIXME - somehow breaks ResultSetManager, do not remove until investigated use DBIx::Class::ResultSet; @@ -122,11 +122,23 @@ Creates a new ResultSource object. Not normally called directly by end users. =cut { + my $rsrc_registry; + + sub __derived_instances { + map { + (defined $_->{weakref}) + ? $_->{weakref} + : () + } values %{ $rsrc_registry->{ refaddr($_[0]) }{ derivatives } } + } + sub new { my ($class, $attrs) = @_; $class = ref $class if ref $class; - my $self = bless { %{$attrs || {}} }, $class; + my $ancestor = delete $attrs->{__derived_from}; + + my $self = bless { %$attrs }, $class; DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE @@ -149,6 +161,39 @@ Creates a new ResultSource object. Not normally called directly by end users. Carp::confess("Incorrect instantiation of '$self': you almost certainly wanted to call ->clone() instead"); + my $own_slot = $rsrc_registry->{ + my $own_addr = refaddr $self + } = { derivatives => {} }; + + weaken( $own_slot->{weakref} = $self ); + + if( + length ref $ancestor + and + my $ancestor_slot = $rsrc_registry->{ + my $ancestor_addr = refaddr $ancestor + } + ) { + + # on ancestry recording compact registry slots, prevent unbound growth + for my $r ( $rsrc_registry, map { $_->{derivatives} } values %$rsrc_registry ) { + defined $r->{$_}{weakref} or delete $r->{$_} + for keys %$r; + } + + weaken( $_->{$own_addr} = $own_slot ) for map + { $_->{derivatives} } + ( + $ancestor_slot, + (grep + { defined $_->{derivatives}{$ancestor_addr} } + values %$rsrc_registry + ), + ) + ; + } + + $self->{resultset_class} ||= 'DBIx::Class::ResultSet'; $self->{name} ||= "!!NAME NOT SET!!"; $self->{_columns_info_loaded} ||= 0; @@ -162,6 +207,16 @@ Creates a new ResultSource object. Not normally called directly by end users. $self; } + + sub DBIx::Class::__Rsrc_Ancestry_iThreads_handler__::CLONE { + for my $r ( $rsrc_registry, map { $_->{derivatives} } values %$rsrc_registry ) { + %$r = map { + defined $_->{weakref} + ? ( refaddr $_->{weakref} => $_ ) + : () + } values %$r + } + } } =head2 clone @@ -179,7 +234,7 @@ sub clone { $self->new({ ( (length ref $self) - ? %$self + ? ( %$self, __derived_from => $self ) : () ), ( diff --git a/lib/DBIx/Class/ResultSourceProxy/Table.pm b/lib/DBIx/Class/ResultSourceProxy/Table.pm index c165f7702..a1a0ce3a8 100644 --- a/lib/DBIx/Class/ResultSourceProxy/Table.pm +++ b/lib/DBIx/Class/ResultSourceProxy/Table.pm @@ -30,6 +30,10 @@ sub _init_result_source_instance { $class->ensure_class_loaded($table_class); if( $rsrc ) { + # + # NOTE! - not using clone() here and *NOT* marking source as derived + # from the one already existing on the class (if any) + # $rsrc = $table_class->new({ %$rsrc, result_class => $class, @@ -84,14 +88,22 @@ sub table { unless (blessed $table && $table->isa($class->table_class)) { + my $ancestor = $class->can('result_source_instance') + ? $class->result_source_instance + : undef + ; + my $table_class = $class->table_class; $class->ensure_class_loaded($table_class); + + # NOTE! - not using clone() here and *NOT* marking source as derived + # from the one already existing on the class (if any) + # This is logically sound as we are operating at class-level, and is + # in fact necessary, as otherwise any base-class with a "dummy" table + # will be marked as an ancestor of everything $table = $table_class->new({ - $class->can('result_source_instance') - ? %{$class->result_source_instance||{}} - : () - , + %{ $ancestor || {} }, name => $table, result_class => $class, }); diff --git a/xt/extra/internals/rsrc_ancestry.t b/xt/extra/internals/rsrc_ancestry.t new file mode 100644 index 000000000..e39f005a4 --- /dev/null +++ b/xt/extra/internals/rsrc_ancestry.t @@ -0,0 +1,82 @@ +use warnings; +use strict; + +use Config; +BEGIN { + my $skipall; + + if( ! $Config{useithreads} ) { + $skipall = 'your perl does not support ithreads'; + } + elsif( "$]" < 5.008005 ) { + $skipall = 'DBIC does not actively support threads before perl 5.8.5'; + } + elsif( $INC{'Devel/Cover.pm'} ) { + $skipall = 'Devel::Cover does not work with ithreads yet'; + } + + if( $skipall ) { + print "1..0 # SKIP $skipall\n"; + exit 0; + } +} + +use threads; +use Test::More; +use DBIx::Class::_Util 'hrefaddr'; +use Scalar::Util 'weaken'; + +{ + package DBICTest::Ancestry::Result; + + use base 'DBIx::Class::Core'; + + __PACKAGE__->table("foo"); +} + +{ + package DBICTest::Ancestry::Schema; + + use base 'DBIx::Class::Schema'; + + __PACKAGE__->register_class( r => "DBICTest::Ancestry::Result" ); +} + +my $schema = DBICTest::Ancestry::Schema->clone; +my $rsrc = $schema->resultset("r")->result_source->clone; + +threads->new( sub { + + my $another_rsrc = $rsrc->clone; + + is_deeply + refaddrify( DBICTest::Ancestry::Result->result_source_instance->__derived_instances ), + refaddrify( + DBICTest::Ancestry::Schema->source("r"), + $schema->source("r"), + $rsrc, + $another_rsrc, + ) + ; + + undef $schema; + undef $rsrc; + $another_rsrc->schema(undef); + + is_deeply + refaddrify( DBICTest::Ancestry::Result->result_source_instance->__derived_instances ), + refaddrify( + DBICTest::Ancestry::Schema->source("r"), + $another_rsrc, + ) + ; + + # tasty crashes without this + select( undef, undef, undef, 0.2 ); +})->join; + +sub refaddrify { + [ sort map { hrefaddr $_ } @_ ]; +} + +done_testing; From f064a2abb15858bb39a141ad50391d4191988d2c Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 25 Apr 2016 11:53:54 +0200 Subject: [PATCH 191/262] Resolve $rsrc instance duality on metadata traversal Make result_source a straight wrapper around result_source_instance. This should fix all the fallout introduced in 0.082800 (4006691d), which sadly went undetected all the way until ~7 months after its release. Ultimately this is my fault, as I had an early warning, and even later made a conjecture which spot exactly may blow up in my face (read towards end of 350e8d57) Exploit the fact that result_source_instance until very recently was a toss-up between a CAG 'inherited' and a Class::Data::Inheritable (removed in 5e0eea35) with CAG not really involved in result-instance level calls, and the latter making it downright impractical due to the closure-based approach. Combined with the fact that result_source was a 'simple'-type accessor pointing at the '_result_source' hash-slot allows us (at least seemingly) to switch to a setup where result_source is nothing but a wrapper around a CAG inherited accessor result_source_instance which point to the named slot '_result_source' The changeset is deceptively small, and is kept this way for easier auditing. See next commit for the armada of additional testing to verify the entire stack is in fact still solid. --- Changes | 2 ++ lib/DBIx/Class/ResultSourceProxy/Table.pm | 4 ++-- lib/DBIx/Class/Row.pm | 23 ++++++++--------------- lib/DBIx/Class/Schema.pm | 6 +++++- t/resultsource/add_column_on_instance.t | 22 ++++++++++++++++++++++ t/resultsource/instance_equivalence.t | 23 +++++++++++++++++++++++ 6 files changed, 62 insertions(+), 18 deletions(-) create mode 100644 t/resultsource/add_column_on_instance.t create mode 100644 t/resultsource/instance_equivalence.t diff --git a/Changes b/Changes index 2abdb6eff..c2bb298d1 100644 --- a/Changes +++ b/Changes @@ -42,6 +42,8 @@ Revision history for DBIx::Class specific DateTime::Format dependencies * Fixes + - Fix regresion (0.082800) of certain calls being presented stale + result source metadata (RT#107462) - Fix incorrect SQL generated with invalid {rows} on complex resultset operations, generally more robust handling of rows/offset attrs - Fix incorrect $storage state on unexpected RDBMS disconnects and diff --git a/lib/DBIx/Class/ResultSourceProxy/Table.pm b/lib/DBIx/Class/ResultSourceProxy/Table.pm index a1a0ce3a8..4c0807cca 100644 --- a/lib/DBIx/Class/ResultSourceProxy/Table.pm +++ b/lib/DBIx/Class/ResultSourceProxy/Table.pm @@ -17,7 +17,7 @@ __PACKAGE__->mk_group_accessors( inherited => 'table_alias' ); sub _init_result_source_instance { my $class = shift; - $class->mk_group_accessors( inherited => 'result_source_instance' ) + $class->mk_group_accessors( inherited => [ result_source_instance => '_result_source' ] ) unless $class->can('result_source_instance'); # might be pre-made for us courtesy of DBIC::DB::result_source_instance() @@ -109,7 +109,7 @@ sub table { }); } - $class->mk_group_accessors(inherited => 'result_source_instance') + $class->mk_group_accessors( inherited => [ result_source_instance => '_result_source' ] ) unless $class->can('result_source_instance'); $class->result_source_instance($table)->name; diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 40d6fbd2f..6d1b34101 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -1430,21 +1430,14 @@ Accessor to the L this object was created from. =cut sub result_source { - $_[0]->throw_exception( 'result_source can be called on instances only' ) - unless ref $_[0]; - - @_ > 1 - ? $_[0]->{_result_source} = $_[1] - - # note this is a || not a ||=, the difference is important - : $_[0]->{_result_source} || do { - $_[0]->can('result_source_instance') - ? $_[0]->result_source_instance - : $_[0]->throw_exception( - "No result source instance registered for @{[ ref $_[0] ]}, did you forget to call @{[ ref $_[0] ]}->table(...) ?" - ) - } - ; + # this is essentially a `shift->result_source_instance(@_)` with handholding + &{ + $_[0]->can('result_source_instance') + || + $_[0]->throw_exception( + "No result source instance registered for '@{[ $_[0] ]}', did you forget to call @{[ ref $_[0] || $_[0] ]}->table(...) ?" + ) + }; } =head2 register_column diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 153d7292f..d5a8f3583 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -1625,7 +1625,11 @@ sub compose_connection { my $source = $schema->source($source_name); my $class = $source->result_class; #warn "$source_name $class $source ".$source->storage; - $class->mk_classaccessor(result_source_instance => $source); + + $class->mk_group_accessors( inherited => [ result_source_instance => '_result_source' ] ); + # explicit set-call, avoid mro update lag + $class->set_inherited( result_source_instance => $source ); + $class->mk_classaccessor(resultset_instance => $source->resultset); $class->mk_classaccessor(class_resolver => $schema); } diff --git a/t/resultsource/add_column_on_instance.t b/t/resultsource/add_column_on_instance.t new file mode 100644 index 000000000..9ae95165c --- /dev/null +++ b/t/resultsource/add_column_on_instance.t @@ -0,0 +1,22 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; + +use DBICTest; + +my $ar = DBICTest->init_schema->resultset("Artist")->find(1); + +ok (! $ar->can("not_yet_there_column"), "No accessor for nonexitentcolumn" ); + +$ar->add_column("not_yet_there_column"); +ok ($ar->has_column("not_yet_there_column"), "Metadata correct after nonexitentcolumn addition" ); +ok ($ar->can("not_yet_there_column"), "Accessor generated for nonexitentcolumn" ); + +$ar->not_yet_there_column('I EXIST \o/'); + +is { $ar->get_columns }->{not_yet_there_column}, 'I EXIST \o/', "Metadata propagates to mutli-column methods"; + +done_testing; diff --git a/t/resultsource/instance_equivalence.t b/t/resultsource/instance_equivalence.t new file mode 100644 index 000000000..37f054f71 --- /dev/null +++ b/t/resultsource/instance_equivalence.t @@ -0,0 +1,23 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; +no warnings 'qw'; + +use Test::More; + +use DBICTest; + +my $schema = DBICTest->init_schema; +my $rsrc = $schema->source("Artist"); + +is( (eval($_)||die $@), $rsrc, "Same source object after $_" ) for qw( + $rsrc->resultset->result_source, + $rsrc->resultset->next->result_source, + $rsrc->resultset->next->result_source_instance, + $schema->resultset("Artist")->result_source, + $schema->resultset("Artist")->next->result_source, + $schema->resultset("Artist")->next->result_source_instance, +); + +done_testing; From b83736a7d3235d2f50fe5695550eb3637432d960 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 6 Jun 2016 14:34:55 +0200 Subject: [PATCH 192/262] Fold column_info() into columns_info() Not sure how I never noticed the utter code duplication. --- lib/DBIx/Class/FilterColumn.pm | 13 ++-- lib/DBIx/Class/InflateColumn.pm | 10 ++- lib/DBIx/Class/InflateColumn/File.pm | 2 +- lib/DBIx/Class/Relationship/HasOne.pm | 18 ++++-- lib/DBIx/Class/ResultSource.pm | 67 ++++++++------------ lib/DBIx/Class/ResultSourceProxy.pm | 7 +- lib/DBIx/Class/Row.pm | 21 +++--- lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm | 3 +- lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm | 29 +++++++-- lib/SQL/Translator/Parser/DBIx/Class.pm | 6 +- t/86might_have.t | 2 +- 11 files changed, 96 insertions(+), 82 deletions(-) diff --git a/lib/DBIx/Class/FilterColumn.pm b/lib/DBIx/Class/FilterColumn.pm index 18f99a821..c280b47a6 100644 --- a/lib/DBIx/Class/FilterColumn.pm +++ b/lib/DBIx/Class/FilterColumn.pm @@ -9,14 +9,11 @@ use namespace::clean; sub filter_column { my ($self, $col, $attrs) = @_; - my $colinfo = $self->result_source_instance->column_info($col); + my $colinfo = $self->result_source->columns_info([$col])->{$col}; $self->throw_exception("FilterColumn can not be used on a column with a declared InflateColumn inflator") if defined $colinfo->{_inflate_info} and $self->isa('DBIx::Class::InflateColumn'); - $self->throw_exception("No such column $col to filter") - unless $self->result_source_instance->has_column($col); - $self->throw_exception('filter_column expects a hashref of filter specifications') unless ref $attrs eq 'HASH'; @@ -34,8 +31,7 @@ sub _column_from_storage { return $value if is_literal_value($value); - my $info = $self->result_source->column_info($col) - or $self->throw_exception("No column info for $col"); + my $info = $self->result_source->columns_info([$col])->{$col}; return $value unless exists $info->{_filter_info}; @@ -49,8 +45,7 @@ sub _column_to_storage { return $value if is_literal_value($value); - my $info = $self->result_source->column_info($col) or - $self->throw_exception("No column info for $col"); + my $info = $self->result_source->columns_info([$col])->{$col}; return $value unless exists $info->{_filter_info}; @@ -63,7 +58,7 @@ sub get_filtered_column { my ($self, $col) = @_; $self->throw_exception("$col is not a filtered column") - unless exists $self->result_source->column_info($col)->{_filter_info}; + unless exists $self->result_source->columns_info->{$col}{_filter_info}; return $self->{_filtered_column}{$col} if exists $self->{_filtered_column}{$col}; diff --git a/lib/DBIx/Class/InflateColumn.pm b/lib/DBIx/Class/InflateColumn.pm index 08b1b54b6..39d36f5f6 100644 --- a/lib/DBIx/Class/InflateColumn.pm +++ b/lib/DBIx/Class/InflateColumn.pm @@ -87,7 +87,7 @@ L sub inflate_column { my ($self, $col, $attrs) = @_; - my $colinfo = $self->result_source_instance->column_info($col); + my $colinfo = $self->result_source->columns_info([$col])->{$col}; $self->throw_exception("InflateColumn can not be used on a column with a declared FilterColumn filter") if defined $colinfo->{_filter_info} and $self->isa('DBIx::Class::FilterColumn'); @@ -111,8 +111,7 @@ sub _inflated_column { is_literal_value($value) #that would be a not-yet-reloaded literal update ); - my $info = $self->result_source->column_info($col) - or $self->throw_exception("No column info for $col"); + my $info = $self->result_source->columns_info([$col])->{$col}; return $value unless exists $info->{_inflate_info}; @@ -133,8 +132,7 @@ sub _deflated_column { is_literal_value($value) ); - my $info = $self->result_source->column_info($col) or - $self->throw_exception("No column info for $col"); + my $info = $self->result_source->columns_info([$col])->{$col}; return $value unless exists $info->{_inflate_info}; @@ -160,7 +158,7 @@ sub get_inflated_column { my ($self, $col) = @_; $self->throw_exception("$col is not an inflated column") - unless exists $self->result_source->column_info($col)->{_inflate_info}; + unless exists $self->result_source->columns_info->{$col}{_inflate_info}; # we take care of keeping things in sync return $self->{_inflated_column}{$col} diff --git a/lib/DBIx/Class/InflateColumn/File.pm b/lib/DBIx/Class/InflateColumn/File.pm index 08a1a3180..34db2ed02 100644 --- a/lib/DBIx/Class/InflateColumn/File.pm +++ b/lib/DBIx/Class/InflateColumn/File.pm @@ -49,7 +49,7 @@ sub register_column { sub _file_column_file { my ($self, $column, $filename) = @_; - my $column_info = $self->result_source->column_info($column); + my $column_info = $self->result_source->columns_info->{$column}; return unless $column_info->{is_file_column}; diff --git a/lib/DBIx/Class/Relationship/HasOne.pm b/lib/DBIx/Class/Relationship/HasOne.pm index 665d13190..46e18e34b 100644 --- a/lib/DBIx/Class/Relationship/HasOne.pm +++ b/lib/DBIx/Class/Relationship/HasOne.pm @@ -97,12 +97,18 @@ sub _validate_has_one_condition { return unless $self_id =~ /^self\.(.*)$/; my $key = $1; - $class->throw_exception("Defining rel on ${class} that includes '$key' but no such column defined here yet") - unless $class->result_source_instance->has_column($key); - my $column_info = $class->result_source_instance->column_info($key); - if ( $column_info->{is_nullable} ) { - carp(qq'"might_have/has_one" must not be on columns with is_nullable set to true ($class/$key). This might indicate an incorrect use of those relationship helpers instead of belongs_to.'); - } + + my $column_info = $class->result_source->columns_info->{$key} + or $class->throw_exception( + "Defining rel on ${class} that includes '$key' " + . 'but no such column defined there yet' + ); + + carp( + "'might_have'/'has_one' must not be used on columns with is_nullable " + . "set to true ($class/$key). This almost certainly indicates an " + . "incorrect use of these relationship helpers instead of 'belongs_to'" + ) if $column_info->{is_nullable}; } } diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 0a5d1fc07..a8da52e93 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -445,13 +445,19 @@ sub add_columns { my ($self, @cols) = @_; $self->_ordered_columns(\@cols) unless $self->_ordered_columns; - my @added; + my ( @added, $colinfos ); my $columns = $self->_columns; + while (my $col = shift @cols) { - my $column_info = {}; - if ($col =~ s/^\+//) { - $column_info = $self->column_info($col); - } + my $column_info = + ( + $col =~ s/^\+// + and + ( $colinfos ||= $self->columns_info )->{$col} + ) + || + {} + ; # If next entry is { ... } use that for the column info, if not # use an empty hashref @@ -462,6 +468,7 @@ sub add_columns { push(@added, $col) unless exists $columns->{$col}; $columns->{$col} = $column_info; } + push @{ $self->_ordered_columns }, @added; return $self; } @@ -511,35 +518,10 @@ contents of the hashref. =cut sub column_info { - my ($self, $column) = @_; - $self->throw_exception("No such column $column") - unless exists $self->_columns->{$column}; - - if ( ! $self->_columns->{$column}{data_type} - and ! $self->{_columns_info_loaded} - and $self->column_info_from_storage - and my $stor = dbic_internal_try { $self->schema->storage } ) - { - $self->{_columns_info_loaded}++; - - # try for the case of storage without table - dbic_internal_try { - my $info = $stor->columns_info_for( $self->from ); - my $lc_info = { map - { (lc $_) => $info->{$_} } - ( keys %$info ) - }; - - foreach my $col ( keys %{$self->_columns} ) { - $self->_columns->{$col} = { - %{ $self->_columns->{$col} }, - %{ $info->{$col} || $lc_info->{lc $col} || {} } - }; - } - }; - } + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; - return $self->_columns->{$column}; + #my ($self, $column) = @_; + $_[0]->columns_info([ $_[1] ])->{$_[1]}; } =head2 columns @@ -634,6 +616,8 @@ sub columns_info { } } else { + # the shallow copy is crucial - there are exists() checks within + # the wider codebase %ret = %$colinfo; } @@ -1857,14 +1841,17 @@ sub _pk_depends_on { # auto-increment my $rel_source = $self->related_source($rel_name); + my $colinfos; + foreach my $p ($self->primary_columns) { - if (exists $keyhash->{$p}) { - unless (defined($rel_data->{$keyhash->{$p}}) - || $rel_source->column_info($keyhash->{$p}) - ->{is_auto_increment}) { - return 0; - } - } + return 0 if ( + exists $keyhash->{$p} + and + ! defined( $rel_data->{$keyhash->{$p}} ) + and + ! ( $colinfos ||= $rel_source->columns_info ) + ->{$keyhash->{$p}}{is_auto_increment} + ) } return 1; diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm index 5f4bbe3d0..70de112c8 100644 --- a/lib/DBIx/Class/ResultSourceProxy.pm +++ b/lib/DBIx/Class/ResultSourceProxy.pm @@ -25,11 +25,16 @@ sub add_columns { my ($class, @cols) = @_; my $source = $class->result_source_instance; $source->add_columns(@cols); + + my $colinfos; foreach my $c (grep { !ref } @cols) { # If this is an augment definition get the real colname. $c =~ s/^\+//; - $class->register_column($c => $source->column_info($c)); + $class->register_column( + $c, + ( $colinfos ||= $source->columns_info )->{$c} + ); } } diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 6d1b34101..b0542cb04 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -196,7 +196,7 @@ sub new { @{$new->{_ignore_at_insert}={}}{@$col_from_rel} = (); } - my ($related,$inflated); + my( $related, $inflated, $colinfos ); foreach my $key (keys %$attrs) { if (ref $attrs->{$key} and ! is_literal_value($attrs->{$key}) ) { @@ -258,9 +258,8 @@ sub new { next; } elsif ( - $rsrc->has_column($key) - and - $rsrc->column_info($key)->{_inflate_info} + ( $colinfos ||= $rsrc->columns_info ) + ->{$key}{_inflate_info} ) { $inflated->{$key} = $attrs->{$key}; next; @@ -902,7 +901,7 @@ sub _is_column_numeric { return undef unless ( $rsrc = $self->result_source )->has_column($column); - my $colinfo = $rsrc->column_info ($column); + my $colinfo = $rsrc->columns_info->{$column}; # cache for speed (the object may *not* have a resultsource instance) if ( @@ -1099,7 +1098,9 @@ See also L. sub set_inflated_columns { my ( $self, $upd ) = @_; - my $rsrc; + + my ($rsrc, $colinfos); + foreach my $key (keys %$upd) { if (ref $upd->{$key}) { $rsrc ||= $self->result_source; @@ -1117,9 +1118,11 @@ sub set_inflated_columns { ); } elsif ( - $rsrc->has_column($key) - and - exists $rsrc->column_info($key)->{_inflate_info} + exists( ( + ( $colinfos ||= $rsrc->columns_info )->{$key} + || + {} + )->{_inflate_info} ) ) { $self->set_inflated_column($key, delete $upd->{$key}); } diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm index 61767ba2b..336070a0d 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm @@ -117,8 +117,9 @@ sub deployment_statements { sub _dbh_last_insert_id { my ($self, $dbh, $source, @columns) = @_; my @ids = (); + my $ci = $source->columns_info(\@columns); foreach my $col (@columns) { - my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col)); + my $seq = ( $ci->{$col}{sequence} ||= $self->get_autoinc_seq($source,$col)); my $id = $self->_sequence_fetch( 'CURRVAL', $seq ); push @ids, $id; } diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm index 017709c99..5282b7f9b 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm @@ -247,7 +247,9 @@ sub connect_call_blob_setup { sub _is_lob_column { my ($self, $source, $column) = @_; - return $self->_is_lob_type($source->column_info($column)->{data_type}); + return $self->_is_lob_type( + $source->columns_info([$column])->{$column}{data_type} + ); } sub _prep_for_execute { @@ -357,15 +359,28 @@ sub insert { # try to insert explicit 'DEFAULT's instead (except for identity, timestamp # and computed columns) if (not %$to_insert) { + + my $ci; + # same order as add_columns for my $col ($source->columns) { next if $col eq $identity_col; - my $info = $source->column_info($col); - - next if ref $info->{default_value} eq 'SCALAR' - || (exists $info->{data_type} && (not defined $info->{data_type})); - - next if $info->{data_type} && $info->{data_type} =~ /^timestamp\z/i; + my $info = ( $ci ||= $source->columns_info )->{$col}; + + next if ( + ref $info->{default_value} eq 'SCALAR' + or + ( + exists $info->{data_type} + and + ! defined $info->{data_type} + ) + or + ( + ( $info->{data_type} || '' ) + =~ /^timestamp\z/i + ) + ); $to_insert->{$col} = \'DEFAULT'; } diff --git a/lib/SQL/Translator/Parser/DBIx/Class.pm b/lib/SQL/Translator/Parser/DBIx/Class.pm index 4cc21f0b0..4ca3f933a 100644 --- a/lib/SQL/Translator/Parser/DBIx/Class.pm +++ b/lib/SQL/Translator/Parser/DBIx/Class.pm @@ -127,6 +127,10 @@ sub parse { name => $table_name, type => 'TABLE', ); + + my $ci = $source->columns_info; + + # same order as add_columns foreach my $col ($source->columns) { # assuming column_info in dbic is the same as DBI (?) @@ -137,7 +141,7 @@ sub parse { is_auto_increment => 0, is_foreign_key => 0, is_nullable => 0, - %{$source->column_info($col)} + %{$ci->{$col} || {}} ); if ($colinfo{is_nullable}) { $colinfo{default} = '' unless exists $colinfo{default}; diff --git a/t/86might_have.t b/t/86might_have.t index 62655e035..f656802f4 100644 --- a/t/86might_have.t +++ b/t/86might_have.t @@ -40,7 +40,7 @@ warning_like { { "foreign.id" => "self.link" }, ); } - qr{"might_have/has_one" must not be on columns with is_nullable set to true}, + qr{'might_have'/'has_one' must not be used on columns with is_nullable set to true}, 'might_have should warn if the self.id column is nullable'; { From e570488ade8f327f47dd3318db3443a348d561d6 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 15 Apr 2016 00:33:17 +0200 Subject: [PATCH 193/262] Centralize all user-side rsrc calls to go through result_source() This ensures the user will always get a sensible exception when the rsrc metadata object has not yet been initialized (as introduced in 5298bbb5): Before: ~$ perl -e 'use base "DBIx::Class::Core"; __PACKAGE__->add_column("foo")' Can't locate object method "result_source_instance" via package "main" at .../ResultSourceProxy.pm line 29. After: ~$ perl -e 'use base "DBIx::Class::Core"; __PACKAGE__->add_column("foo")' DBIx::Class::Row::result_source(): No ResultSource instance registered for 'main', did you forget to call main->table(...) ? at -e line 1 Add a shitload of assertions to track we are doing the right thing in all cases. This more or less concludes the rsrc changeset necessary to resolve all ambiguities. The next commit adds user-visible warnings when things go off the rails The changeset was successfully tested against the list of distributions in c8b1011e with no ill effects being observed. Thus I am pretty damn confident I rather nailed it >.> --- lib/DBIx/Class/CDBICompat/ColumnCase.pm | 2 +- lib/DBIx/Class/CDBICompat/ColumnGroups.pm | 4 +- lib/DBIx/Class/CDBICompat/ImaDBI.pm | 7 +- lib/DBIx/Class/CDBICompat/Relationships.pm | 8 +- lib/DBIx/Class/DB.pm | 4 +- lib/DBIx/Class/InflateColumn.pm | 3 +- lib/DBIx/Class/Manual/Cookbook.pod | 4 +- lib/DBIx/Class/Relationship/BelongsTo.pm | 8 +- lib/DBIx/Class/Relationship/HasMany.pm | 4 +- lib/DBIx/Class/Relationship/HasOne.pm | 8 +- lib/DBIx/Class/ResultSetManager.pm | 11 +- lib/DBIx/Class/ResultSource.pm | 10 +- lib/DBIx/Class/ResultSource/View.pm | 14 +- lib/DBIx/Class/ResultSourceProxy.pm | 9 +- lib/DBIx/Class/ResultSourceProxy/Table.pm | 2 +- lib/DBIx/Class/Row.pm | 22 ++- lib/DBIx/Class/Schema.pm | 6 +- lib/DBIx/Class/UTF8Columns.pm | 2 +- lib/DBIx/Class/_Util.pm | 9 +- t/lib/DBICTest.pm | 17 ++- t/lib/DBICTest/BaseSchema.pm | 168 ++++++++++++++++++++- t/resultsource/instance_equivalence.t | 2 + 22 files changed, 257 insertions(+), 67 deletions(-) diff --git a/lib/DBIx/Class/CDBICompat/ColumnCase.pm b/lib/DBIx/Class/CDBICompat/ColumnCase.pm index 56bef61b3..efbb88166 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnCase.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnCase.pm @@ -13,7 +13,7 @@ sub _register_column_group { sub add_columns { my ($class, @cols) = @_; - return $class->result_source_instance->add_columns(map lc, @cols); + return $class->result_source->add_columns(map lc, @cols); } sub has_a { diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm index 6ead1f77f..73f845c95 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm @@ -36,7 +36,7 @@ sub _add_column_group { sub add_columns { my ($class, @cols) = @_; - $class->result_source_instance->add_columns(@cols); + $class->result_source->add_columns(@cols); } sub _register_column_group { @@ -148,7 +148,7 @@ sub _mk_group_accessors { } } -sub all_columns { return shift->result_source_instance->columns; } +sub all_columns { return shift->result_source->columns; } sub primary_column { my ($class) = @_; diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm index ee9aae0c6..43537ff40 100644 --- a/lib/DBIx/Class/CDBICompat/ImaDBI.pm +++ b/lib/DBIx/Class/CDBICompat/ImaDBI.pm @@ -52,9 +52,12 @@ sub sth_to_objects { $sth->execute(@$execute_args); - my @ret; + my (@ret, $rsrc); while (my $row = $sth->fetchrow_hashref) { - push(@ret, $class->inflate_result($class->result_source_instance, $row)); + push(@ret, $class->inflate_result( + ( $rsrc ||= $class->result_source ), + $row + )); } return @ret; diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm index a5bfa5e5c..90ce39be8 100644 --- a/lib/DBIx/Class/CDBICompat/Relationships.pm +++ b/lib/DBIx/Class/CDBICompat/Relationships.pm @@ -66,7 +66,7 @@ sub _declare_has_a { } else { $self->belongs_to($col, $f_class); - $rel_info = $self->result_source_instance->relationship_info($col); + $rel_info = $self->result_source->relationship_info($col); } $rel_info->{args} = \%args; @@ -110,14 +110,14 @@ sub has_many { if( !$f_key and !@f_method ) { $class->ensure_class_loaded($f_class); - my $f_source = $f_class->result_source_instance; + my $f_source = $f_class->result_source; ($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class } $f_source->relationships; } $class->next::method($rel, $f_class, $f_key, $args); - my $rel_info = $class->result_source_instance->relationship_info($rel); + my $rel_info = $class->result_source->relationship_info($rel); $args->{mapping} = \@f_method; $args->{foreign_key} = $f_key; $rel_info->{args} = $args; @@ -150,7 +150,7 @@ sub might_have { { proxy => \@columns }); } - my $rel_info = $class->result_source_instance->relationship_info($rel); + my $rel_info = $class->result_source->relationship_info($rel); $rel_info->{args}{import} = \@columns; $class->_extend_meta( diff --git a/lib/DBIx/Class/DB.pm b/lib/DBIx/Class/DB.pm index ea4a5a6dc..df232b305 100644 --- a/lib/DBIx/Class/DB.pm +++ b/lib/DBIx/Class/DB.pm @@ -176,7 +176,7 @@ native L system. =cut sub resultset_instance { - $_[0]->result_source_instance->resultset + $_[0]->result_source->resultset } =begin hidden @@ -194,7 +194,7 @@ __PACKAGE__->mk_classaccessor('_result_source_instance' => []); # Yep. this is horrific. Basically what's happening here is that # (with good reason) DBIx::Class::Schema copies the result source for # registration. Because we have a retarded setup order forced on us we need -# to actually make our ->result_source_instance -be- the source used, and we +# to actually make our ->result_source -be- the source used, and we # need to get the source name and schema into ourselves. So this makes it # happen. diff --git a/lib/DBIx/Class/InflateColumn.pm b/lib/DBIx/Class/InflateColumn.pm index 39d36f5f6..c16375d2d 100644 --- a/lib/DBIx/Class/InflateColumn.pm +++ b/lib/DBIx/Class/InflateColumn.pm @@ -92,10 +92,9 @@ sub inflate_column { $self->throw_exception("InflateColumn can not be used on a column with a declared FilterColumn filter") if defined $colinfo->{_filter_info} and $self->isa('DBIx::Class::FilterColumn'); - $self->throw_exception("No such column $col to inflate") - unless $self->result_source_instance->has_column($col); $self->throw_exception("inflate_column needs attr hashref") unless ref $attrs eq 'HASH'; + $colinfo->{_inflate_info} = $attrs; my $acc = $colinfo->{accessor}; $self->mk_group_accessors('inflated_column' => [ (defined $acc ? $acc : $col), $col]); diff --git a/lib/DBIx/Class/Manual/Cookbook.pod b/lib/DBIx/Class/Manual/Cookbook.pod index 324ff641c..ce68fc24b 100644 --- a/lib/DBIx/Class/Manual/Cookbook.pod +++ b/lib/DBIx/Class/Manual/Cookbook.pod @@ -125,9 +125,9 @@ almost like you would define a regular ResultSource. # # do not attempt to deploy() this view - __PACKAGE__->result_source_instance->is_virtual(1); + __PACKAGE__->result_source->is_virtual(1); - __PACKAGE__->result_source_instance->view_definition(q[ + __PACKAGE__->result_source->view_definition(q[ SELECT u.* FROM user u INNER JOIN user_friends f ON u.id = f.user_id WHERE f.friend_user_id = ? diff --git a/lib/DBIx/Class/Relationship/BelongsTo.pm b/lib/DBIx/Class/Relationship/BelongsTo.pm index cadca9297..50ddc2eb4 100644 --- a/lib/DBIx/Class/Relationship/BelongsTo.pm +++ b/lib/DBIx/Class/Relationship/BelongsTo.pm @@ -39,16 +39,16 @@ sub belongs_to { $class->throw_exception( "No such column '$f_key' declared yet on ${class} ($guess)" - ) unless $class->result_source_instance->has_column($f_key); + ) unless $class->result_source->has_column($f_key); $class->ensure_class_loaded($f_class); my $f_rsrc = dbic_internal_try { - $f_class->result_source_instance; + $f_class->result_source; } catch { $class->throw_exception( "Foreign class '$f_class' does not seem to be a Result class " - . "(or it simply did not load entirely due to a circular relation chain)" + . "(or it simply did not load entirely due to a circular relation chain): $_" ); }; @@ -81,7 +81,7 @@ sub belongs_to { and (keys %$cond)[0] =~ /^foreign\./ and - $class->result_source_instance->has_column($rel) + $class->result_source->has_column($rel) ) ? 'filter' : 'single'; my $fk_columns = ($acc_type eq 'single' and ref $cond eq 'HASH') diff --git a/lib/DBIx/Class/Relationship/HasMany.pm b/lib/DBIx/Class/Relationship/HasMany.pm index 053eda6d5..6ef09fb74 100644 --- a/lib/DBIx/Class/Relationship/HasMany.pm +++ b/lib/DBIx/Class/Relationship/HasMany.pm @@ -16,7 +16,7 @@ sub has_many { unless (ref $cond) { - my $pri = $class->result_source_instance->_single_pri_col_or_die; + my $pri = $class->result_source->_single_pri_col_or_die; my ($f_key,$guess); if (defined $cond && length $cond) { @@ -30,7 +30,7 @@ sub has_many { # FIXME - this check needs to be moved to schema-composition time... # # only perform checks if the far side appears already loaded -# if (my $f_rsrc = dbic_internal_try { $f_class->result_source_instance } ) { +# if (my $f_rsrc = dbic_internal_try { $f_class->result_source } ) { # $class->throw_exception( # "No such column '$f_key' on foreign class ${f_class} ($guess)" # ) if !$f_rsrc->has_column($f_key); diff --git a/lib/DBIx/Class/Relationship/HasOne.pm b/lib/DBIx/Class/Relationship/HasOne.pm index 46e18e34b..8f74bb8a1 100644 --- a/lib/DBIx/Class/Relationship/HasOne.pm +++ b/lib/DBIx/Class/Relationship/HasOne.pm @@ -24,7 +24,7 @@ sub has_one { sub _has_one { my ($class, $join_type, $rel, $f_class, $cond, $attrs) = @_; unless (ref $cond) { - my $pri = $class->result_source_instance->_single_pri_col_or_die; + my $pri = $class->result_source->_single_pri_col_or_die; my ($f_key,$guess,$f_rsrc); if (defined $cond && length $cond) { @@ -36,7 +36,7 @@ sub _has_one { $class->ensure_class_loaded($f_class); $f_rsrc = dbic_internal_try { - my $r = $f_class->result_source_instance; + my $r = $f_class->result_source; die "There got to be some columns by now... (exception caught and rewritten by catch below)" unless $r->columns; $r; @@ -60,8 +60,8 @@ sub _has_one { # FIXME - this check needs to be moved to schema-composition time... # # only perform checks if the far side was not preloaded above *AND* -# # appears to have been loaded by something else (has a rsrc_instance) -# if (! $f_rsrc and $f_rsrc = dbic_internal_try { $f_class->result_source_instance }) { +# # appears to have been loaded by something else (has a rsrc) +# if (! $f_rsrc and $f_rsrc = dbic_internal_try { $f_class->result_source }) { # $class->throw_exception( # "No such column '$f_key' on foreign class ${f_class} ($guess)" # ) if !$f_rsrc->has_column($f_key); diff --git a/lib/DBIx/Class/ResultSetManager.pm b/lib/DBIx/Class/ResultSetManager.pm index addc8c36f..e4adae57a 100644 --- a/lib/DBIx/Class/ResultSetManager.pm +++ b/lib/DBIx/Class/ResultSetManager.pm @@ -88,12 +88,11 @@ sub _register_resultset_class { my $self = shift; my $resultset_class = $self . $self->table_resultset_class_suffix; no strict 'refs'; - if (@{"$resultset_class\::ISA"}) { - $self->result_source_instance->resultset_class($resultset_class); - } else { - $self->result_source_instance->resultset_class - ($self->base_resultset_class); - } + $self->result_source->resultset_class( + ( scalar @{"${resultset_class}::ISA"} ) + ? $resultset_class + : $self->base_resultset_class + ); } =head1 FURTHER QUESTIONS? diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index a8da52e93..d6ca1ed09 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -60,8 +60,8 @@ DBIx::Class::ResultSource - Result source object __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year2000cds'); - __PACKAGE__->result_source_instance->is_virtual(1); - __PACKAGE__->result_source_instance->view_definition( + __PACKAGE__->result_source->is_virtual(1); + __PACKAGE__->result_source->view_definition( "SELECT cdid, artist, title FROM cd WHERE year ='2000'" ); @@ -1043,11 +1043,11 @@ sub unique_constraint_columns { =back - __PACKAGE__->result_source_instance->sqlt_deploy_callback('mycallbackmethod'); + __PACKAGE__->result_source->sqlt_deploy_callback('mycallbackmethod'); or - __PACKAGE__->result_source_instance->sqlt_deploy_callback(sub { + __PACKAGE__->result_source->sqlt_deploy_callback(sub { my ($source_instance, $sqlt_table) = @_; ... } ); @@ -2388,7 +2388,7 @@ sub related_source { else { my $class = $self->relationship_info($rel)->{class}; $self->ensure_class_loaded($class); - $class->result_source_instance; + $class->result_source; } } diff --git a/lib/DBIx/Class/ResultSource/View.pm b/lib/DBIx/Class/ResultSource/View.pm index 33398267b..ede6d1d44 100644 --- a/lib/DBIx/Class/ResultSource/View.pm +++ b/lib/DBIx/Class/ResultSource/View.pm @@ -21,8 +21,8 @@ DBIx::Class::ResultSource::View - ResultSource object representing a view __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year2000cds'); - __PACKAGE__->result_source_instance->is_virtual(1); - __PACKAGE__->result_source_instance->view_definition( + __PACKAGE__->result_source->is_virtual(1); + __PACKAGE__->result_source->view_definition( "SELECT cdid, artist, title FROM cd WHERE year ='2000'" ); __PACKAGE__->add_columns( @@ -73,13 +73,13 @@ above, you can then: If you modified the schema to include a placeholder - __PACKAGE__->result_source_instance->view_definition( + __PACKAGE__->result_source->view_definition( "SELECT cdid, artist, title FROM cd WHERE year = ?" ); and ensuring you have is_virtual set to true: - __PACKAGE__->result_source_instance->is_virtual(1); + __PACKAGE__->result_source->is_virtual(1); You could now say: @@ -113,14 +113,14 @@ You could now say: =head2 is_virtual - __PACKAGE__->result_source_instance->is_virtual(1); + __PACKAGE__->result_source->is_virtual(1); Set to true for a virtual view, false or unset for a real database-based view. =head2 view_definition - __PACKAGE__->result_source_instance->view_definition( + __PACKAGE__->result_source->view_definition( "SELECT cdid, artist, title FROM cd WHERE year ='2000'" ); @@ -129,7 +129,7 @@ syntaxes. =head2 deploy_depends_on - __PACKAGE__->result_source_instance->deploy_depends_on( + __PACKAGE__->result_source->deploy_depends_on( ["MyApp::Schema::Result::Year","MyApp::Schema::Result::CD"] ); diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm index 70de112c8..cfd37cab8 100644 --- a/lib/DBIx/Class/ResultSourceProxy.pm +++ b/lib/DBIx/Class/ResultSourceProxy.pm @@ -23,7 +23,7 @@ sub set_inherited_ro_instance { sub add_columns { my ($class, @cols) = @_; - my $source = $class->result_source_instance; + my $source = $class->result_source; $source->add_columns(@cols); my $colinfos; @@ -46,7 +46,7 @@ sub add_column { sub add_relationship { my ($class, $rel, @rest) = @_; - my $source = $class->result_source_instance; + my $source = $class->result_source; $source->add_relationship($rel => @rest); $class->register_relationship($rel => $source->relationship_info($rel)); } @@ -55,7 +55,7 @@ sub add_relationship { # legacy resultset_class accessor, seems to be used by cdbi only sub iterator_class { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; - shift->result_source_instance->resultset_class(@_) + shift->result_source->resultset_class(@_) } for my $method_to_proxy (qw/ @@ -91,7 +91,8 @@ for my $method_to_proxy (qw/ /) { quote_sub __PACKAGE__."::$method_to_proxy", sprintf( <<'EOC', $method_to_proxy ); DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; - shift->result_source_instance->%s (@_); + + shift->result_source->%s (@_); EOC } diff --git a/lib/DBIx/Class/ResultSourceProxy/Table.pm b/lib/DBIx/Class/ResultSourceProxy/Table.pm index 4c0807cca..53dd26f03 100644 --- a/lib/DBIx/Class/ResultSourceProxy/Table.pm +++ b/lib/DBIx/Class/ResultSourceProxy/Table.pm @@ -82,7 +82,7 @@ Gets or sets the table name. =cut sub table { - return $_[0]->result_source_instance->name unless @_ > 1; + return $_[0]->result_source->name unless @_ > 1; my ($class, $table) = @_; diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index b0542cb04..1097701c4 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -190,7 +190,7 @@ sub new { $rsrc ||= $h->resolve; } - $new->result_source($rsrc) if $rsrc; + $new->result_source_instance($rsrc) if $rsrc; if (my $col_from_rel = delete $attrs->{-cols_from_relations}) { @{$new->{_ignore_at_insert}={}}{@$col_from_rel} = (); @@ -625,12 +625,9 @@ sub delete { $self->in_storage(0); } else { - my $rsrc = dbic_internal_try { $self->result_source_instance } - or $self->throw_exception("Can't do class delete without a ResultSource instance"); - my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {}; my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_}; - $rsrc->resultset->search(@_)->delete; + $self->result_source->resultset->search_rs(@_)->delete; } return $self; } @@ -1174,7 +1171,7 @@ sub copy { my $new = { _column_data => $col_data }; bless $new, ref $self; - $new->result_source($rsrc); + $new->result_source_instance($rsrc); $new->set_inflated_columns($changes); $new->insert; @@ -1433,12 +1430,20 @@ Accessor to the L this object was created from. =cut sub result_source { + # While getter calls are routed through here for sensible exception text + # it makes no sense to have setters do the same thing + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + @_ > 1 + and + fail_on_internal_call; + # this is essentially a `shift->result_source_instance(@_)` with handholding &{ $_[0]->can('result_source_instance') || $_[0]->throw_exception( - "No result source instance registered for '@{[ $_[0] ]}', did you forget to call @{[ ref $_[0] || $_[0] ]}->table(...) ?" + "No ResultSource instance registered for '@{[ $_[0] ]}', did you forget to call @{[ ref $_[0] || $_[0] ]}->table(...) ?" ) }; } @@ -1589,7 +1594,8 @@ sub throw_exception { if ( ! DBIx::Class::_Util::in_internal_try and - my $rsrc = dbic_internal_try { $self->result_source } + # FIXME - the try is 99% superfluous, but just in case + my $rsrc = dbic_internal_try { $self->result_source_instance } ) { $rsrc->throw_exception(@_) } diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index d5a8f3583..9961c08d9 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -199,7 +199,7 @@ sub _ns_get_rsrc_instance { my $rs_class = ref ($_[0]) || $_[0]; return dbic_internal_try { - $rs_class->result_source_instance + $rs_class->result_source } catch { $me->throw_exception ( "Attempt to load_namespaces() class $rs_class failed - are you sure this is a real Result Class?: $_" @@ -1398,13 +1398,13 @@ file). You may also need it to register classes at runtime. Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to calling: - $schema->register_source($source_name, $component_class->result_source_instance); + $schema->register_source($source_name, $component_class->result_source); =cut sub register_class { my ($self, $source_name, $to_register) = @_; - $self->register_source($source_name => $to_register->result_source_instance); + $self->register_source($source_name => $to_register->result_source); } =head2 register_source diff --git a/lib/DBIx/Class/UTF8Columns.pm b/lib/DBIx/Class/UTF8Columns.pm index 38a4dd412..db571a69c 100644 --- a/lib/DBIx/Class/UTF8Columns.pm +++ b/lib/DBIx/Class/UTF8Columns.pm @@ -94,7 +94,7 @@ sub utf8_columns { if (@_) { foreach my $col (@_) { $self->throw_exception("column $col doesn't exist") - unless $self->result_source_instance->has_column($col); + unless $self->result_source->has_column($col); } return $self->_utf8_columns({ map { $_ => 1 } @_ }); } else { diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index b640e7695..c459c73c2 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -1038,9 +1038,10 @@ sub fail_on_internal_call { { package DB; $fr = [ CORE::caller(1) ]; - $argdesc = ref $DB::args[0] - ? DBIx::Class::_Util::refdesc($DB::args[0]) - : ( $DB::args[0] . '' ) + $argdesc = + ( not defined $DB::args[0] ) ? 'UNAVAILABLE' + : ( length ref $DB::args[0] ) ? DBIx::Class::_Util::refdesc($DB::args[0]) + : $DB::args[0] . '' ; }; @@ -1062,7 +1063,7 @@ sub fail_on_internal_call { ; if ( - $argdesc + defined $fr->[0] and $check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ and diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index b43d4bff8..cfc18df97 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -31,6 +31,21 @@ use DBICTest::Util qw( dbg DEBUG_TEST_CONCURRENCY_LOCKS PEEPEENESS ); use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; + +# The actual ASSERT logic is in BaseSchema for pesky load-order reasons +# Hence run this through once, *before* DBICTest::Schema and friends load +BEGIN { + if ( + DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + or + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + ) { + require DBIx::Class::Row; + require DBICTest::BaseSchema; + DBICTest::BaseSchema->connect( sub {} ); + } +} + use DBICTest::Schema; use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard modver_gt_or_eq ); use Carp; @@ -275,7 +290,7 @@ sub __mk_disconnect_guard { my $clan_connect_caller = '*UNKNOWN*'; my $i; - while ( my ($pack, $file, $line) = caller(++$i) ) { + while ( my ($pack, $file, $line) = CORE::caller(++$i) ) { next if $file eq __FILE__; next if $pack =~ /^DBIx::Class|^Try::Tiny/; $clan_connect_caller = "$file line $line"; diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index aaaf955ca..5f52f75b0 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -7,9 +7,10 @@ use base qw(DBICTest::Base DBIx::Class::Schema); use Fcntl qw(:DEFAULT :seek :flock); use IO::Handle (); -use DBIx::Class::_Util 'scope_guard'; +use DBIx::Class::_Util qw( emit_loud_diag scope_guard set_subname get_subname ); use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry); use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); +use Scalar::Util qw( refaddr weaken ); use namespace::clean; if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { @@ -216,7 +217,19 @@ END { } } -my $weak_registry = {}; +my ( $weak_registry, $assertion_arounds ) = ( {}, {} ); + +sub DBICTest::__RsrcRedefiner_iThreads_handler__::CLONE { + if( DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE ) { + %$assertion_arounds = map { + (defined $_) + ? ( refaddr($_) => $_ ) + : () + } values %$assertion_arounds; + + weaken($_) for values %$assertion_arounds; + } +} sub connection { my $self = shift->next::method(@_); @@ -363,6 +376,157 @@ sub connection { ]); } + # + # Check an explicit level of indirection: makes sure that folks doing + # use `base "DBIx::Class::Core"; __PACKAGE__->add_column("foo")` + # will see the correct error message + # + # In the future this all is likely to be folded into a single method in + # some way, but that's a fight for another maint + # + if( DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE ) { + + for my $class_of_interest ( + 'DBIx::Class::Row', + map { $self->class($_) } ($self->sources) + ) { + + my $orig_rsrc = $class_of_interest->can('result_source') + or die "How did we get here?!"; + + unless ( $assertion_arounds->{refaddr $orig_rsrc} ) { + + my ($origin) = get_subname($orig_rsrc); + + no warnings 'redefine'; + no strict 'refs'; + + *{"${origin}::result_source"} = my $replacement = set_subname "${origin}::result_source" => sub { + + + @_ > 1 + and + (CORE::caller(0))[1] !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x + and + emit_loud_diag( + msg => 'Incorrect indirect call of result_source() as setter must be changed to result_source_instance()', + confess => 1, + ); + + + grep { + ! (CORE::caller($_))[7] + and + ( (CORE::caller($_))[3] || '' ) eq '(eval)' + and + ( (CORE::caller($_))[1] || '' ) !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x + } (0..2) + and + # these evals are legit + ( (CORE::caller(4))[3] || '' ) !~ /^ (?: + DBIx::Class::Schema::_ns_get_rsrc_instance + | + DBIx::Class::Relationship::BelongsTo::belongs_to + | + DBIx::Class::Relationship::HasOne::_has_one + | + Class::C3::Componentised::.+ + ) $/x + and + emit_loud_diag( + # not much else we can do (aside from exit(1) which is too obnoxious) + msg => 'Incorrect call of result_source() in an eval', + ); + + + &$orig_rsrc; + }; + + weaken( $assertion_arounds->{refaddr $replacement} = $replacement ); + } + + + # no rsrc_instance to mangle + next if $class_of_interest eq 'DBIx::Class::Row'; + + + my $orig_rsrc_instance = $class_of_interest->can('result_source_instance') + or die "How did we get here?!"; + + # Do the around() per definition-site as result_source_instance is a CAG inherited cref + unless ( $assertion_arounds->{refaddr $orig_rsrc_instance} ) { + + my ($origin) = get_subname($orig_rsrc_instance); + + no warnings 'redefine'; + no strict 'refs'; + + *{"${origin}::result_source_instance"} = my $replacement = set_subname "${origin}::result_source_instance" => sub { + + + @_ == 1 + and + # special cased as we do not care whether there is a source + ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Schema::_register_source' + and + # special case because I am paranoid + ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Row::throw_exception' + and + ( (CORE::caller(1))[3] || '' ) !~ / ^ DBIx::Class:: (?: + Row::result_source + | + Row::throw_exception + | + ResultSourceProxy::Table:: (?: _init_result_source_instance | table ) + | + ResultSourceHandle::STORABLE_thaw + ) $ /x + and + (CORE::caller(0))[1] !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x + and + emit_loud_diag( + msg => 'Incorrect direct call of result_source_instance() as getter must be changed to result_source()', + confess => 1 + ); + + + grep { + ! (CORE::caller($_))[7] + and + ( (CORE::caller($_))[3] || '' ) eq '(eval)' + and + ( (CORE::caller($_))[1] || '' ) !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x + } (0..2) + and + # special cased as we do not care whether there is a source + ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Schema::_register_source' + and + # special case because I am paranoid + ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Row::throw_exception' + and + # special case for Storable, which in turn calls from an eval + ( (CORE::caller(1))[3] || '' ) ne 'DBIx::Class::ResultSourceHandle::STORABLE_thaw' + and + emit_loud_diag( + # not much else we can do (aside from exit(1) which is too obnoxious) + msg => 'Incorrect call of result_source_instance() in an eval', + skip_frames => 1, + show_dups => 1, + ); + + &$orig_rsrc_instance; + }; + + weaken( $assertion_arounds->{refaddr $replacement} = $replacement ); + } + + } + + Class::C3::initialize if DBIx::Class::_ENV_::OLD_MRO; + } + # + # END Check an explicit level of indirection + return $self; } diff --git a/t/resultsource/instance_equivalence.t b/t/resultsource/instance_equivalence.t index 37f054f71..90621f960 100644 --- a/t/resultsource/instance_equivalence.t +++ b/t/resultsource/instance_equivalence.t @@ -1,5 +1,7 @@ BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } +BEGIN { $ENV{DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE} = 0 } + use strict; use warnings; no warnings 'qw'; From 73f54e275e7dc98b4a082475ff252afdbeca182f Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 22 Apr 2016 12:39:00 +0200 Subject: [PATCH 194/262] Comprehensive diagnostic on incorrect ResultSource metadata use This commit is the second part of the permanent RT#107462 solution f064a2ab. Given the amount of changes to the resultsource metadata subsystem, I can not be certain that everything has been accounted for, even despite the comprehensive assertion harness added in the previous commits passing with flying colors on the entire reverse dep list detailed in c8b1011e. As Dave Howorth correctly pointed out in [1], the diagnostic of why something stopped working within the metadata subsystem is pretty daunting, especially given the ass-backward nature of DBIC's implementation of it. The (minimal but present) performance hit is deemed worth it in order to be able to present this information to downstream. One unexpected bit of good news is that none of the downstreams tested emitted the warning, which is an extra point of confidence that the main change of f064a2ab, and the even more dangerous change in 9e36e3ec are both solid. The gist here is that this: ~/devel/dbic$ perl -Ilib -It/lib -MDBICTest -e ' my $art = DBICTest->init_schema->resultset("Artist")->find(1); DBICTest::Schema::Artist->add_column("foo"); DBICTest::Schema->source("Artist")->add_columns("foo"); $art->has_column("foo"); ' now emits a comprehensive non-trappable warning along the lines of: DBIx::Class::ResultSource::Table=HASH(0x2a32660) (the metadata instance of source 'Artist') is *OUTDATED*, and does not reflect the modifications of its *ancestors* as follows: * DBIx::Class::ResultSource::Table=HASH(0x24ed770)->add_column(...) at -e line 4 * DBIx::Class::ResultSource::Table=HASH(0x2955da8)->add_columns(...) at -e line 6 Stale metadata accessed by 'getter' DBIx::Class::ResultSource::Table=HASH(0x2a32660)->has_column(...) within the callstack beginning at lib/DBIx/Class/ResultSource.pm line 231. DBIx::Class::ResultSource::get_rsrc_instance_specific_attribute(DBIx::Class::ResultSource::Table=HASH(0x2a32660), "_columns") called at (eval 95) line 2 DBIx::Class::ResultSource::_columns(DBIx::Class::ResultSource::Table=HASH(0x2a32660)) called at lib/DBIx/Class/ResultSource.pm line 732 DBIx::Class::ResultSource::has_column(DBIx::Class::ResultSource::Table=HASH(0x2a32660), "foo") called at (eval 70) line 19 DBIx::Class::ResultSourceProxy::has_column(DBICTest::Artist=HASH(0x311e338), "foo") called at -e line 8 The performance hit consistently measures in the ~1.5% range: the test suite of @frioux's DBIx::Class::Helpers v2.032002 consistently completes within roughly ~63.7 CPU seconds at the base of this branch, yet climbs to ~64.6 as of this commit (on an idle low-clocked Xeon L3426) The warning can not be disabled for the time being (aside from monkeypatching DBIC::ResultSource) - the wide-range testing indicates it only fires on real legitimate problems. Hopefully I am making the right call... [1] http://lists.scsys.co.uk/pipermail/dbix-class/2016-January/012127.html --- Changes | 3 +- lib/DBIx/Class/Carp.pm | 20 +- lib/DBIx/Class/ResultSource.pm | 262 +++++++++++++++++++++- lib/DBIx/Class/ResultSource/View.pm | 5 +- lib/DBIx/Class/ResultSourceHandle.pm | 7 +- lib/DBIx/Class/ResultSourceProxy/Table.pm | 23 ++ lib/DBIx/Class/_Util.pm | 5 +- xt/dist/pod_coverage.t | 4 + xt/extra/diagnostics/divergent_metadata.t | 97 ++++++++ 9 files changed, 410 insertions(+), 16 deletions(-) create mode 100644 xt/extra/diagnostics/divergent_metadata.t diff --git a/Changes b/Changes index c2bb298d1..45b2f87f6 100644 --- a/Changes +++ b/Changes @@ -12,7 +12,8 @@ Revision history for DBIx::Class all seems out of place, please file a report at once - The unique constraint info (including the primary key columns) is no longer shared between related (class and schema-level) ResultSource - instances + instances. If your app stops working with no obvious pointers, set + DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE=1 to obtain extra info - Neither exception_action() nor $SIG{__DIE__} handlers are invoked on recoverable errors. This ensures that the retry logic is fully insulated from changes in control flow, as the handlers are only diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm index 9474dc1c3..e1c83a0ca 100644 --- a/lib/DBIx/Class/Carp.pm +++ b/lib/DBIx/Class/Carp.pm @@ -53,11 +53,23 @@ sub __find_caller { my $fr_num = 1; # skip us and the calling carp* - my (@f, $origin); + my (@f, $origin, $eval_src); while (@f = CORE::caller($fr_num++)) { - next if - ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ ); + undef $eval_src; + + next if ( + $f[2] == 0 + or + # there is no value reporting a sourceless eval frame + ( + ( $f[3] eq '(eval)' or $f[1] =~ /^\(eval \d+\)$/ ) + and + not defined ( $eval_src = (CORE::caller($fr_num))[6] ) + ) + or + $f[3] =~ /::__ANON__$/ + ); $origin ||= ( $f[3] =~ /^ (.+) :: ([^\:]+) $/x @@ -84,7 +96,7 @@ sub __find_caller { } my $site = @f # if empty - nothing matched - full stack - ? "at $f[1] line $f[2]" + ? ( "at $f[1] line $f[2]" . ( $eval_src ? "\n === BEGIN $f[1]\n$eval_src\n === END $f[1]" : '' ) ) : Carp::longmess() ; diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index d6ca1ed09..f8a1661b1 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -6,7 +6,11 @@ use warnings; use base 'DBIx::Class::ResultSource::RowParser'; use DBIx::Class::Carp; -use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try fail_on_internal_call ); +use DBIx::Class::_Util qw( + UNRESOLVABLE_CONDITION + dbic_internal_try fail_on_internal_call + refdesc emit_loud_diag +); use SQL::Abstract 'is_literal_value'; use Devel::GlobalDestruction; use Scalar::Util qw( blessed weaken isweak refaddr ); @@ -23,16 +27,16 @@ my @hashref_attributes = qw( my @arrayref_attributes = qw( _ordered_columns _primaries ); -__PACKAGE__->mk_group_accessors(simple => +__PACKAGE__->mk_group_accessors(rsrc_instance_specific_attribute => @hashref_attributes, @arrayref_attributes, qw( source_name name column_info_from_storage sqlt_deploy_callback ), ); -__PACKAGE__->mk_group_accessors(component_class => qw/ +__PACKAGE__->mk_group_accessors(rsrc_instance_specific_handler => qw( resultset_class result_class -/); +)); =head1 NAME @@ -200,7 +204,7 @@ Creates a new ResultSource object. Not normally called directly by end users. $self->{sqlt_deploy_callback} ||= 'default_sqlt_deploy_hook'; $self->{$_} = { %{ $self->{$_} || {} } } - for @hashref_attributes; + for @hashref_attributes, '__metadata_divergencies'; $self->{$_} = [ @{ $self->{$_} || [] } ] for @arrayref_attributes; @@ -217,6 +221,228 @@ Creates a new ResultSource object. Not normally called directly by end users. } values %$r } } + + + # needs direct access to $rsrc_registry under an assert + # + sub set_rsrc_instance_specific_attribute { + + # only mark if we are setting something different + if ( + ( + defined( $_[2] ) + xor + defined( $_[0]->{$_[1]} ) + ) + or + ( + # both defined + defined( $_[2] ) + and + ( + # differ in ref-ness + ( + length ref( $_[2] ) + xor + length ref( $_[0]->{$_[1]} ) + ) + or + # both refs (the mark-on-same-ref is deliberate) + length ref( $_[2] ) + or + # both differing strings + $_[2] ne $_[0]->{$_[1]} + ) + ) + ) { + + my $callsite; + # need to protect $_ here + for my $derivative ( + $_[0]->__derived_instances, + + # DO NOT REMOVE - this blob is marking *ancestors* as tainted, here to + # weed out any fallout from https://github.com/dbsrgits/dbix-class/commit/9e36e3ec + # Note that there is no way to kill this warning, aside from never + # calling set_primary_key etc more than once per hierarchy + # (this is why the entire thing is guarded by an assert) + ( + ( + DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + and + grep { $_[1] eq $_ } qw( _unique_constraints _primaries source_info ) + ) + ? ( + map + { defined($_->{weakref}) ? $_->{weakref} : () } + grep + { defined( ( $_->{derivatives}{refaddr($_[0])} || {} )->{weakref} ) } + values %$rsrc_registry + ) + : () + ), + ) { + + $derivative->{__metadata_divergencies}{$_[1]}{ $callsite ||= do { + + # + # FIXME - this is horrible, but it's the best we can do for now + # Replace when Carp::Skip is written (it *MUST* take this use-case + # into consideration) + # + my ($cs) = DBIx::Class::Carp::__find_caller(__PACKAGE__); + + my ($fr_num, @fr) = 1; + while( @fr = CORE::caller($fr_num++) ) { + $cs =~ /^ \Qat $fr[1] line $fr[2]\E (?: $ | \n )/x + and + $fr[3] =~ s/.+::// + and + last + } + + # FIXME - using refdesc here isn't great, but I can't think of anything + # better at this moment + @fr + ? "@{[ refdesc $_[0] ]}->$fr[3](...) $cs" + : "$cs" + ; + } } = 1; + } + } + + $_[0]->{$_[1]} = $_[2]; + } +} + +sub get_rsrc_instance_specific_attribute { + + $_[0]->__emit_stale_metadata_diag( $_[1] ) if ( + ! $_[0]->{__in_rsrc_setter_callstack} + and + $_[0]->{__metadata_divergencies}{$_[1]} + ); + + $_[0]->{$_[1]}; +} + + +# reuse the elaborate set logic of instance_specific_attr +sub set_rsrc_instance_specific_handler { + $_[0]->set_rsrc_instance_specific_attribute($_[1], $_[2]); + + # trigger a load for the case of $foo->handler_accessor("bar")->new + $_[0]->get_rsrc_instance_specific_handler($_[1]) + if defined wantarray; +} + +# This is essentially the same logic as get_component_class +# (in DBIC::AccessorGroup). However the latter is a grouped +# accessor type, and here we are strictly after a 'simple' +# So we go ahead and recreate the logic as found in ::AG +sub get_rsrc_instance_specific_handler { + + # emit desync warnings if any + my $val = $_[0]->get_rsrc_instance_specific_attribute( $_[1] ); + + # plain string means class - load it + no strict 'refs'; + if ( + defined $val + and + # inherited CAG can't be set to undef effectively, so people may use '' + length $val + and + ! defined blessed $val + and + ! ${"${val}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} + ) { + $_[0]->ensure_class_loaded($val); + + ${"${val}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} + = do { \(my $anon = 'loaded') }; + } + + $val; +} + + +sub __construct_stale_metadata_diag { + return '' unless $_[0]->{__metadata_divergencies}{$_[1]}; + + my ($fr_num, @fr); + + # find the CAG getter FIRST + # allows unlimited user-namespace overrides without screwing around with + # $LEVEL-like crap + while( + @fr = CORE::caller(++$fr_num) + and + $fr[3] ne 'DBIx::Class::ResultSource::get_rsrc_instance_specific_attribute' + ) { 1 } + + Carp::confess( "You are not supposed to call __construct_stale_metadata_diag here..." ) + unless @fr; + + # then find the first non-local, non-private reportable callsite + while ( + @fr = CORE::caller(++$fr_num) + and + ( + $fr[2] == 0 + or + $fr[3] eq '(eval)' + or + $fr[1] =~ /^\(eval \d+\)$/ + or + $fr[3] =~ /::(?: __ANON__ | _\w+ )$/x + or + $fr[0] =~ /^DBIx::Class::ResultSource/ + ) + ) { 1 } + + my $by = ( @fr and $fr[3] =~ s/.+::// ) + # FIXME - using refdesc here isn't great, but I can't think of anything + # better at this moment + ? " by 'getter' @{[ refdesc $_[0] ]}->$fr[3](...)\n within the callstack beginning" + : '' + ; + + # Given the full stacktrace combined with the really involved callstack + # there is no chance the emitter will properly deduplicate this + # Only complain once per callsite per source + return( ( $by and $_[0]->{__encountered_divergencies}{$by}++ ) + + ? '' + + : "$_[0] (the metadata instance of source '@{[ $_[0]->source_name ]}') is " + . "*OUTDATED*, and does not reflect the modifications of its " + . "*ancestors* as follows:\n" + . join( "\n", + map + { " * $_->[0]" } + sort + { $a->[1] cmp $b->[1] } + map + { [ $_, ( $_ =~ /( at .+? line \d+)/ ) ] } + keys %{ $_[0]->{__metadata_divergencies}{$_[1]} } + ) + . "\nStale metadata accessed${by}" + ); +} + +sub __emit_stale_metadata_diag { + emit_loud_diag( + msg => ( + # short circuit: no message - no diag + $_[0]->__construct_stale_metadata_diag($_[1]) + || + return 0 + ), + # the constructor already does deduplication + emit_dups => 1, + confess => DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE, + ); } =head2 clone @@ -443,6 +669,10 @@ info keys as L. sub add_columns { my ($self, @cols) = @_; + + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + $self->_ordered_columns(\@cols) unless $self->_ordered_columns; my ( @added, $colinfos ); @@ -470,6 +700,7 @@ sub add_columns { } push @{ $self->_ordered_columns }, @added; + $self->_columns($columns); return $self; } @@ -666,6 +897,9 @@ broken result source. sub remove_columns { my ($self, @to_remove) = @_; + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + my $columns = $self->_columns or return; @@ -710,6 +944,9 @@ for more info. sub set_primary_key { my ($self, @cols) = @_; + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + my $colinfo = $self->columns_info(\@cols); for my $col (@cols) { carp_unique(sprintf ( @@ -792,6 +1029,9 @@ will be applied to the L of each L sub sequence { my ($self,$seq) = @_; + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + my @pks = $self->primary_columns or return; @@ -838,6 +1078,9 @@ the result source. sub add_unique_constraint { my $self = shift; + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + if (@_ > 2) { $self->throw_exception( 'add_unique_constraint() does not accept multiple constraints, use ' @@ -1329,10 +1572,11 @@ result source instance has been attached to. sub schema { if (@_ > 1) { - $_[0]->{schema} = $_[1]; + # invoke the mark-diverging logic + $_[0]->set_rsrc_instance_specific_attribute( schema => $_[1] ); } else { - $_[0]->{schema} || do { + $_[0]->get_rsrc_instance_specific_attribute( 'schema' ) || do { my $name = $_[0]->{source_name} || '_unnamed_'; my $err = 'Unable to perform storage-dependent operations with a detached result source ' . "(source '$name' is not associated with a schema)."; @@ -1448,6 +1692,10 @@ be resolved. sub add_relationship { my ($self, $rel, $f_source_name, $cond, $attrs) = @_; + + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + $self->throw_exception("Can't create relationship without join condition") unless $cond; $attrs ||= {}; diff --git a/lib/DBIx/Class/ResultSource/View.pm b/lib/DBIx/Class/ResultSource/View.pm index ede6d1d44..818295ec2 100644 --- a/lib/DBIx/Class/ResultSource/View.pm +++ b/lib/DBIx/Class/ResultSource/View.pm @@ -5,8 +5,9 @@ use warnings; use base 'DBIx::Class::ResultSource'; -__PACKAGE__->mk_group_accessors( - 'simple' => qw(is_virtual view_definition deploy_depends_on) ); +__PACKAGE__->mk_group_accessors( rsrc_instance_specific_attribute => qw( + is_virtual view_definition deploy_depends_on +)); =head1 NAME diff --git a/lib/DBIx/Class/ResultSourceHandle.pm b/lib/DBIx/Class/ResultSourceHandle.pm index b9b54bf5c..169cb4a78 100644 --- a/lib/DBIx/Class/ResultSourceHandle.pm +++ b/lib/DBIx/Class/ResultSourceHandle.pm @@ -116,7 +116,12 @@ sub STORABLE_thaw { $self->schema( $s ); } else { - $rs->source_name( $self->source_moniker ); + # FIXME do not use accessor here - will trigger the divergent meta logic + # Ideally this should be investigated and fixed properly, but the + # codepath is so obscure, and the trigger point (t/52leaks.t) so bizarre + # that... meh. + $rs->{source_name} = $self->source_moniker; + $rs->{_detached_thaw} = 1; $self->_detached_source( $rs ); } diff --git a/lib/DBIx/Class/ResultSourceProxy/Table.pm b/lib/DBIx/Class/ResultSourceProxy/Table.pm index 53dd26f03..b0c4343e1 100644 --- a/lib/DBIx/Class/ResultSourceProxy/Table.pm +++ b/lib/DBIx/Class/ResultSourceProxy/Table.pm @@ -93,6 +93,29 @@ sub table { : undef ; + # Folks calling ->table on a class *might* expect the name + # to shift everywhere, but that can't happen + # So what we do is mark the ancestor as "dirty" + # even though it will have no "derived" link to the one we + # will use afterwards + if( + defined $ancestor + and + $ancestor->name ne $table + and + scalar $ancestor->__derived_instances + ) { + # Trigger the "descendants are dirty" logic, without giving + # it an explicit externally-callable interface + # This is ugly as sin, but likely saner in the long run + local $ancestor->{__in_rsrc_setter_callstack} = 1 + unless $ancestor->{__in_rsrc_setter_callstack}; + my $old_name = $ancestor->name; + $ancestor->set_rsrc_instance_specific_attribute( name => "\0" ); + $ancestor->set_rsrc_instance_specific_attribute( name => $old_name ); + } + + my $table_class = $class->table_class; $class->ensure_class_loaded($table_class); diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index c459c73c2..7f3549dc6 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -411,7 +411,10 @@ sub emit_loud_diag { exit 70; } - my $msg = "\n$0: $args->{msg}"; + my $msg = "\n" . join( ': ', + ( $0 eq '-e' ? () : $0 ), + $args->{msg} + ); # when we die - we usually want to keep doing it $args->{emit_dups} = !!$args->{confess} diff --git a/xt/dist/pod_coverage.t b/xt/dist/pod_coverage.t index 004f35e11..e2389af4c 100644 --- a/xt/dist/pod_coverage.t +++ b/xt/dist/pod_coverage.t @@ -67,6 +67,10 @@ my $exceptions = { resolve_prefetch STORABLE_freeze STORABLE_thaw + get_rsrc_instance_specific_attribute + set_rsrc_instance_specific_attribute + get_rsrc_instance_specific_handler + set_rsrc_instance_specific_handler /], }, 'DBIx::Class::ResultSet' => { diff --git a/xt/extra/diagnostics/divergent_metadata.t b/xt/extra/diagnostics/divergent_metadata.t new file mode 100644 index 000000000..67e9bea1e --- /dev/null +++ b/xt/extra/diagnostics/divergent_metadata.t @@ -0,0 +1,97 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +# things will die if this is set +BEGIN { $ENV{DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE} = 0 } + +use strict; +use warnings; + +use Test::More; + +use DBICTest::Util 'capture_stderr'; +use DBICTest; + +my ($fn) = __FILE__ =~ /( [^\/\\]+ ) $/x; +my @divergence_lines; + +my $art = DBICTest->init_schema->resultset("Artist")->find(1); + +push @divergence_lines, __LINE__ + 1; +DBICTest::Schema::Artist->add_columns("Something_New"); + +push @divergence_lines, __LINE__ + 1; +$_->add_column("Something_New_2") for grep + { $_ != $art->result_source } + DBICTest::Schema::Artist->result_source_instance->__derived_instances +; + +push @divergence_lines, __LINE__ + 1; +DBICTest::Schema::Artist->result_source_instance->name("foo"); + +my $orig_class_rsrc_before_table_triggered_reinit = DBICTest::Schema::Artist->result_source_instance; + +push @divergence_lines, __LINE__ + 1; +DBICTest::Schema::Artist->table("bar"); + +is( + capture_stderr { + ok( + DBICTest::Schema::Artist->has_column( "Something_New" ), + 'Added column visible' + ); + + ok( + (! DBICTest::Schema::Artist->has_column( "Something_New_2" ) ), + 'Column added on children not visible' + ); + }, + '', + 'No StdErr output during rsrc augmentation' +); + +my $err = capture_stderr { + ok( + ! $art->has_column($_), + "Column '$_' not visible on @{[ $art->table ]}" + ) for qw(Something_New Something_New_2); +}; + +# Tricky text - check it painstakingly as things may go off +# in very subtle ways +my $expected_warning_1 = join '.+?', map { quotemeta $_ } + "@{[ $art->result_source ]} (the metadata instance of source 'Artist') is *OUTDATED*", + + "${orig_class_rsrc_before_table_triggered_reinit}->add_columns(...) at", + "$fn line $divergence_lines[0]", + + "@{[ DBICTest::Schema->source('Artist') ]}->add_column(...) at", + "$fn line $divergence_lines[1]", + + "Stale metadata accessed by 'getter' @{[ $art->result_source ]}->has_column(...)", +; + +like + $err, + qr/$expected_warning_1/s, + 'Correct warning on diverged metadata' +; + +my $expected_warning_2 = join '.+?', map { quotemeta $_ } + "@{[ $art->result_source ]} (the metadata instance of source 'Artist') is *OUTDATED*", + + "${orig_class_rsrc_before_table_triggered_reinit}->name(...) at", + "$fn line $divergence_lines[2]", + + "${orig_class_rsrc_before_table_triggered_reinit}->table(...) at", + "$fn line $divergence_lines[3]", + + "Stale metadata accessed by 'getter' @{[ $art->result_source ]}->table(...)", +; + +like + $err, + qr/$expected_warning_2/s, + 'Correct warning on diverged metadata' +; + +done_testing; From d56e05c74844b8b22f4f66e378b6ef992045a7b5 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 22 Jul 2016 12:59:40 +0200 Subject: [PATCH 195/262] An extra bit of diag on incomplete rsrc re-register Due to the counterintuitive nature of the metadata subsystem, a user wishing to modify the metadata for a result class at runtime (post $schema instance initialization), may end up in a situation where *everything* appears to work but falls apart on the next call to My::Schema->connect. In fact I myself made this very mistake in https://github.com/ctrlo/GADS/pull/1/files, even though I was pretty well aware of the dangers at the time. In order to make this go away for good reuse the meta-metadata kept around to track rsrc ancestry and modifications, and emit a warning alerting folks to the potential problem (the *actual* problematic desync will also be warned about at a later step by the stale-metadata diag). --- lib/DBIx/Class/Schema.pm | 40 +++++++++++++++++++- xt/extra/diagnostics/incomplete_reregister.t | 26 +++++++++++++ 2 files changed, 65 insertions(+), 1 deletion(-) create mode 100644 xt/extra/diagnostics/incomplete_reregister.t diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 9961c08d9..45dcd7e81 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -1466,7 +1466,7 @@ sub _register_source { $derived_rsrc->schema($self); weaken $derived_rsrc->{schema} - if length ref($self); + if length( my $schema_class = ref($self) ); my %reg = %{$self->source_registrations}; $reg{$source_name} = $derived_rsrc; @@ -1498,6 +1498,44 @@ sub _register_source { $map{$result_class} = $source_name; $self->class_mappings(\%map); + + + my $schema_class_level_rsrc; + if ( + # we are called on a schema instance, not on the class + length $schema_class + + and + + # the schema class also has a registration with the same name + $schema_class_level_rsrc = dbic_internal_try { $schema_class->source($source_name) } + + and + + # what we are registering on the schema instance *IS* derived + # from the class-level (top) rsrc... + ( grep { $_ == $derived_rsrc } $result_class_level_rsrc->__derived_instances ) + + and + + # ... while the schema-class-level has stale-markers + keys %{ $schema_class_level_rsrc->{__metadata_divergencies} || {} } + ) { + my $msg = + "The ResultSource instance you just registered on '$self' as " + . "'$source_name' seems to have no relation to $schema_class->" + . "source('$source_name') which in turn is marked stale (likely due " + . "to recent $result_class->... direct class calls). This is almost " + . "always a mistake: perhaps you forgot a cycle of " + . "$schema_class->unregister_source( '$source_name' ) / " + . "$schema_class->register_class( '$source_name' => '$result_class' )" + ; + + DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + ? emit_loud_diag( msg => $msg, confess => 1 ) + : carp_unique($msg) + ; + } } $derived_rsrc; diff --git a/xt/extra/diagnostics/incomplete_reregister.t b/xt/extra/diagnostics/incomplete_reregister.t new file mode 100644 index 000000000..27469b1a2 --- /dev/null +++ b/xt/extra/diagnostics/incomplete_reregister.t @@ -0,0 +1,26 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +# things will die if this is set +BEGIN { $ENV{DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE} = 0 } + +use strict; +use warnings; + +use Test::More; +use Test::Warn; + +use DBICTest; + +my $s = DBICTest->init_schema( no_deploy => 1 ); + + +warnings_exist { + DBICTest::Schema::Artist->add_column("somethingnew"); + $s->unregister_source("Artist"); + $s->register_class( Artist => "DBICTest::Schema::Artist" ); +} + qr/The ResultSource instance you just registered on .+ \Qas 'Artist' seems to have no relation to DBICTest::Schema->source('Artist') which in turn is marked stale/, + 'Expected warning on incomplete re-register of schema-class-level source' +; + +done_testing; From 4c90556806f286093d0806e858abdba329e6dfd3 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 23 May 2016 11:08:17 +0200 Subject: [PATCH 196/262] Some test suite corrections ahead of next commits Splitting this off for easier reading --- t/35exception_inaction.t | 1 - t/72pg.t | 7 ++++++- t/73oracle.t | 7 ++++++- t/99dbic_sqlt_parser.t | 2 +- t/lib/DBICTest/Schema/Year2000CDs.pm | 5 +++++ t/lib/testinclude/DBICTestAdminInc.pm | 2 +- t/lib/testinclude/DBICTestConfig.pm | 2 +- 7 files changed, 20 insertions(+), 6 deletions(-) diff --git a/t/35exception_inaction.t b/t/35exception_inaction.t index 6c032d681..a75ee6142 100644 --- a/t/35exception_inaction.t +++ b/t/35exception_inaction.t @@ -39,7 +39,6 @@ sub ok { return !!$_[0]; } - # this is incredibly horrible... # demonstrate utter breakage of the reconnection/retry logic # diff --git a/t/72pg.t b/t/72pg.t index 6c2545f3d..9d379302e 100644 --- a/t/72pg.t +++ b/t/72pg.t @@ -79,8 +79,13 @@ for my $use_insert_returning ($test_server_supports_insert_returning : (0) ) { - no warnings qw/once redefine/; + # doing it here instead of the actual class to keep the main thing under dfs + # and thus keep catching false positives (so far none, but one never knows) + mro::set_mro("DBICTest::Schema", "c3"); + my $old_connection = DBICTest::Schema->can('connection'); + + no warnings qw/once redefine/; local *DBICTest::Schema::connection = set_subname 'DBICTest::Schema::connection' => sub { my $s = shift->$old_connection(@_); $s->storage->_use_insert_returning ($use_insert_returning); diff --git a/t/73oracle.t b/t/73oracle.t index b61a6a805..e7096ea4d 100644 --- a/t/73oracle.t +++ b/t/73oracle.t @@ -109,8 +109,13 @@ my $schema; for my $use_insert_returning ($test_server_supports_insert_returning ? (1,0) : (0) ) { for my $force_ora_joins ($test_server_supports_only_orajoins ? (0) : (0,1) ) { - no warnings qw/once redefine/; + # doing it here instead of the actual class to keep the main thing under dfs + # and thus keep catching false positives (so far none, but one never knows) + mro::set_mro("DBICTest::Schema", "c3"); + my $old_connection = DBICTest::Schema->can('connection'); + + no warnings qw/once redefine/; local *DBICTest::Schema::connection = set_subname 'DBICTest::Schema::connection' => sub { my $s = shift->$old_connection (@_); $s->storage->_use_insert_returning ($use_insert_returning); diff --git a/t/99dbic_sqlt_parser.t b/t/99dbic_sqlt_parser.t index 51e25215e..2ab43a33e 100644 --- a/t/99dbic_sqlt_parser.t +++ b/t/99dbic_sqlt_parser.t @@ -196,7 +196,7 @@ lives_ok (sub { { package DBICTest::PartialSchema; - use base qw/DBIx::Class::Schema/; + use base qw/DBICTest::BaseSchema/; __PACKAGE__->load_classes( { 'DBICTest::Schema' => [qw/ diff --git a/t/lib/DBICTest/Schema/Year2000CDs.pm b/t/lib/DBICTest/Schema/Year2000CDs.pm index 6ee67d58d..1cf1b3736 100644 --- a/t/lib/DBICTest/Schema/Year2000CDs.pm +++ b/t/lib/DBICTest/Schema/Year2000CDs.pm @@ -6,6 +6,11 @@ use strict; use base qw/DBICTest::Schema::CD/; +# FIXME not entirely sure *why* this particular bit trips up tests +# and even more mysteriously: only a single oracle test... +# Running out of time and no local Oracle so can't investigate :/ +use mro 'c3'; + __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year2000cds'); diff --git a/t/lib/testinclude/DBICTestAdminInc.pm b/t/lib/testinclude/DBICTestAdminInc.pm index 212d33dc6..710dab057 100644 --- a/t/lib/testinclude/DBICTestAdminInc.pm +++ b/t/lib/testinclude/DBICTestAdminInc.pm @@ -5,6 +5,6 @@ use strict; use base 'DBICTest::BaseSchema'; -sub connect { exit 70 } # this is what the test will expect to see +sub connection { exit 70 } # this is what the test will expect to see 1; diff --git a/t/lib/testinclude/DBICTestConfig.pm b/t/lib/testinclude/DBICTestConfig.pm index e531dc4be..e59982f40 100644 --- a/t/lib/testinclude/DBICTestConfig.pm +++ b/t/lib/testinclude/DBICTestConfig.pm @@ -5,7 +5,7 @@ use strict; use base 'DBICTest::BaseSchema'; -sub connect { +sub connection { my($self, @opt) = @_; @opt == 4 and $opt[0] eq 'klaatu' From 1b822bd3e15476666e97d9a95754f123410b3c56 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 27 May 2016 16:14:28 +0200 Subject: [PATCH 197/262] Annotate every indirect sugar-method Now that the churn is over we can add annotations to each method a user ought to never override. See next commit for the actual use case and diagnostics emitter. Unfortunately this adds yet another small compile-time hit, similar to 73f54e27 (a hit incurred regardless whether the upcoming validation framework is used or not). Complete test of DBIx::Class::Helpers v2.032002 goes from about ~64.6 seconds CPU time up to ~65.5, adding another ~1% of startup speed loss. The savings in debugging sessions should make this all worth it... or so one hopes. --- lib/DBIx/Class/AccessorGroup.pm | 4 +-- lib/DBIx/Class/MethodAttributes.pm | 28 ++++++++++++++---- lib/DBIx/Class/Relationship/Accessor.pm | 16 ++++++++-- lib/DBIx/Class/Relationship/Base.pm | 10 +++---- lib/DBIx/Class/Relationship/ManyToMany.pm | 35 +++++++++++++++------- lib/DBIx/Class/ResultSet.pm | 10 +++---- lib/DBIx/Class/ResultSetColumn.pm | 12 ++++---- lib/DBIx/Class/ResultSource.pm | 10 +++---- lib/DBIx/Class/ResultSourceProxy.pm | 15 ++++++++-- lib/DBIx/Class/Row.pm | 4 +-- lib/DBIx/Class/Schema.pm | 4 +-- lib/DBIx/Class/Storage.pm | 2 +- lib/DBIx/Class/_Util.pm | 36 +++++++++++++++++++++++ t/lib/DBICTest/BaseSchema.pm | 13 +++++++- 14 files changed, 148 insertions(+), 51 deletions(-) diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index 77cf85255..5ccc10983 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -9,12 +9,12 @@ use Scalar::Util 'blessed'; use DBIx::Class::_Util 'fail_on_internal_call'; use namespace::clean; -sub mk_classdata { +sub mk_classdata :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->mk_classaccessor(@_); } -sub mk_classaccessor { +sub mk_classaccessor :DBIC_method_is_indirect_sugar { my $self = shift; $self->mk_group_accessors('inherited', $_[0]); (@_ > 1) diff --git a/lib/DBIx/Class/MethodAttributes.pm b/lib/DBIx/Class/MethodAttributes.pm index 7ffe56095..0dec0b308 100644 --- a/lib/DBIx/Class/MethodAttributes.pm +++ b/lib/DBIx/Class/MethodAttributes.pm @@ -143,8 +143,22 @@ sub MODIFY_CODE_ATTRIBUTES { sub VALID_DBIC_CODE_ATTRIBUTE { #my ($class, $attr) = @_; - # initially no valid attributes - 0; +### +### !!! IMPORTANT !!! +### +### *DO NOT* yield to the temptation of using free-form-argument attributes. +### The technique was proven instrumental in Catalyst a decade ago, and +### was more recently revived in Sub::Attributes. Yet, while on the surface +### they seem immensely useful, per-attribute argument lists are in fact an +### architectural dead end. +### +### In other words: you are *very strongly urged* to ensure the regex below +### does not allow anything beyond qr/^ DBIC_method_is_ [A-Z_a-z0-9]+ $/x +### + + $_[1] =~ /^ DBIC_method_is_ (?: + indirect_sugar + ) $/x; } sub FETCH_CODE_ATTRIBUTES { @@ -200,11 +214,13 @@ L below. The following method attributes are currently recognized under the C prefix: -=over - -=item * None so far +=head3 DBIC_method_is_indirect_sugar -=back +The presence of this attribute indicates a helper "sugar" method. Overriding +such methods in your subclasses will be of limited success at best, as DBIC +itself and various plugins are much more likely to invoke alternative direct +call paths, bypassing your override entirely. Good examples of this are +L and L. =head1 METHODS diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index d281e00ca..a408b69f1 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -104,20 +104,30 @@ EOC elsif ($acc_type eq 'multi') { - quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel ); + my @qsub_args = ( + {}, + { + attributes => [qw( + DBIC_method_is_indirect_sugar + )] + }, + ); + + + quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel ), @qsub_args; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; shift->related_resultset(%s)->search( @_ ) EOC - quote_sub "${class}::${rel}_rs", sprintf( <<'EOC', perlstring $rel ); + quote_sub "${class}::${rel}_rs", sprintf( <<'EOC', perlstring $rel ), @qsub_args; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; shift->related_resultset(%s)->search_rs( @_ ) EOC - quote_sub "${class}::add_to_${rel}", sprintf( <<'EOC', perlstring $rel ); + quote_sub "${class}::add_to_${rel}", sprintf( <<'EOC', perlstring $rel ), @qsub_args; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; shift->create_related( %s => @_ ); EOC diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index 994e7d70c..007676e04 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -611,7 +611,7 @@ See L for more information. =cut -sub search_related { +sub search_related :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->related_resultset(shift)->search(@_); } @@ -623,7 +623,7 @@ it guarantees a resultset, even in list context. =cut -sub search_related_rs { +sub search_related_rs :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->related_resultset(shift)->search_rs(@_) } @@ -643,7 +643,7 @@ current result or where conditions. =cut -sub count_related { +sub count_related :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->related_resultset(shift)->search_rs(@_)->count; } @@ -720,7 +720,7 @@ See L for details. =cut -sub find_related { +sub find_related :DBIC_method_is_indirect_sugar { #my ($self, $rel, @args) = @_; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return shift->related_resultset(shift)->find(@_); @@ -785,7 +785,7 @@ L for details. =cut -sub update_or_create_related { +sub update_or_create_related :DBIC_method_is_indirect_sugar { #my ($self, $rel, @args) = @_; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->related_resultset(shift)->update_or_create(@_); diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm index 0c31ebba9..fdd46972c 100644 --- a/lib/DBIx/Class/Relationship/ManyToMany.pm +++ b/lib/DBIx/Class/Relationship/ManyToMany.pm @@ -56,7 +56,15 @@ EOW } } - quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ); + my @main_meth_qsub_args = ( + {}, + { attributes => [ + 'DBIC_method_is_indirect_sugar', + ] }, + ); + + + quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ), @main_meth_qsub_args; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; @@ -67,13 +75,18 @@ EOW EOC - my $qsub_attrs = { - '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } }, - '$carp_unique' => \$cu, - }; + my @extra_meth_qsub_args = ( + { + '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } }, + '$carp_unique' => \$cu, + }, + { attributes => [ + 'DBIC_method_is_indirect_sugar', + ] }, + ); - quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', map { perlstring $_ } ( "${class}::${meth}", $rel, $f_rel ) ), $qsub_attrs; + quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', map { perlstring $_ } ( "${class}::${meth}", $rel, $f_rel ) ), @extra_meth_qsub_args; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and @@ -95,8 +108,11 @@ EOC ; EOC + # the above is the only indirect method, the 3 below have too much logic + shift @{$extra_meth_qsub_args[1]{attributes}}; - quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), $qsub_attrs; + + quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), @extra_meth_qsub_args; ( @_ >= 2 and @_ <= 3 ) or $_[0]->throw_exception( "'%1$s' expects an object or hashref to link to, and an optional hashref of link data" @@ -140,7 +156,7 @@ EOC EOC - quote_sub "${class}::${set_meth}", sprintf( <<'EOC', $set_meth, $add_meth, $rel, $f_rel ), $qsub_attrs; + quote_sub "${class}::${set_meth}", sprintf( <<'EOC', $set_meth, $add_meth, $rel, $f_rel ), @extra_meth_qsub_args; my $self = shift; @@ -190,8 +206,7 @@ EOC $guard->commit if $guard; EOC - - quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel ); + quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel ), @extra_meth_qsub_args; $_[0]->throw_exception("'%1$s' expects an object") unless defined Scalar::Util::blessed( $_[1] ); diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 2c5131d7a..3d06065d2 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -986,7 +986,7 @@ See also L. =cut -sub search_related { +sub search_related :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return shift->related_resultset(shift)->search(@_); } @@ -998,7 +998,7 @@ it guarantees a resultset, even in list context. =cut -sub search_related_rs { +sub search_related_rs :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return shift->related_resultset(shift)->search_rs(@_); } @@ -1769,7 +1769,7 @@ with the passed arguments, then L. =cut -sub count_literal { +sub count_literal :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->search_literal(@_)->count } @@ -1849,7 +1849,7 @@ an object for the first result (or C if the resultset is empty). =cut -sub first { +sub first :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return $_[0]->reset->next; } @@ -2867,7 +2867,7 @@ L. =cut -sub create { +sub create :DBIC_method_is_indirect_sugar { #my ($self, $col_data) = @_; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return shift->new_result(shift)->insert; diff --git a/lib/DBIx/Class/ResultSetColumn.pm b/lib/DBIx/Class/ResultSetColumn.pm index 71cd52c8c..a5141390d 100644 --- a/lib/DBIx/Class/ResultSetColumn.pm +++ b/lib/DBIx/Class/ResultSetColumn.pm @@ -278,7 +278,7 @@ resultset (or C if there are none). =cut -sub min { +sub min :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; $_[0]->func('MIN'); } @@ -299,7 +299,7 @@ Wrapper for ->func_rs for function MIN(). =cut -sub min_rs { +sub min_rs :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; $_[0]->func_rs('MIN') } @@ -321,7 +321,7 @@ resultset (or C if there are none). =cut -sub max { +sub max :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; $_[0]->func('MAX'); } @@ -342,7 +342,7 @@ Wrapper for ->func_rs for function MAX(). =cut -sub max_rs { +sub max_rs :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; $_[0]->func_rs('MAX') } @@ -364,7 +364,7 @@ the resultset. Use on varchar-like columns at your own risk. =cut -sub sum { +sub sum :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; $_[0]->func('SUM'); } @@ -385,7 +385,7 @@ Wrapper for ->func_rs for function SUM(). =cut -sub sum_rs { +sub sum_rs :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; $_[0]->func_rs('SUM') } diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index f8a1661b1..85d0bfca6 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -704,7 +704,7 @@ sub add_columns { return $self; } -sub add_column { +sub add_column :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->add_columns(@_) } @@ -748,7 +748,7 @@ contents of the hashref. =cut -sub column_info { +sub column_info :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; #my ($self, $column) = @_; @@ -912,7 +912,7 @@ sub remove_columns { $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]); } -sub remove_column { +sub remove_column :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->remove_columns(@_) } @@ -1143,7 +1143,7 @@ See also L. =cut -sub add_unique_constraints { +sub add_unique_constraints :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; my $self = shift; @@ -1606,7 +1606,7 @@ Returns the L for the current schema. =cut -sub storage { +sub storage :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; $_[0]->schema->storage } diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm index cfd37cab8..cd18d2e3e 100644 --- a/lib/DBIx/Class/ResultSourceProxy.pm +++ b/lib/DBIx/Class/ResultSourceProxy.pm @@ -6,6 +6,9 @@ use warnings; use base 'DBIx::Class'; +# needs to be loaded early to query method attributes below +use DBIx::Class::ResultSource; + use DBIx::Class::_Util qw( quote_sub fail_on_internal_call ); use namespace::clean; @@ -38,7 +41,7 @@ sub add_columns { } } -sub add_column { +sub add_column :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->add_columns(@_) } @@ -53,7 +56,7 @@ sub add_relationship { # legacy resultset_class accessor, seems to be used by cdbi only -sub iterator_class { +sub iterator_class :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->result_source->resultset_class(@_) } @@ -89,7 +92,13 @@ for my $method_to_proxy (qw/ relationship_info has_relationship /) { - quote_sub __PACKAGE__."::$method_to_proxy", sprintf( <<'EOC', $method_to_proxy ); + + my $qsub_opts = { attributes => [ do { + no strict 'refs'; + attributes::get( \&{"DBIx::Class::ResultSource::$method_to_proxy"} ) + } ] }; + + quote_sub __PACKAGE__."::$method_to_proxy", sprintf( <<'EOC', $method_to_proxy ), {}, $qsub_opts; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; shift->result_source->%s (@_); diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 1097701c4..7ccebb41e 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -1359,7 +1359,7 @@ Alias for L =cut -sub insert_or_update { +sub insert_or_update :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->update_or_insert(@_); } @@ -1429,7 +1429,7 @@ Accessor to the L this object was created from. =cut -sub result_source { +sub result_source :DBIC_method_is_indirect_sugar { # While getter calls are routed through here for sensible exception text # it makes no sense to have setters do the same thing DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 45dcd7e81..618b58529 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -552,7 +552,7 @@ version, overload L instead. =cut -sub connect { +sub connect :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->clone->connection(@_); } @@ -835,7 +835,7 @@ those values. =cut -sub populate { +sub populate :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; my ($self, $name, $data) = @_; diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm index d949b01e4..c8f0180ef 100644 --- a/lib/DBIx/Class/Storage.pm +++ b/lib/DBIx/Class/Storage.pm @@ -25,7 +25,7 @@ __PACKAGE__->mk_group_accessors(component_class => 'cursor_class'); __PACKAGE__->cursor_class('DBIx::Class::Cursor'); -sub cursor { +sub cursor :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->cursor_class(@_); } diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 7f3549dc6..e94d98d52 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -1065,6 +1065,42 @@ sub fail_on_internal_call { : $fr ; + + die "\nMethod $fr->[3] is not marked with the 'DBIC_method_is_indirect_sugar' attribute\n\n" unless ( + + # unlikely but who knows... + ! @$fr + + or + + # This is a weird-ass double-purpose method, only one branch of which is marked + # as an illegal indirect call + # Hence the 'indirect' attribute makes no sense + # FIXME - likely need to mark this in some other manner + $fr->[3] eq 'DBIx::Class::ResultSet::new' + + or + + # RsrcProxy stuff is special and not attr-annotated on purpose + # Yet it is marked (correctly) as fail_on_internal_call(), as DBIC + # itself should not call these methods as first-entry + $fr->[3] =~ /^DBIx::Class::ResultSourceProxy::[^:]+$/ + + or + + # FIXME - there is likely a more fine-graned way to escape "foreign" + # callers, based on annotations... (albeit a slower one) + # For the time being just skip in a dumb way + $fr->[3] !~ /^DBIx::Class|^DBICx::|^DBICTest::/ + + or + + grep + { $_ eq 'DBIC_method_is_indirect_sugar' } + do { no strict 'refs'; attributes::get( \&{ $fr->[3] }) } + ); + + if ( defined $fr->[0] and diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index 5f52f75b0..6c293cc29 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -443,6 +443,12 @@ sub connection { }; weaken( $assertion_arounds->{refaddr $replacement} = $replacement ); + + attributes->import( + $origin, + $replacement, + attributes::get($orig_rsrc) + ); } @@ -518,8 +524,13 @@ sub connection { }; weaken( $assertion_arounds->{refaddr $replacement} = $replacement ); - } + attributes->import( + $origin, + $replacement, + attributes::get($orig_rsrc_instance) + ); + } } Class::C3::initialize if DBIx::Class::_ENV_::OLD_MRO; From 12e7015aa9372aeaf1aaa7e125b8ac8da216deb5 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 23 May 2016 11:08:17 +0200 Subject: [PATCH 198/262] Introducing DBIx::Class::Schema::SanityChecker This gives us comprehensive diagnostic on incorrect component composition and other hard to track... stuff. Given the huge amount of changes to call chains (specifically the changes in 77c3a5dc and e5053694), and the fallout seen on CPAN and darkpan due to these modifications, the status quo became clearly untennable. To mitigate the (often silent) breakage a brand new "sanity check" framework was introduced as part of the ::Schema setup-cycle (and is enabled by default) Same DBIx::Class::Helper v2.032002 test time shoots from 65.5s all the way to 76.0s, a 16% slowdown. However the moment the framework is disabled by flipping $schema->schema_sanity_checker to a defined-but-false value - the startup impact is entirely gone. The changset was extensively tested against the following set of downstream dists (a superset of c8b1011e), with each warning hand-confirmed to be a valid description of a real problem: --- actual bash script passing on a *heavily* massaged PERL5LIB set -o pipefail export PERL_CPANM_OPT= export PERL5LIB="/home/rabbit/devel/dbic/dbgit/lib:$PERL5LIB" export DBICTEST_SQLT_DEPLOY=0 export DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE=1 export DBIC_ASSERT_NO_FAILING_SANITY_CHECKS=1 # these fail with ERRONEOUS_METAINSTANCE_USE alone # (S::L fails due to PG_DSN but I think is ok besides that) for d in \ DBICx::Shortcuts \ DBIx::Class::Bootstrap::Simple \ DBIx::Class::Preview \ DBIx::Class::Schema::Loader \ Pinto \ ; do \ DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE=0 \ DBIC_ASSERT_NO_FAILING_SANITY_CHECKS=0 \ DBICTEST_PG_DSN= \ cpanm -v --reinstall $d 2>&1 \ | tee -a /dev/shm/umpfh \ | grep -P -B1 'sanity check|emit_|^(Building and testing|Result:)' || exit 1 \ ; done # these emit various san-check related problems for d in \ RapidApp \ Data::OFAC \ DBIx::Class::VirtualColumns \ "DBD::SQLite@1.35 Handel" \ DBIx::Class::RDBOHelpers \ CatalystX::CRUD::ModelAdapter::DBIC \ DBICx::Indexing \ DBICx::TestDatabase \ DBIx::Class::BitField \ DBIx::Class::I18NColumns \ DBIx::Class::PhoneticSearch \ DBIx::Class::RandomColumns \ DBIx::Class::ResultSource::MultipleTableInheritance \ DBIx::Class::Result::ProxyField \ DBIx::Class::Schema::PopulateMore \ DBIx::Class::Tree \ Foorum \ Interchange6::Schema \ Test::DBIx::Class \ TreePath \ ; do \ DBIC_ASSERT_NO_FAILING_SANITY_CHECKS=0 \ cpanm -v --reinstall $d 2>&1 \ | tee -a /dev/shm/umpfh \ | grep -P -B1 'sanity check|emit_|^(Building and testing|Result:)' || exit 1 \ ; done # these are entirely unaffected \o/ for d in \ Dancer2::Plugin::DBIC \ App::DBCritic \ App::DH \ AproJo \ Articulate \ Authorization::RBAC \ BackPAN::Index \ Bio::Chado::Schema \ Bot::BasicBot::Pluggable::Module::Notes \ Bracket \ Business::Cart::Generic \ Business::DPD \ Catalyst::Authentication::Credential::Facebook \ Catalyst::Authentication::Store::DBIx::Class \ Catalyst::Controller::DBIC::API \ Catalyst::Model::DBIC::Plain \ Catalyst::Model::DBIC::Schema \ Catalyst::Model::DBIC::Schema::PerRequest \ Catalyst::Model::FormFu \ Catalyst::Plugin::Authentication::Store::DBIC \ Catalyst::Plugin::Authorization::Abilities \ Catalyst::Plugin::AutoCRUD \ Catalyst::Plugin::DBIC::Schema::Profiler \ Catalyst::Plugin::Session::Store::DBIC \ Catalyst::TraitFor::Controller::DBIC::DoesPaging \ Catalyst::TraitFor::Model::DBIC::Schema::RequestConnectionPool \ Catalyst::TraitFor::Model::DBIC::Schema::Result \ Catalyst::TraitFor::Model::DBIC::Schema::WithCurrentUser \ Catalyst::View::CSV \ CatalystX::Controller::ExtJS::REST::SimpleExcel \ CatalystX::Crudite \ CatalystX::Eta \ CatalystX::OAuth2 \ CatalystX::Resource \ CGI::Application::Plugin::Authentication::Driver::DBIC \ CGI::Application::Plugin::DBIC::Schema \ CGI::Application::Plugin::DBIx::Class \ CGI::Application::Plugin::ExtJS \ CGI::Session::Driver::dbic \ Cookieville \ Dancer2::Plugin::Auth::Extensible::Provider::DBIC \ Dancer2::Session::DBIC \ Dancer::Plugin::Auth::Extensible::Provider::DBIC \ Dancer::Plugin::Auth::RBAC::Credentials::DBIC \ Dancer::Plugin::Auth::RBAC::Permissions::DBIC \ Dancer::Plugin::DBIC \ Dancer::Session::DBIC \ Data::Morph \ DBICx::AutoDoc \ DBICx::Backend::Move \ DBICx::DataDictionary \ DBICx::Deploy \ DBICx::Hooks \ DBICx::MapMaker \ DBICx::MaterializedPath \ DBICx::Modeler \ DBICx::Sugar \ DBICx::TxnInsert \ DBIx::Class::AlwaysUpdate \ DBIx::Class::AuditAny \ DBIx::Class::AuditLog \ DBIx::Class::BatchUpdate \ DBIx::Class::Candy \ DBIx::Class::ColumnDefault \ DBIx::Class::CompressColumns \ DBIx::Class::Cursor::Cached \ DBIx::Class::CustomPrefetch \ DBIx::Class::DateTime::Epoch \ DBIx::Class::DeleteAction \ DBIx::Class::DeploymentHandler \ DBIx::Class::DigestColumns \ DBIx::Class::DynamicDefault \ DBIx::Class::DynamicSubclass \ DBIx::Class::EasyFixture \ DBIx::Class::ElasticSync \ DBIx::Class::EncodeColumns \ DBIx::Class::EncodedColumn \ DBIx::Class::Factory \ DBIx::Class::Fixtures \ DBIx::Class::ForceUTF8 \ DBIx::Class::FormatColumns \ DBIx::Class::FormTools \ DBIx::Class::FromSledge \ DBIx::Class::FrozenColumns \ DBIx::Class::GeomColumns \ DBIx::Class::Graph \ DBIx::Class::Helpers \ DBIx::Class::HTML::FormFu \ DBIx::Class::HTMLWidget \ DBIx::Class::Indexed \ DBIx::Class::InflateColumn::Authen::Passphrase \ DBIx::Class::InflateColumn::BigFloat \ DBIx::Class::InflateColumn::Boolean \ DBIx::Class::InflateColumn::Currency \ DBIx::Class::InflateColumn::DateTime::Duration \ DBIx::Class::InflateColumn::DateTime::WithTimeZone \ DBIx::Class::InflateColumn::DateTimeX::Immutable \ DBIx::Class::InflateColumn::FS \ DBIx::Class::InflateColumn::IP \ DBIx::Class::InflateColumn::Markup::Unified \ DBIx::Class::InflateColumn::Math::Currency \ DBIx::Class::InflateColumn::Object::Enum \ DBIx::Class::InflateColumn::Path::Class \ DBIx::Class::InflateColumn::Serializer \ DBIx::Class::InflateColumn::Serializer::JSYNC \ DBIx::Class::InflateColumn::Serializer::Role::HashContentAccessor \ DBIx::Class::InflateColumn::Serializer::Sereal \ DBIx::Class::InflateColumn::Time \ DBIx::Class::InflateColumn::TimeMoment \ DBIx::Class::InflateColumn::URI \ DBIx::Class::IntrospectableM2M \ DBIx::Class::Journal \ DBIx::Class::LibXMLdoc \ DBIx::Class::LookupColumn \ DBIx::Class::MaterializedPath \ DBIx::Class::Migration \ DBIx::Class::Numeric \ DBIx::Class::Objects \ DBIx::Class::OptimisticLocking \ DBIx::Class::ParameterizedJoinHack \ DBIx::Class::PassphraseColumn \ DBIx::Class::QueriesTime \ DBIx::Class::QueryLog \ DBIx::Class::QueryLog::WithStackTrace \ DBIx::Class::QueryProfiler \ DBIx::Class::RandomStringColumns \ DBIx::Class::Relationship::Predicate \ DBIx::Class::Report \ DBIx::Class::Result::ColumnData \ DBIx::Class::ResultSet::AccessorsEverywhere \ DBIx::Class::ResultSet::Data::Pageset \ DBIx::Class::ResultSet::Excel \ DBIx::Class::ResultSet::Faceter \ DBIx::Class::ResultSet::HashRef \ DBIx::Class::ResultSet::RecursiveUpdate \ DBIx::Class::Result::Validation \ DBIx::Class::SaltedPasswords \ DBIx::Class::Schema::Config \ DBIx::Class::Schema::Diff \ DBIx::Class::Schema::RestrictWithObject \ DBIx::Class::Schema::ResultSetAccessors \ DBIx::Class::Schema::Versioned::Inline \ DBIx::Class::Service \ DBIx::Class::SingletonRows \ DBIx::Class::Storage::DBI::mysql::backup \ DBIx::Class::Storage::DBI::ODBC::OPENEDGE \ DBIx::Class::Storage::DBI::OpenEdge \ DBIx::Class::StorageReadOnly \ DBIx::Class::Storage::TxnEndHook \ DBIx::Class::TimeStamp \ DBIx::Class::Tokenize \ DBIx::Class::TopoSort \ DBIx::Class::Tree::CalculateSets \ DBIx::Class::Tree::Mobius \ DBIx::Class::UnicornLogger \ DBIx::Class::UserStamp \ DBIx::Class::UUIDColumns \ DBIx::Class::Validation \ DBIx::Class::Validation::Structure \ DBIx::Class::WebForm \ DBIx::Class::Wrapper \ DBIx::Table::TestDataGenerator \ Data::Importer \ Dwimmer \ ETLp \ ExtJS::Generator::DBIC \ Finance::QuoteDB \ Form::Processor::Model::DBIC \ Form::Sensible::Reflector::DBIC \ FormValidator::Simple::Plugin::DBIC::Unique \ Galileo \ GenOO \ HTML::FormFu::ExtJS \ HTML::FormFu::Model::DBIC \ HTML::FormHandler::Model::DBIC \ Hyle \ IronMan::Schema \ KiokuDB::Backend::DBI \ Log::Log4perl::Appender::DBIx::Class \ Mixin::ExtraFields::Driver::DBIC \ Module::CPANTS::ProcessCPAN \ Mojolicious::Plugin::DBICAdmin \ MooseX::Types::DBIx::Class \ OpusVL::AppKit \ OpusVL::AppKit::Schema::AppKitAuthDB \ OpusVL::Preferences \ OpusVL::SysParams \ Prosody \ Pulp \ RackMan \ Reaction \ Schema::RackTables \ Tapper::MCP \ Tapper::Schema \ Template::Provider::CustomDBIC \ Template::Provider::DBIC \ Template::Provider::PerContextDBIC \ Template::Provider::PrefixDBIC \ Test::DBIC::ExpectedQueries \ Test::DBIC::Schema::Connector \ Test::DBIx::Class::Schema \ Test::Fixture::DBIC::Schema \ Tie::DBIx::Class \ Types::DBIx::Class \ WebAPI::DBIC \ WebNano::Controller::CRUD \ Web::Util::DBIC::Paging \ Web::Util::ExtPaging \ WWW::Hashbang::Pastebin \ WWW::RobotRules::DBIC \ YAWF \ YATT::Lite \ Yeb::Plugin::DBIC \ "DBD::SQLite@1.35 Catalyst::ActionRole::BuildDBICResult DBIx::NoSQL Jedi::Plugin::Session Jedi::Plugin::Auth" \ "Test::More@1.001014 Test::DBIx::Class::Stats" \ "Mojolicious@3.91 ExpenseTracker" \ "Dancer2@0.166001 Strehler Strehler::Element::Extra Strehler::RSS" \ ; do \ cpanm -v --reinstall $d 2>&1 \ | tee -a /dev/shm/umpfh \ | grep -P -B1 '^(Building and testing|Result:)' || exit 1 \ ; done echo echo 'YAY!' exit 0 --- Changes | 4 + examples/Schema/MyApp/Schema.pm | 5 + lib/DBIx/Class/MethodAttributes.pm | 3 + lib/DBIx/Class/Schema.pm | 98 ++- lib/DBIx/Class/Schema/SanityChecker.pm | 590 ++++++++++++++++++ lib/DBIx/Class/Schema/Versioned.pm | 14 + lib/DBIx/Class/_Util.pm | 1 + t/cdbi/DeepAbstractSearch/01_search.t | 18 + t/cdbi/testlib/DBIC/Test/SQLite.pm | 17 + t/cdbi/testlib/MyBase.pm | 17 + t/lib/DBICTest/BaseSchema.pm | 47 ++ t/storage/txn.t | 3 + t/storage/txn_scope_guard.t | 3 + xt/dist/pod_coverage.t | 13 +- .../invalid_component_composition.t | 48 ++ xt/extra/internals/ithread_stress.t | 3 + xt/extra/lean_startup.t | 4 + 17 files changed, 883 insertions(+), 5 deletions(-) create mode 100644 lib/DBIx/Class/Schema/SanityChecker.pm create mode 100644 xt/extra/diagnostics/invalid_component_composition.t diff --git a/Changes b/Changes index 45b2f87f6..236b7349c 100644 --- a/Changes +++ b/Changes @@ -33,6 +33,10 @@ Revision history for DBIx::Class instead of silently discarding the argument * New Features + - DBIC now performs a range of sanity checks on the entire hierarchy + of Schema/Result/ResultSet classes loudly alerting the end user to + potential extremely hard-to-diagnose pitfalls ( RT#93976, also fully + addresses https://blog.afoolishmanifesto.com/posts/mros-and-you/ ) - InflateColumn::DateTime now accepts the ecosystem-standard option 'time_zone', in addition to the DBIC-only 'timezone' (GH#28) - Massively optimised literal SQL snippet scanner - fixes all known diff --git a/examples/Schema/MyApp/Schema.pm b/examples/Schema/MyApp/Schema.pm index 3642e82be..fdfa82bc1 100644 --- a/examples/Schema/MyApp/Schema.pm +++ b/examples/Schema/MyApp/Schema.pm @@ -6,4 +6,9 @@ use strict; use base qw/DBIx::Class::Schema/; __PACKAGE__->load_namespaces; +# no point taxing 5.8, but otherwise leave the default: a user may +# be interested in exploring and seeing what broke +__PACKAGE__->schema_sanity_checker('') + if DBIx::Class::_ENV_::OLD_MRO; + 1; diff --git a/lib/DBIx/Class/MethodAttributes.pm b/lib/DBIx/Class/MethodAttributes.pm index 0dec0b308..0365dadda 100644 --- a/lib/DBIx/Class/MethodAttributes.pm +++ b/lib/DBIx/Class/MethodAttributes.pm @@ -222,6 +222,9 @@ itself and various plugins are much more likely to invoke alternative direct call paths, bypassing your override entirely. Good examples of this are L and L. +See also the check +L. + =head1 METHODS =head2 MODIFY_CODE_ATTRIBUTES diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 618b58529..83d7e091c 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -7,8 +7,9 @@ use base 'DBIx::Class'; use DBIx::Class::Carp; use Try::Tiny; -use Scalar::Util qw/weaken blessed/; +use Scalar::Util qw( weaken blessed refaddr ); use DBIx::Class::_Util qw( + false emit_loud_diag refdesc refcount quote_sub scope_guard is_exception dbic_internal_try fail_on_internal_call emit_loud_diag @@ -27,6 +28,12 @@ __PACKAGE__->mk_classaccessor('default_resultset_attributes' => {}); __PACKAGE__->mk_classaccessor('class_mappings' => {}); __PACKAGE__->mk_classaccessor('source_registrations' => {}); +__PACKAGE__->mk_group_accessors( component_class => 'schema_sanity_checker' ); +__PACKAGE__->schema_sanity_checker( + DBIx::Class::_ENV_::OLD_MRO ? false : + 'DBIx::Class::Schema::SanityChecker' +); + =head1 NAME DBIx::Class::Schema - composable schemas @@ -454,6 +461,42 @@ Example: use base qw/DBIx::Class::Schema/; __PACKAGE__->default_resultset_attributes( { software_limit => 1 } ); +=head2 schema_sanity_checker + +=over 4 + +=item Arguments: L provider + +=item Return Value: L provider + +=item Default value: L + +=back + +On every call to L if the value of this attribute evaluates to +true, DBIC will invoke +C<< L<$schema_sanity_checker|/schema_sanity_checker>->L($schema) >> +before returning. The return value of this invocation is ignored. + +B to +L this +feature was introduced. Blindly disabling the checker on existing projects +B after upgrade to C<< DBIC >= v0.082900 >>. + +Example: + + package My::Schema; + use base qw/DBIx::Class::Schema/; + __PACKAGE__->schema_sanity_checker('My::Schema::SanityChecker'); + + # or to disable all checks: + __PACKAGE__->schema_sanity_checker(''); + +Note: setting the value to C B have the desired effect, +due to an implementation detail of L inherited +accessors. In order to disable any and all checks you must set this +attribute to an empty string as shown in the second example above. + =head2 exception_action =over 4 @@ -859,12 +902,17 @@ Similar to L except sets the storage object and connection data B on C<$self>. You should probably be calling L to get a properly L Schema object instead. +If the accessor L returns a true value C<$checker>, +the following call will take place before return: +C<< L<$checker|/schema_sanity_checker>->L)|DBIx::Class::Schema::SanityChecker/perform_schema_sanity_checks> >> + =head3 Overloading Overload C to change the behaviour of C. =cut +my $default_off_stderr_blurb_emitted; sub connection { my ($self, @info) = @_; return $self if !@info && $self->storage; @@ -888,7 +936,53 @@ sub connection { my $storage = $storage_class->new( $self => $args||{} ); $storage->connect_info(\@info); $self->storage($storage); - return $self; + + +### +### Begin 5.8 "you have not selected a checker" warning +### + # We can not blanket-enable this on 5.8 - it is just too expensive for + # day to day execution. We also can't just go silent - there are genuine + # regressions ( due to core changes) for which this is the only line of + # defense. So instead we whine on STDERR that folks need to do something + # + # Beyond suboptimal, but given the constraints the best we can do :( + # + # This should stay around for at least 3~4 years + # + DBIx::Class::_ENV_::OLD_MRO + and + ! $default_off_stderr_blurb_emitted + and + length ref $self->schema_sanity_checker + and + length ref __PACKAGE__->schema_sanity_checker + and + ( + refaddr( $self->schema_sanity_checker ) + == + refaddr( __PACKAGE__->schema_sanity_checker ) + ) + and + emit_loud_diag( + msg => sprintf( + "Sanity checks for schema %s are disabled on this perl $]: " + . '*THIS IS POTENTIALLY VERY DANGEROUS*. You are strongly urged to ' + . "read http://is.gd/dbic_sancheck_5_008 before proceeding\n", + ( defined( blessed $self ) ? refdesc $self : "'$self'" ) + )) + and + $default_off_stderr_blurb_emitted = 1; +### +### End 5.8 "you have not selected a checker" warning +### + + + if( my $checker = $self->schema_sanity_checker ) { + $checker->perform_schema_sanity_checks($self); + } + + $self; } sub _normalize_storage_type { diff --git a/lib/DBIx/Class/Schema/SanityChecker.pm b/lib/DBIx/Class/Schema/SanityChecker.pm new file mode 100644 index 000000000..c6b3e50dd --- /dev/null +++ b/lib/DBIx/Class/Schema/SanityChecker.pm @@ -0,0 +1,590 @@ +package DBIx::Class::Schema::SanityChecker; + +use strict; +use warnings; + +use DBIx::Class::_Util qw( + dbic_internal_try refdesc uniq serialize + describe_class_methods emit_loud_diag +); +use DBIx::Class (); +use DBIx::Class::Exception (); +use Scalar::Util qw( blessed refaddr ); +use namespace::clean; + +=head1 NAME + +DBIx::Class::Schema::SanityChecker - Extensible "critic" for your Schema class hierarchy + +=head1 SYNOPSIS + + package MyApp::Schema; + use base 'DBIx::Class::Schema'; + + # this is the default on Perl v5.10 and later + __PACKAGE__->schema_sanity_checker('DBIx::Class::Schema::SanityChecker'); + ... + +=head1 DESCRIPTION + +This is the default implementation of the Schema and related classes +L. + +The validator is B on perls C and above. See +L for discussion of the runtime effects. + +Use of this class begins by invoking L +(usually via L), which in turn starts +invoking validators I> in the order listed in +L. For each set of returned errors (if any) +I> is called and the resulting strings are +passed to L, where final headers are prepended and the entire +thing is printed on C. + +The class does not provide a constructor, due to the lack of state to be +passed around: object orientation was chosen purely for the ease of +overriding parts of the chain of events as described above. The general +pattern of communicating errors between the individual methods (both +before and after formatting) is an arrayref of hash references. + +=head2 WHY + +DBIC existed for more than a decade without any such setup validation +fanciness, let alone something that is enabled by default (which in turn +L). The reason for this relatively +drastic change is a set of revamps within the metadata handling framework, +in order to resolve once and for all problems like +L, +L, etc. While +DBIC internals are now way more robust than they were before, this comes at +a price: some non-issues in code that has been working for a while, will +now become hard to explain, or if you are unlucky: B. + +Thus, in order to protect existing codebases to the fullest extent possible, +the executive decision (and substantial effort) was made to introduce this +on-by-default setup validation framework. A massive amount of work has been +invested ensuring that none of the builtin checks emit a false-positive: +each and every complaint made by these checks B. + +=head2 Performance considerations + +First of all - after your connection has been established - there is B whenever the checks are enabled. + +By default the checks are triggered every time +L is called. Thus there is a +noticeable startup slowdown, most notably during testing (each test is +effectively a standalone program connecting anew). As an example the test +execution phase of the L C distribution +suffers a consistent slowdown of about C<16%>. This is considered a relatively +small price to pay for the benefits provided. + +Nevertheless, there are valid cases for disabling the checks during +day-to-day development, and having them run only during CI builds. In fact +the test suite of DBIC does exactly this as can be seen in +F: + + ~/dbic_repo$ git show 39636786 | perl -ne "print if 16..61" + +Whatever you do, B: it is not +worth the risk. + +=head3 Perl5.8 + +The situation with perl interpreters before C is sadly more +complicated: due to lack of built-in L, the +mechanism used to interrogate various classes is +L<< B slower|https://github.com/dbsrgits/dbix-class/commit/296248c3 >>. +As a result the very same version of L +L takes a C> hit on its +test execution time (these numbers are observed with the speedups of +L available, without them the slowdown reaches the whopping +C<350%>). + +Therefore, on these versions of perl the sanity checks are B by +default. Instead a C placeholder value is inserted into the +L, +urging the user to decide for themselves how to proceed. + +It is the author's B recommendation to find a way to run the +checks on your codebase continuously, even if it takes much longer. Refer to +the last paragraph of L above for an example how +to do this during CI builds only. + +=head2 Validations provided by this module + +=head3 no_indirect_method_overrides + +There are many methods within DBIC which are +L<"strictly sugar"|DBIx::Class::MethodAttributes/DBIC_method_is_indirect_sugar> +and should never be overridden by your application (e.g. see warnings at the +end of L and L). +Starting with C DBIC is much more aggressive in calling the +underlying non-sugar methods directly, which in turn means that almost all +user-side overrides of sugar methods are never going to be invoked. These +situations are now reliably detected and reported individually (you may +end up with a lot of output on C due to this). + +Note: B reported by this check B<*MUST*> be resolved +before upgrading DBIC in production. Malfunctioning business logic and/or +B may result otherwise. + +=head3 valid_c3_composition + +Looks through everything returned by L, and +for any class that B already utilize L a +L is calculated and then +compared to the shadowing map as if C was requested in the first place. +Any discrepancies are reported in order to clearly identify L especially when +encountered within complex inheritance hierarchies. + +=head3 no_inheritance_crosscontamination + +Checks that every individual L, +L, L, +L +and L class does not inherit from +an unexpected DBIC base class: e.g. an error will be raised if your +C inherits from both C and +C. + +=head1 METHODS + +=head2 perform_schema_sanity_checks + +=over + +=item Arguments: L<$schema|DBIx::Class::Schema> + +=item Return Value: unspecified (ignored by caller) + +=back + +The entry point expected by the +L. See +L for details. + +=cut + +sub perform_schema_sanity_checks { + my ($self, $schema) = @_; + + local $DBIx::Class::_Util::describe_class_query_cache->{'!internal!'} = {} + if + # does not make a measurable difference on 5.10+ + DBIx::Class::_ENV_::OLD_MRO + and + # the callstack shouldn't really be recursive, but for completeness... + ! $DBIx::Class::_Util::describe_class_query_cache->{'!internal!'} + ; + + my (@errors_found, $schema_desc); + for my $ch ( @{ $self->available_checks } ) { + + my $err = $self->${\"check_$ch"} ( $schema ); + + push @errors_found, map + { + { + check_name => $ch, + formatted_error => $_, + schema_desc => ( $schema_desc ||= + ( length ref $schema ) + ? refdesc $schema + : "'$schema'" + ), + } + } + @{ + $self->${\"format_${ch}_errors"} ( $err ) + || + [] + } + if @$err; + } + + $self->emit_errors(\@errors_found) + if @errors_found; +} + +=head2 available_checks + +=over + +=item Arguments: none + +=item Return Value: \@list_of_check_names + +=back + +The list of checks L will perform on the +provided L<$schema|DBIx::Class::Schema> object. For every entry returned +by this method, there must be a pair of I> and +I> methods available. + +Override this method to add checks to the +L. + +=cut + +sub available_checks { [qw( + valid_c3_composition + no_inheritance_crosscontamination + no_indirect_method_overrides +)] } + +=head2 emit_errors + +=over + +=item Arguments: \@list_of_formatted_errors + +=item Return Value: unspecified (ignored by caller) + +=back + +Takes an array reference of individual errors returned by various +I> formatters, and outputs them on C. + +This method is the most convenient integration point for a 3rd party logging +framework. + +Each individual error is expected to be a hash reference with all values being +plain strings as follows: + + { + schema_desc => $human_readable_description_of_the_passed_in_schema + check_name => $name_of_the_check_as_listed_in_available_checks() + formatted_error => $error_text_as_returned_by_format_$checkname_errors() + } + +If the environment variable C is set to +a true value this method will throw an exception with the same text. Those who +prefer to take no chances could set this variable permanently as part of their +deployment scripts. + +=cut + +# *NOT* using carp_unique and the warn framework - make +# it harder to accidentaly silence problems via $SIG{__WARN__} +sub emit_errors { + #my ($self, $errs) = @_; + + my @final_error_texts = map { + sprintf( "Schema %s failed the '%s' sanity check: %s\n", + @{$_}{qw( schema_desc check_name formatted_error )} + ); + } @{$_[1]}; + + emit_loud_diag( + msg => $_ + ) for @final_error_texts; + + # Do not use the constant - but instead check the env every time + # This will allow people to start auditing their apps piecemeal + DBIx::Class::Exception->throw( join "\n", @final_error_texts, ' ' ) + if $ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS}; +} + +=head2 all_schema_related_classes + +=over + +=item Arguments: L<$schema|DBIx::Class::Schema> + +=item Return Value: @sorted_list_of_unique_class_names + +=back + +This is a convenience method providing a list (not an arrayref) of +"interesting classes" related to the supplied schema. The returned list +currently contains the following class names: + +=over + +=item * The L class itself + +=item * The associated L class if any + +=item * The classes of all L if any + +=item * All L classes for all registered ResultSource instances + +=item * All L classes for all registered ResultSource instances + +=back + +=cut + +sub all_schema_related_classes { + my ($self, $schema) = @_; + + sort( uniq( map { + ( not defined $_ ) ? () + : ( defined blessed $_ ) ? ref $_ + : $_ + } ( + $schema, + $schema->storage, + ( map { + $_, + $_->result_class, + $_->resultset_class, + } map { $schema->source($_) } $schema->sources ), + ))); +} + + +sub format_no_indirect_method_overrides_errors { + # my ($self, $errors) = @_; + + [ map { sprintf( + "Method(s) %s override the convenience shortcut %s::%s(): " + . 'it is almost certain these overrides *MAY BE COMPLETELY IGNORED* at ' + . 'runtime. You MUST reimplement each override to hook a method from the ' + . "chain of calls within the convenience shortcut as seen when running:\n " + . '~$ perl -M%2$s -MDevel::Dwarn -e "Ddie { %3$s => %2$s->can(q(%3$s)) }"', + join (', ', map { "$_()" } sort @{ $_->{by} } ), + $_->{overriden}{via_class}, + $_->{overriden}{name}, + )} @{ $_[1] } ] +} + +sub check_no_indirect_method_overrides { + my ($self, $schema) = @_; + + my( @err, $seen_shadowing_configurations ); + + METHOD_STACK: + for my $method_stack ( map { + values %{ describe_class_methods($_)->{methods_with_supers} || {} } + } $self->all_schema_related_classes($schema) ) { + + my $nonsugar_methods; + + for (@$method_stack) { + + push @$nonsugar_methods, $_ and next + unless $_->{attributes}{DBIC_method_is_indirect_sugar}; + + push @err, { + overriden => { + name => $_->{name}, + via_class => $_->{via_class} + }, + by => [ map { "$_->{via_class}::$_->{name}" } @$nonsugar_methods ], + } if ( + $nonsugar_methods + and + ! $seen_shadowing_configurations->{ + join "\0", + map + { refaddr $_ } + ( + $_, + @$nonsugar_methods, + ) + }++ + ) + ; + + next METHOD_STACK; + } + } + + \@err +} + + +sub format_valid_c3_composition_errors { + # my ($self, $errors) = @_; + + [ map { sprintf( + "Class '%s' %s using the '%s' MRO affecting the lookup order of the " + . "following method(s): %s. You MUST add the following line to '%1\$s' " + . "right after strict/warnings:\n use mro 'c3';", + $_->{class}, + ( ($_->{initial_mro} eq $_->{current_mro}) ? 'is' : 'was originally' ), + $_->{initial_mro}, + join (', ', map { "$_()" } sort keys %{$_->{affected_methods}} ), + )} @{ $_[1] } ] +} + + +my $base_ISA = { + map { $_ => 1 } @{mro::get_linear_isa("DBIx::Class")} +}; + +sub check_valid_c3_composition { + my ($self, $schema) = @_; + + my @err; + + # + # A *very* involved check, to absolutely minimize false positives + # If this check returns an issue - it *better be* a real one + # + for my $class ( $self->all_schema_related_classes($schema) ) { + + my $desc = do { + no strict 'refs'; + describe_class_methods({ + class => $class, + ( ${"${class}::__INITIAL_MRO_UPON_DBIC_LOAD__"} + ? ( use_mro => ${"${class}::__INITIAL_MRO_UPON_DBIC_LOAD__"} ) + : () + ), + }) + }; + + # is there anything to check? + next unless ( + ! $desc->{mro}{is_c3} + and + $desc->{methods_with_supers} + and + my @potentially_problematic_method_stacks = + grep + { + # at least 2 variants came via inheritance (not ours) + ( + (grep { $_->{via_class} ne $class } @$_) + > + 1 + ) + and + # + # last ditch effort to skip examining an alternative mro + # IFF the entire "foreign" stack is located in the "base isa" + # + # This allows for extra efficiency (as there are several + # with_supers methods that would always be there), but more + # importantly saves one from tripping on the nonsensical yet + # begrudgingly functional (as in - no adverse effects): + # + # use base 'DBIx::Class'; + # use base 'DBIx::Class::Schema'; + # + ( + grep { + # not ours + $_->{via_class} ne $class + and + # not from the base stack either + ! $base_ISA->{$_->{via_class}} + } @$_ + ) + } + values %{ $desc->{methods_with_supers} } + ); + + my $affected_methods; + + for my $stack (@potentially_problematic_method_stacks) { + + # If we got so far - we need to see what the class would look + # like under c3 and compare, sigh + # + # Note that if the hierarchy is *really* fucked (like the above + # double-base e.g.) then recalc under 'c3' WILL FAIL, hence the + # extra eval: if we fail we report things as "jumbled up" + # + $affected_methods->{$stack->[0]{name}} = [ + map { $_->{via_class} } @$stack + ] unless dbic_internal_try { + + serialize($stack) + eq + serialize( + describe_class_methods({ class => $class, use_mro => 'c3' }) + ->{methods} + ->{$stack->[0]{name}} + ) + }; + } + + push @err, { + class => $class, + isa => $desc->{isa}, + initial_mro => $desc->{mro}{type}, + current_mro => mro::get_mro($class), + affected_methods => $affected_methods, + } if $affected_methods; + } + + \@err; +} + + +sub format_no_inheritance_crosscontamination_errors { + # my ($self, $errors) = @_; + + [ map { sprintf( + "Class '%s' registered in the role of '%s' unexpectedly inherits '%s': " + . 'you must resolve this by either removing an erroneous `use base` call ' + . "or switching to Moo(se)-style delegation (i.e. the 'handles' keyword)", + $_->{class}, + $_->{type}, + $_->{unexpectedly_inherits}, + )} @{ $_[1] } ] +} + +sub check_no_inheritance_crosscontamination { + my ($self, $schema) = @_; + + my @err; + + my $to_check = { + Schema => [ $schema ], + Storage => [ $schema->storage ], + ResultSource => [ map { $schema->source($_) } $schema->sources ], + }; + + $to_check->{ResultSet} = [ + map { $_->resultset_class } @{$to_check->{ResultSource}} + ]; + + $to_check->{Core} = [ + map { $_->result_class } @{$to_check->{ResultSource}} + ]; + + # Reduce everything to a unique sorted list of class names + $_ = [ sort( uniq( map { + ( not defined $_ ) ? () + : ( defined blessed $_ ) ? ref $_ + : $_ + } @$_ ) ) ] for values %$to_check; + + for my $group ( sort keys %$to_check ) { + for my $class ( @{ $to_check->{$group} } ) { + for my $foreign_base ( + map { "DBIx::Class::$_" } sort grep { $_ ne $group } keys %$to_check + ) { + + push @err, { + class => $class, + type => ( $group eq 'Core' ? 'ResultClass' : $group ), + unexpectedly_inherits => $foreign_base + } if $class->isa($foreign_base); + } + } + } + + \@err; +} + +1; + +__END__ + +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/lib/DBIx/Class/Schema/Versioned.pm b/lib/DBIx/Class/Schema/Versioned.pm index 8101f2e43..f84bd0595 100644 --- a/lib/DBIx/Class/Schema/Versioned.pm +++ b/lib/DBIx/Class/Schema/Versioned.pm @@ -49,6 +49,13 @@ use base 'DBIx::Class::Schema'; use strict; use warnings; +# no point sanity checking, unless we are running asserts +__PACKAGE__->schema_sanity_checker( + DBIx::Class::_ENV_::ASSERT_NO_FAILING_SANITY_CHECKS + ? 'DBIx::Class::Schema::SanityChecker' + : '' +); + __PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table'); package # Hide from PAUSE @@ -57,6 +64,13 @@ use base 'DBIx::Class::Schema'; use strict; use warnings; +# no point sanity checking, unless we are running asserts +__PACKAGE__->schema_sanity_checker( + DBIx::Class::_ENV_::ASSERT_NO_FAILING_SANITY_CHECKS + ? 'DBIx::Class::Schema::SanityChecker' + : '' +); + __PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat'); diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index e94d98d52..ac3a93715 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -50,6 +50,7 @@ BEGIN { DBIC_ASSERT_NO_INTERNAL_WANTARRAY DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + DBIC_ASSERT_NO_FAILING_SANITY_CHECKS DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE ) diff --git a/t/cdbi/DeepAbstractSearch/01_search.t b/t/cdbi/DeepAbstractSearch/01_search.t index 8b2101a06..5c87cb0bc 100644 --- a/t/cdbi/DeepAbstractSearch/01_search.t +++ b/t/cdbi/DeepAbstractSearch/01_search.t @@ -19,6 +19,24 @@ my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 0 }); package Music::DBI; use base qw(DBIx::Class::CDBICompat); use Class::DBI::Plugin::DeepAbstractSearch; + +BEGIN { + # offset the warning from DBIx::Class::Schema on 5.8 + # keep the ::Schema default as-is otherwise + DBIx::Class::_ENV_::OLD_MRO + and + ( eval <<'EOS' or die $@ ); + + sub setup_schema_instance { + my $s = shift->next::method(@_); + $s->schema_sanity_checker(''); + $s; + } + + 1; +EOS +} + __PACKAGE__->connection(@DSN); my $sql = <<'SQL_END'; diff --git a/t/cdbi/testlib/DBIC/Test/SQLite.pm b/t/cdbi/testlib/DBIC/Test/SQLite.pm index 72aa0c1c3..87a17f21b 100644 --- a/t/cdbi/testlib/DBIC/Test/SQLite.pm +++ b/t/cdbi/testlib/DBIC/Test/SQLite.pm @@ -43,6 +43,23 @@ use DBICTest; use base qw/DBIx::Class/; +BEGIN { + # offset the warning from DBIx::Class::Schema on 5.8 + # keep the ::Schema default as-is otherwise + DBIx::Class::_ENV_::OLD_MRO + and + ( eval <<'EOS' or die $@ ); + + sub setup_schema_instance { + my $s = shift->next::method(@_); + $s->schema_sanity_checker(''); + $s; + } + + 1; +EOS +} + __PACKAGE__->load_components(qw/CDBICompat Core DB/); my $DB = DBICTest->_sqlite_dbfilename; diff --git a/t/cdbi/testlib/MyBase.pm b/t/cdbi/testlib/MyBase.pm index 8cffd74d1..106b359db 100644 --- a/t/cdbi/testlib/MyBase.pm +++ b/t/cdbi/testlib/MyBase.pm @@ -7,6 +7,23 @@ use strict; use DBI; use DBICTest; +BEGIN { + # offset the warning from DBIx::Class::Schema on 5.8 + # keep the ::Schema default as-is otherwise + DBIx::Class::_ENV_::OLD_MRO + and + ( eval <<'EOS' or die $@ ); + + sub setup_schema_instance { + my $s = shift->next::method(@_); + $s->schema_sanity_checker(''); + $s; + } + + 1; +EOS +} + use base qw(DBIx::Class::CDBICompat); my @connect = (@ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}, { PrintError => 0}); diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index 6c293cc29..396367867 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -11,8 +11,55 @@ use DBIx::Class::_Util qw( emit_loud_diag scope_guard set_subname get_subname ); use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry); use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); use Scalar::Util qw( refaddr weaken ); +use Devel::GlobalDestruction (); use namespace::clean; +# Unless we are running assertions there is no value in checking ourselves +# during regular tests - the CI will do it for us +# +if ( + DBIx::Class::_ENV_::ASSERT_NO_FAILING_SANITY_CHECKS + and + # full-blown 5.8 sanity-checking is waaaaaay too slow, even for CI + ( + ! DBIx::Class::_ENV_::OLD_MRO + or + # still run a couple test with this, even on 5.8 + $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} + ) +) { + + __PACKAGE__->schema_sanity_checker('DBIx::Class::Schema::SanityChecker'); + + # Repeat the check on going out of scope (will catch weird runtime tinkering) + # Add only in case we will be using it, as it slows tests down + eval <<'EOD' or die $@; + + sub DESTROY { + if ( + ! Devel::GlobalDestruction::in_global_destruction() + and + my $checker = $_[0]->schema_sanity_checker + ) { + $checker->perform_schema_sanity_checks($_[0]); + } + + # *NOT* using next::method here - it (currently) will confuse Class::C3 + # in some obscure cases ( 5.8 naturally ) + shift->SUPER::DESTROY(); + } + + 1; + +EOD + +} +else { + # otherwise just unset the default + __PACKAGE__->schema_sanity_checker(''); +} + + if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { my $ea = __PACKAGE__->exception_action( sub { diff --git a/t/storage/txn.t b/t/storage/txn.t index 9af004043..0edca6c44 100644 --- a/t/storage/txn.t +++ b/t/storage/txn.t @@ -1,3 +1,6 @@ +# Test is sufficiently involved to *want* to run with "maximum paranoia" +BEGIN { $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} = 1 } + BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use strict; diff --git a/t/storage/txn_scope_guard.t b/t/storage/txn_scope_guard.t index 09efcd7f6..00d81a46d 100644 --- a/t/storage/txn_scope_guard.t +++ b/t/storage/txn_scope_guard.t @@ -1,3 +1,6 @@ +# Test is sufficiently involved to *want* to run with "maximum paranoia" +BEGIN { $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} = 1 } + BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use strict; diff --git a/xt/dist/pod_coverage.t b/xt/dist/pod_coverage.t index e2389af4c..859f0e324 100644 --- a/xt/dist/pod_coverage.t +++ b/xt/dist/pod_coverage.t @@ -8,6 +8,7 @@ use Test::More; use Module::Runtime 'require_module'; use lib 'maint/.Generated_Pod/lib'; use DBICTest; +use DBIx::Class::Schema::SanityChecker; use namespace::clean; # this has already been required but leave it here for CPANTS static analysis @@ -102,6 +103,11 @@ my $exceptions = { connection /] }, + 'DBIx::Class::Schema::SanityChecker' => { + ignore => [ map { + qr/^ (?: check_${_} | format_${_}_errors ) $/x + } @{ DBIx::Class::Schema::SanityChecker->available_checks } ] + }, 'DBIx::Class::Admin' => { ignore => [ qw/ @@ -181,9 +187,10 @@ foreach my $module (@modules) { # build parms up from ignore list my $parms = {}; - $parms->{trustme} = - [ map { qr/^$_$/ } @{ $ex->{ignore} } ] - if exists($ex->{ignore}); + $parms->{trustme} = [ map + { ref $_ eq 'Regexp' ? $_ : qr/^\Q$_\E$/ } + @{ $ex->{ignore} } + ] if exists($ex->{ignore}); # run the test with the potentially modified parm set Test::Pod::Coverage::pod_coverage_ok($module, $parms, "$module POD coverage"); diff --git a/xt/extra/diagnostics/invalid_component_composition.t b/xt/extra/diagnostics/invalid_component_composition.t new file mode 100644 index 000000000..ac162d533 --- /dev/null +++ b/xt/extra/diagnostics/invalid_component_composition.t @@ -0,0 +1,48 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +BEGIN { delete $ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS} } + +use strict; +use warnings; + +use Test::More; + +use DBICTest::Util 'capture_stderr'; +use DBICTest; + + +{ + package DBICTest::Some::BaseResult; + use base "DBIx::Class::Core"; + + # order is important + __PACKAGE__->load_components(qw( FilterColumn InflateColumn::DateTime )); +} + +{ + package DBICTest::Some::Result; + use base "DBICTest::Some::BaseResult"; + + __PACKAGE__->table("sometable"); + + __PACKAGE__->add_columns( + somecolumn => { data_type => "datetime" }, + ); +} + +{ + package DBICTest::Some::Schema; + use base "DBIx::Class::Schema"; + __PACKAGE__->schema_sanity_checker("DBIx::Class::Schema::SanityChecker"); + __PACKAGE__->register_class( some_result => "DBICTest::Some::Result" ); +} + +like( + capture_stderr { + DBICTest::Some::Schema->connection(sub {} ); + }, + qr/Class 'DBICTest::Some::Result' was originally using the 'dfs' MRO affecting .+ register_column\(\)/, + 'Proper incorrect composition warning emitted on StdErr' +); + +done_testing; diff --git a/xt/extra/internals/ithread_stress.t b/xt/extra/internals/ithread_stress.t index 0b1602f67..dc56d498f 100644 --- a/xt/extra/internals/ithread_stress.t +++ b/xt/extra/internals/ithread_stress.t @@ -1,5 +1,8 @@ BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } +# Test is sufficiently involved to *want* to run with "maximum paranoia" +BEGIN { $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} = 1 } + use warnings; use strict; diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index 435a5ba1a..2731f0c7c 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -105,6 +105,10 @@ BEGIN { DBICTEST_DEBUG_CONCURRENCY_LOCKS )}; + # ensures the checker won't be disabled in + # t/lib/DBICTest/BaseSchema.pm + $ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS} = 1; + $ENV{DBICTEST_ANFANG_DEFANG} = 1; # make sure extras do not load even when this is set From 09d8fb4a05e6cd025924cc08e41484f17a116695 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 4 Jun 2016 17:02:00 +0200 Subject: [PATCH 199/262] Expand annotations to cover all generated methods This is needed for the next commit, as we need a reliable way to tell gened methods apart from everything else. Given we will be taking the hit of adding the attributes, just go ahead and annotate *everything*, to be done with all auto-generated subs once and for all. This also solves @vanstyn's long-time gripe of not being able to tell where in a random schema one has declared m2m "relationships" (a typical customer is *very* unlikely to be using DBIC::IntrospectableM2M) As of this commit a typical Result can be introspected for m2m as follows: ~$ perl -Ilib -It/lib -MDBICTest -MPackage::Stash -e ' my $meths = Package::Stash->new("DBICTest::Schema::Artwork") ->get_all_symbols("CODE"); for my $m (sort keys %$meths ) { print "$m\n" if grep { $_ =~ /^DBIC_method_is_m2m_sugar/ } attributes::get($meths->{$m}); } ' While the more involved "complete method map" looks as follows: ~$ perl -Ilib -It/lib -MDBICTest -MPackage::Stash -e ' my $meths = Package::Stash->new("DBICTest::Schema::CD") ->get_all_symbols("CODE"); for my $m (sort keys %$meths ) { if ( my @attrs = attributes::get($meths->{$m}) ) { print "\n$m\n"; print " $_\n" for @attrs; } } ' --- lib/DBIx/Class/AccessorGroup.pm | 42 ++++++++ lib/DBIx/Class/CDBICompat/Relationships.pm | 7 +- lib/DBIx/Class/MethodAttributes.pm | 104 ++++++++++++++++++++ lib/DBIx/Class/Relationship/Accessor.pm | 48 ++++++++- lib/DBIx/Class/Relationship/ManyToMany.pm | 13 +++ lib/DBIx/Class/Relationship/ProxyMethods.pm | 9 +- 6 files changed, 220 insertions(+), 3 deletions(-) diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index 5ccc10983..d4493e218 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -23,6 +23,48 @@ sub mk_classaccessor :DBIC_method_is_indirect_sugar { ; } +sub mk_group_accessors { + my $class = shift; + my $type = shift; + + $class->next::method($type, @_); + + # label things + if( $type =~ /^ ( inflated_ | filtered_ )? column $/x ) { + + $class = ref $class + if length ref $class; + + for my $acc_pair ( + map + { [ $_, "_${_}_accessor" ] } + map + { ref $_ ? $_->[0] : $_ } + @_ + ) { + + for my $i (0, 1) { + + my $acc_name = $acc_pair->[$i]; + + attributes->import( + $class, + ( + $class->can($acc_name) + || + Carp::confess("Accessor '$acc_name' we just created on $class can't be found...?") + ), + 'DBIC_method_is_generated_from_resultsource_metadata', + ($i + ? "DBIC_method_is_${type}_extra_accessor" + : "DBIC_method_is_${type}_accessor" + ), + ) + } + } + } +} + sub get_component_class { my $class = $_[0]->get_inherited($_[1]); diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm index 90ce39be8..ecbc5c2d9 100644 --- a/lib/DBIx/Class/CDBICompat/Relationships.pm +++ b/lib/DBIx/Class/CDBICompat/Relationships.pm @@ -128,7 +128,12 @@ sub has_many { ); if (@f_method) { - quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel), { '$rf' => \sub { my $o = shift; $o = $o->$_ for @f_method; $o } }; + my @qsub_args = ( + { '$rf' => \sub { my $o = shift; $o = $o->$_ for @f_method; $o } }, + { attributes => [ 'DBIC_method_is_generated_from_resultsource_metadata' ] }, + ); + + quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel), @qsub_args; my $rs = shift->related_resultset(%s)->search_rs( @_); $rs->{attrs}{record_filter} = $rf; return (wantarray ? $rs->all : $rs); diff --git a/lib/DBIx/Class/MethodAttributes.pm b/lib/DBIx/Class/MethodAttributes.pm index 0365dadda..6c23988c0 100644 --- a/lib/DBIx/Class/MethodAttributes.pm +++ b/lib/DBIx/Class/MethodAttributes.pm @@ -158,6 +158,18 @@ sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /^ DBIC_method_is_ (?: indirect_sugar + | + generated_from_resultsource_metadata + | + (?: inflated_ | filtered_ )? column_ (?: extra_)? accessor + | + single_relationship_accessor + | + (?: multi | filter ) _relationship_ (?: extra_ )? accessor + | + proxy_to_relationship + | + m2m_ (?: extra_)? sugar (?:_with_attrs)? ) $/x; } @@ -225,6 +237,98 @@ L and L. See also the check L. +=head3 DBIC_method_is_generated_from_resultsource_metadata + +This attribute is applied to all methods dynamically installed after various +invocations of L. Notably +this includes L, +L, +L +and the various L, +B the L (given its +effects are never reflected as C). + +=head3 DBIC_method_is_column_accessor + +This attribute is applied to all methods dynamically installed as a result of +invoking L. + +=head3 DBIC_method_is_inflated_column_accessor + +This attribute is applied to all methods dynamically installed as a result of +invoking L. + +=head3 DBIC_method_is_filtered_column_accessor + +This attribute is applied to all methods dynamically installed as a result of +invoking L. + +=head3 DBIC_method_is_*column_extra_accessor + +For historical reasons any L accessor is generated +twice as C<{name}> and C<_{name}_accessor>. The second method is marked with +C correspondingly. + +=head3 DBIC_method_is_single_relationship_accessor + +This attribute is applied to all methods dynamically installed as a result of +invoking L, +L or +L (though for C +see L<...filter_rel...|/DBIC_method_is_filter_relationship_accessor> below. + +=head3 DBIC_method_is_multi_relationship_accessor + +This attribute is applied to the main method dynamically installed as a result +of invoking L. + +=head3 DBIC_method_is_multi_relationship_extra_accessor + +This attribute is applied to the two extra methods dynamically installed as a +result of invoking L: +C<$relname_rs> and C. + +=head3 DBIC_method_is_filter_relationship_accessor + +This attribute is applied to (legacy) methods dynamically installed as a +result of invoking L with an +already-existing identically named column. The method is internally +implemented as an L +and is labeled with both atributes at the same time. + +=head3 DBIC_method_is_filter_relationship_extra_accessor + +Same as L. + +=head3 DBIC_method_is_proxy_to_relationship + +This attribute is applied to methods dynamically installed as a result of +providing L. + +=head3 DBIC_method_is_m2m_sugar + +=head3 DBIC_method_is_m2m_sugar_with_attrs + +One of the above attributes is applied to the main method dynamically +installed as a result of invoking +L. The C<_with_atrs> suffix +serves to indicate whether the user supplied any C<\%attrs> to the +C call. There is deliberately no mechanism to retrieve the actual +supplied values: if you really need this functionality you would need to rely on +L. + +=head3 DBIC_method_is_extra_m2m_sugar + +=head3 DBIC_method_is_extra_m2m_sugar_with_attrs + +One of the above attributes is applied to the extra B methods dynamically +installed as a result of invoking +L: C<$m2m_rs>, C, +C and C. + =head1 METHODS =head2 MODIFY_CODE_ATTRIBUTES diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index a408b69f1..8fdeab2d0 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -25,8 +25,15 @@ sub add_relationship_accessor { if ($acc_type eq 'single') { - quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel); + my @qsub_args = ( {}, { + attributes => [qw( + DBIC_method_is_single_relationship_accessor + DBIC_method_is_generated_from_resultsource_metadata + )] + }); + + quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel), @qsub_args; my $self = shift; if (@_) { @@ -100,6 +107,38 @@ EOC return $pk_val; }, }); + + + # god this is horrible... + my $acc = + $rsrc->columns_info->{$rel}{accessor} + || + $rel + ; + + # because CDBI may elect to never make an accessor at all... + if( my $main_cref = $class->can($acc) ) { + + attributes->import( + $class, + $main_cref, + qw( + DBIC_method_is_filter_relationship_accessor + DBIC_method_is_generated_from_resultsource_metadata + ), + ); + + if( my $extra_cref = $class->can("_${acc}_accessor") ) { + attributes->import( + $class, + $extra_cref, + qw( + DBIC_method_is_filter_relationship_extra_accessor + DBIC_method_is_generated_from_resultsource_metadata + ), + ); + } + } } elsif ($acc_type eq 'multi') { @@ -108,6 +147,8 @@ EOC {}, { attributes => [qw( + DBIC_method_is_multi_relationship_accessor + DBIC_method_is_generated_from_resultsource_metadata DBIC_method_is_indirect_sugar )] }, @@ -121,6 +162,11 @@ EOC EOC + $qsub_args[1]{attributes}[0] + =~ s/^DBIC_method_is_multi_relationship_accessor$/DBIC_method_is_multi_relationship_extra_accessor/ + or die "Unexpected attr '$qsub_args[1]{attributes}[0]' ..."; + + quote_sub "${class}::${rel}_rs", sprintf( <<'EOC', perlstring $rel ), @qsub_args; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; shift->related_resultset(%s)->search_rs( @_ ) diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm index fdd46972c..e715f10e4 100644 --- a/lib/DBIx/Class/Relationship/ManyToMany.pm +++ b/lib/DBIx/Class/Relationship/ManyToMany.pm @@ -60,6 +60,10 @@ EOW {}, { attributes => [ 'DBIC_method_is_indirect_sugar', + ( keys( %{$rel_attrs||{}} ) + ? 'DBIC_method_is_m2m_sugar_with_attrs' + : 'DBIC_method_is_m2m_sugar' + ), ] }, ); @@ -82,6 +86,10 @@ EOC }, { attributes => [ 'DBIC_method_is_indirect_sugar', + ( keys( %{$rel_attrs||{}} ) + ? 'DBIC_method_is_m2m_extra_sugar_with_attrs' + : 'DBIC_method_is_m2m_extra_sugar' + ), ] }, ); @@ -206,6 +214,11 @@ EOC $guard->commit if $guard; EOC + + # the last method needs no captures - just kill it all with fire + $extra_meth_qsub_args[0] = {}; + + quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel ), @extra_meth_qsub_args; $_[0]->throw_exception("'%1$s' expects an object") diff --git a/lib/DBIx/Class/Relationship/ProxyMethods.pm b/lib/DBIx/Class/Relationship/ProxyMethods.pm index cb615140f..ee49fe8f8 100644 --- a/lib/DBIx/Class/Relationship/ProxyMethods.pm +++ b/lib/DBIx/Class/Relationship/ProxyMethods.pm @@ -24,7 +24,14 @@ sub proxy_to_related { my ($class, $rel, $proxy_args) = @_; my %proxy_map = $class->_build_proxy_map_from($proxy_args); - quote_sub "${class}::$_", sprintf( <<'EOC', $rel, $proxy_map{$_} ) + my @qsub_args = ( {}, { + attributes => [qw( + DBIC_method_is_proxy_to_relationship + DBIC_method_is_generated_from_resultsource_metadata + )], + } ); + + quote_sub "${class}::$_", sprintf( <<'EOC', $rel, $proxy_map{$_} ), @qsub_args my $self = shift; my $relobj = $self->%1$s; if (@_ && !defined $relobj) { From 28ef9468343a356954f0e4dc6bba1b834a8b3c3c Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 6 Jun 2016 13:58:31 +0200 Subject: [PATCH 200/262] Prevent invisible skipping of ResultSource proxy overrides *** NOTE *** This does not add any new default functionality, nor does it alter DBIC's behavior from how it solidified back in 2006: all this does is alert a user when things are 99% not DWIM-ing (10 years overdue but better late than...) *** NOTE *** During the original design of DBIC the "ResultSourceProxy" system was established in order to allow easy transition from Class::DBI. Sadly it was not well abstracted away: it is rather difficult to use a custom ResultSource subclass. The expansion of the DBIC project never addressed this properly in the years since. As a result when one wishes to override a part of the ResultSource functionality, the overwhelmingly common practice is to hook a method in a Result class and "hope for the best". The subtle changes of various internal call-chains (mainly 4006691d) make this silent uncertainty untenable. As a solution any such override will now issue a descriptive warning that it has been bypassed during a direct $rsrc->overriden_function invocation. A user now *must* determine how each individual override must behave in this situation, and tag it with one of the provided attributes. For completeness the blueprint off which this solution was devised is provided below: I = indirect (helper) method, never invoked by DBIC itself * Rsrc method types . = rsrc_instance_specific_attribute type accessor (getter+setter) s = setter calling a . internally g = getter calling a . internally c = custom accessor * Result method types P = proxied directly into ::Core via ::ResultSourceProxy (overridable) X = a ::Core proxy to ::ResultSource with extra logic (overridable) m = misc... stuff ___ Indirect methods ( the sanity checker warns when one "covers" these ) / | __ Rsrc methods somehow tied into the metadata state | / || _ Available to .../Result/... via ResultSourceProxy || / ||| ||| DBIx::Class::ResultSource::View: . is_virtual, . deploy_depends_on, . view_definition DBIx::Class::ResultSource: c schema . source_name # no proxy, but see FIXME at top of ::ResultSourceProxy . _columns . _ordered_columns . _primaries . _relationships . _unique_constraints .P column_info_from_storage . name .P result_class .P resultset_attributes .P resultset_class .P source_info . sqlt_deploy_callback IsX add_column sX add_columns sX add_relationship, IsP remove_column sP remove_columns sP add_unique_constraint IsP add_unique_constraints sP sequence sP set_primary_key IgP column_info gP columns_info gP columns gP has_column gP has_relationship gP primary_columns gP relationship_info gP relationships gP unique_constraint_columns gP unique_constraint_names gP unique_constraints DBIx::Class::ResultSourceProxy::Table: m table m _init_result_source_instance --- Changes | 3 + lib/DBIx/Class/CDBICompat/ColumnCase.pm | 2 +- lib/DBIx/Class/CDBICompat/ColumnGroups.pm | 4 +- lib/DBIx/Class/MethodAttributes.pm | 59 +++++ lib/DBIx/Class/ResultSource.pm | 10 + lib/DBIx/Class/ResultSourceProxy.pm | 289 +++++++++++++++++++++- lib/DBIx/Class/Schema/SanityChecker.pm | 7 +- t/resultsource/rsrc_proxy_invocation.t | 61 +++++ 8 files changed, 421 insertions(+), 14 deletions(-) create mode 100644 t/resultsource/rsrc_proxy_invocation.t diff --git a/Changes b/Changes index 236b7349c..1884dd021 100644 --- a/Changes +++ b/Changes @@ -20,6 +20,9 @@ Revision history for DBIx::Class invoked when an error is leaving the DBIC internals to be handled by the caller (n.b. https://github.com/PerlDancer/Dancer2/issues/1125) (also fixes the previously rejected RT#63874) + - Overrides of ResultSourceProxy-provided methods are no longer skipped + silently: a one-per-callsite warning is issued any time this tricky + situation is encoutered https://is.gd/dbic_rsrcproxy_methodattr - $result->related_resultset() no longer passes extra arguments to an underlying search_rs(), as by design these arguments would be used only on the first call to ->related_resultset(), and ignored diff --git a/lib/DBIx/Class/CDBICompat/ColumnCase.pm b/lib/DBIx/Class/CDBICompat/ColumnCase.pm index efbb88166..7f308e876 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnCase.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnCase.pm @@ -11,7 +11,7 @@ sub _register_column_group { return $class->next::method($group => map lc, @cols); } -sub add_columns { +sub add_columns :DBIC_method_is_bypassable_resultsource_proxy { my ($class, @cols) = @_; return $class->result_source->add_columns(map lc, @cols); } diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm index 73f845c95..f65a35806 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm @@ -12,7 +12,7 @@ use namespace::clean; __PACKAGE__->mk_classdata('_column_groups' => { }); -sub columns { +sub columns :DBIC_method_is_bypassable_resultsource_proxy { my $proto = shift; my $class = ref $proto || $proto; my $group = shift || "All"; @@ -34,7 +34,7 @@ sub _add_column_group { $class->_register_column_group($group => @cols); } -sub add_columns { +sub add_columns :DBIC_method_is_bypassable_resultsource_proxy { my ($class, @cols) = @_; $class->result_source->add_columns(@cols); } diff --git a/lib/DBIx/Class/MethodAttributes.pm b/lib/DBIx/Class/MethodAttributes.pm index 6c23988c0..8dfb0727c 100644 --- a/lib/DBIx/Class/MethodAttributes.pm +++ b/lib/DBIx/Class/MethodAttributes.pm @@ -159,6 +159,8 @@ sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /^ DBIC_method_is_ (?: indirect_sugar | + (?: bypassable | mandatory ) _resultsource_proxy + | generated_from_resultsource_metadata | (?: inflated_ | filtered_ )? column_ (?: extra_)? accessor @@ -237,6 +239,63 @@ L and L. See also the check L. +=head3 DBIC_method_is_mandatory_resultsource_proxy + +=head3 DBIC_method_is_bypassable_resultsource_proxy + +The presence of one of these attributes on a L indicates +how DBIC will behave when someone calls e.g.: + + $some_result->result_source->add_columns(...) + +as opposed to the conventional + + SomeResultClass->add_columns(...) + +This distinction becomes important when someone declares a sub named after +one of the (currently 22) methods proxied from a +L to +L. While there are obviously no +problems when these methods are called at compile time, there is a lot of +ambiguity whether an override of something like +L will be respected by +DBIC and various plugins during runtime operations. + +It must be noted that there is a reason for this weird situation: during the +original design of DBIC the "ResultSourceProxy" system was established in +order to allow easy transition from Class::DBI. Unfortunately it was not +well abstracted away: it is rather difficult to use a custom ResultSource +subclass. The expansion of the DBIC project never addressed this properly +in the years since. As a result when one wishes to override a part of the +ResultSource functionality, the overwhelming practice is to hook a method +in a Result class and "hope for the best". + +The subtle changes of various internal call-chains in C make +this silent uncertainty untenable. As a solution any such override will now +issue a descriptive warning that it has been bypassed during a +C<< $rsrc->overriden_function >> invocation. A user B determine how +each individual override must behave in this situation, and tag it with one +of the above two attributes. + +Naturally any override marked with C<..._bypassable_resultsource_proxy> will +behave like it did before: it will be silently ignored. This is the attribute +you want to set if your code appears to work fine, and you do not wish to +receive the warning anymore (though you are strongly encouraged to understand +the other option). + +However overrides marked with C<..._mandatory_resultsource_proxy> will always +be reinvoked by DBIC itself, so that any call of the form: + + $some_result->result_source->columns_info(...) + +will be transformed into: + + $some_result->result_source->result_class->columns_info(...) + +with the rest of the callchain flowing out of that (provided the override did +invoke L where appropriate) + =head3 DBIC_method_is_generated_from_resultsource_metadata This attribute is applied to all methods dynamically installed after various diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 85d0bfca6..9470546ac 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -1,5 +1,15 @@ package DBIx::Class::ResultSource; +### !!!NOTE!!! +# +# Some of the methods defined here will be around()-ed by code at the +# end of ::ResultSourceProxy. The reason for this strange arrangement +# is that the list of around()s of methods in this # class depends +# directly on the list of may-not-be-defined-yet methods within +# ::ResultSourceProxy itself. +# If this sounds terrible - it is. But got to work with what we have. +# + use strict; use warnings; diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm index cd18d2e3e..b8f008258 100644 --- a/lib/DBIx/Class/ResultSourceProxy.pm +++ b/lib/DBIx/Class/ResultSourceProxy.pm @@ -6,12 +6,25 @@ use warnings; use base 'DBIx::Class'; +# ! LOAD ORDER SENSITIVE ! # needs to be loaded early to query method attributes below +# and to do the around()s properly use DBIx::Class::ResultSource; +my @wrap_rsrc_methods = qw( + add_columns + add_relationship +); -use DBIx::Class::_Util qw( quote_sub fail_on_internal_call ); +use DBIx::Class::_Util qw( + quote_sub perlstring fail_on_internal_call describe_class_methods +); use namespace::clean; +# FIXME: this is truly bizarre, not sure why it is this way since 93405cf0 +# This value *IS* *DIFFERENT* from source_name in the underlying rsrc +# instance, and there is *ZERO EFFORT* made to synchronize them... +# FIXME: Due to the above marking this as a rsrc_proxy method is also out +# of the question... __PACKAGE__->mk_group_accessors('inherited_ro_instance' => 'source_name'); sub get_inherited_ro_instance { $_[0]->get_inherited($_[1]) } @@ -23,10 +36,11 @@ sub set_inherited_ro_instance { $_[0]->set_inherited( $_[1], $_[2] ); } - -sub add_columns { +sub add_columns :DBIC_method_is_bypassable_resultsource_proxy { my ($class, @cols) = @_; my $source = $class->result_source; + local $source->{__callstack_includes_rsrc_proxy_method} = "add_columns"; + $source->add_columns(@cols); my $colinfos; @@ -46,10 +60,11 @@ sub add_column :DBIC_method_is_indirect_sugar { shift->add_columns(@_) } - -sub add_relationship { +sub add_relationship :DBIC_method_is_bypassable_resultsource_proxy { my ($class, $rel, @rest) = @_; my $source = $class->result_source; + local $source->{__callstack_includes_rsrc_proxy_method} = "add_relationship"; + $source->add_relationship($rel => @rest); $class->register_relationship($rel => $source->relationship_info($rel)); } @@ -92,18 +107,272 @@ for my $method_to_proxy (qw/ relationship_info has_relationship /) { + my $qsub_opts = { attributes => [ + do { + no strict 'refs'; + attributes::get( \&{"DBIx::Class::ResultSource::$method_to_proxy"} ); + } + ] }; - my $qsub_opts = { attributes => [ do { - no strict 'refs'; - attributes::get( \&{"DBIx::Class::ResultSource::$method_to_proxy"} ) - } ] }; + # bypassable default for backcompat, except for indirect methods + # ( those will simply warn during the sanheck ) + if(! grep + { $_ eq 'DBIC_method_is_indirect_sugar' } + @{ $qsub_opts->{attributes} } + ) { + push @wrap_rsrc_methods, $method_to_proxy; + push @{ $qsub_opts->{atributes} }, 'DBIC_method_is_bypassable_resultsource_proxy'; + } quote_sub __PACKAGE__."::$method_to_proxy", sprintf( <<'EOC', $method_to_proxy ), {}, $qsub_opts; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; - shift->result_source->%s (@_); + my $rsrc = shift->result_source; + local $rsrc->{__callstack_includes_rsrc_proxy_method} = q(%1$s); + $rsrc->%1$s (@_); +EOC + +} + +# This is where the "magic" of detecting/invoking the proper overridden +# Result method takes place. It isn't implemented as a stateless out-of-band +# SanityCheck as invocation requires certain state in the $rsrc object itself +# in order not to loop over itself. It is not in ResultSource.pm either +# because of load order and because the entire stack is just terrible :/ +# +# The code is not easily readable, as it it optimized for execution time +# (this stuff will be run all the time across the entire install base :/ ) +# +{ + our %__rsrc_proxy_meta_cache; + + sub DBIx::Class::__RsrcProxy_iThreads_handler__::CLONE { + # recreating this cache is pretty cheap: just blow it away + %__rsrc_proxy_meta_cache = (); + } + + for my $method_to_wrap (@wrap_rsrc_methods) { + + my @src_args = ( + perlstring $method_to_wrap, + ); + + my $orig = do { + no strict 'refs'; + \&{"DBIx::Class::ResultSource::$method_to_wrap"} + }; + + my %unclassified_override_warn_emitted; + + my @qsub_args = ( + { + # ref to hashref, this is how S::Q works + '$rsrc_proxy_meta_cache' => \\%__rsrc_proxy_meta_cache, + '$unclassified_override_warn_emitted' => \\%unclassified_override_warn_emitted, + '$orig' => \$orig, + }, + { attributes => [ attributes::get($orig) ] } + ); + + quote_sub "DBIx::Class::ResultSource::$method_to_wrap", sprintf( <<'EOC', @src_args ), @qsub_args; + + my $overridden_proxy_cref; + + # fall through except when... + return &$orig unless ( + + # FIXME - this may be necessary some day, but skip the hit for now + # Scalar::Util::reftype $_[0] eq 'HASH' + # and + + # there is a class to check in the first place + defined $_[0]->{result_class} + + and + # we are not in a reinvoked callstack + ( + ( $_[0]->{__callstack_includes_rsrc_proxy_method} || '' ) + ne + %1$s + ) + + and + # there is a proxied method in the first place + ( + ( $rsrc_proxy_meta_cache->{address}{%1$s} ||= 0 + ( + DBIx::Class::ResultSourceProxy->can(%1$s) + || + -1 + ) ) + > + 0 + ) + + and + # the proxied method *is overridden* + ( + $rsrc_proxy_meta_cache->{address}{%1$s} + != + # the can() should not be able to fail in theory, but the + # result class may not inherit from ::Core *at all* + # hence we simply ||ourselves to paper over this eventuality + ( + ( $overridden_proxy_cref = $_[0]->{result_class}->can(%1$s) ) + || + $rsrc_proxy_meta_cache->{address}{%1$s} + ) + ) + + and + # no short-circuiting atributes + (! grep + { + # checking that: + # + # - Override is not something DBIC plastered on top of things + # One would think this is crazy, yet there it is... sigh: + # https://metacpan.org/source/KARMAN/DBIx-Class-RDBOHelpers-0.12/t/lib/MyDBIC/Schema/Cd.pm#L26-27 + # + # - And is not an m2m crapfest + # + # - And is not something marked as bypassable + + $_ =~ / ^ DBIC_method_is_ (?: + generated_from_resultsource_metadata + | + m2m_ (?: extra_)? sugar (?:_with_attrs)? + | + bypassable_resultsource_proxy + ) $ /x + } + keys %%{ $rsrc_proxy_meta_cache->{attrs}{$overridden_proxy_cref} ||= { + map { $_ => 1 } attributes::get($overridden_proxy_cref) + }} + ) + ); + + # Getting this far means that there *is* an override + # and it is *not* marked for a skip + + # we were asked to loop back through the Result override + if ( + $rsrc_proxy_meta_cache->{attrs} + {$overridden_proxy_cref} + {DBIC_method_is_mandatory_resultsource_proxy} + ) { + local $_[0]->{__callstack_includes_rsrc_proxy_method} = %1$s; + + # replace $self without compromising aliasing + splice @_, 0, 1, $_[0]->{result_class}; + + return &$overridden_proxy_cref; + } + # complain (sparsely) and carry on + else { + + # FIXME!!! - terrible, need to swap for something saner later + my ($cs) = DBIx::Class::Carp::__find_caller( __PACKAGE__ ); + + my $key = $cs . $overridden_proxy_cref; + + unless( $unclassified_override_warn_emitted->{$key} ) { + + # find the real origin + my @meth_stack = @{ DBIx::Class::_Util::describe_class_methods( + ref $_[0]->{result_class} || $_[0]->{result_class} + )->{methods}{%1$s} }; + + my $in_class = (shift @meth_stack)->{via_class}; + + my $possible_supers; + while ( + @meth_stack + and + $meth_stack[0]{via_class} ne __PACKAGE__ + ) { + push @$possible_supers, (shift @meth_stack)->{via_class}; + } + + $possible_supers = $possible_supers + ? sprintf( + ' ( and possible SUPERs: %%s )', + join ', ', map + { join '::', $_, %1$s } + @$possible_supers + ) + : '' + ; + + my $fqmeth = $in_class . '::' . %1$s . '()'; + + DBIx::Class::_Util::emit_loud_diag( + # Repurpose the assertion envvar ( the override-check is independent + # from the schema san-checker, but the spirit is the same ) + confess => $ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS}, + msg => + "The override method $fqmeth$possible_supers has been bypassed " + . "$cs\n" + . "In order to silence this warning you must tag the " + . "definition of $fqmeth with one of the attributes " + . "':DBIC_method_is_bypassable_resultsource_proxy' or " + . "':DBIC_method_is_mandatory_resultsource_proxy' ( see " + . "https://is.gd/dbic_rsrcproxy_methodattr for more info )\n" + ); + + # only set if we didn't throw + $unclassified_override_warn_emitted->{$key} = 1; + } + + return &$orig; + } EOC + } + + Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; +} + +# CI sanity check that all annotations make sense +if( + DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + and + # no point taxing 5.8 with this + ! DBIx::Class::_ENV_::OLD_MRO +) { + + my ( $rsrc_methods, $rsrc_proxy_methods, $base_methods ) = map { + describe_class_methods($_)->{methods} + } qw( + DBIx::Class::ResultSource + DBIx::Class::ResultSourceProxy + DBIx::Class + ); + + delete $rsrc_methods->{$_}, delete $rsrc_proxy_methods->{$_} + for keys %$base_methods; + + ( + $rsrc_methods->{$_} + and + ! $rsrc_proxy_methods->{$_}[0]{attributes}{DBIC_method_is_indirect_sugar} + ) + or + delete $rsrc_proxy_methods->{$_} + for keys %$rsrc_proxy_methods; + + # see fat FIXME at top of file + delete @{$rsrc_proxy_methods}{qw( source_name _source_name_accessor )}; + + if ( + ( my $proxied = join "\n", map "\t$_", sort keys %$rsrc_proxy_methods ) + ne + ( my $wrapped = join "\n", map "\t$_", sort @wrap_rsrc_methods ) + ) { + Carp::confess( + "Unexpected mismatch between the list of proxied methods:\n\n$proxied" + . "\n\nand the list of wrapped rsrc methods:\n\n$wrapped\n\n" + ); + } } 1; diff --git a/lib/DBIx/Class/Schema/SanityChecker.pm b/lib/DBIx/Class/Schema/SanityChecker.pm index c6b3e50dd..e4ca5b31f 100644 --- a/lib/DBIx/Class/Schema/SanityChecker.pm +++ b/lib/DBIx/Class/Schema/SanityChecker.pm @@ -371,7 +371,12 @@ sub check_no_indirect_method_overrides { push @err, { overriden => { name => $_->{name}, - via_class => $_->{via_class} + via_class => ( + # this way we report a much better Dwarn oneliner in the error + $_->{attributes}{DBIC_method_is_bypassable_resultsource_proxy} + ? 'DBIx::Class::ResultSource' + : $_->{via_class} + ), }, by => [ map { "$_->{via_class}::$_->{name}" } @$nonsugar_methods ], } if ( diff --git a/t/resultsource/rsrc_proxy_invocation.t b/t/resultsource/rsrc_proxy_invocation.t new file mode 100644 index 000000000..dc4c9d479 --- /dev/null +++ b/t/resultsource/rsrc_proxy_invocation.t @@ -0,0 +1,61 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +$ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS} = 1; + +use strict; +use warnings; + +use Test::More; + +use DBICTest; +use Sub::Quote 'quote_sub'; + +my $colinfo = DBICTest::Schema::Artist->result_source->column_info('artistid'); + +my $schema = DBICTest->init_schema ( no_deploy => 1 ); +my $rsrc = $schema->source("Artist"); + +for my $overrides_marked_mandatory (0, 1) { + my $call_count; + my @methods_to_override = qw( + add_columns columns_info + ); + + my $attr = { attributes => [ + $overrides_marked_mandatory + ? 'DBIC_method_is_mandatory_resultsource_proxy' + : 'DBIC_method_is_bypassable_resultsource_proxy' + ] }; + + for (@methods_to_override) { + $call_count->{$_} = 0; + + quote_sub( "DBICTest::Schema::Artist::$_", <<'EOC', { '$cnt' => \\($call_count->{$_}) }, $attr ); + $$cnt++; + shift->next::method(@_); +EOC + } + + Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; + + is_deeply + $rsrc->columns_info->{artistid}, + $colinfo, + 'Expected result from rsrc getter', + ; + + $rsrc->add_columns("bar"); + + is_deeply + $call_count, + { + add_columns => ($overrides_marked_mandatory ? 1 : 0), + + # ResultSourceProxy::add_columns will call colinfos as well + columns_info => ($overrides_marked_mandatory ? 2 : 0), + }, + 'expected rsrc proxy override callcounts', + ; +} + +done_testing; From 93f1cd05f42cb5b4081a2929804f3c8ab4d38f52 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 3 Apr 2016 15:43:28 +0200 Subject: [PATCH 201/262] Recognize more authorship based on the historic repo (if available) --- .mailmap | 5 +++++ AUTHORS | 4 +++- xt/dist/authors.t | 2 +- 3 files changed, 9 insertions(+), 2 deletions(-) diff --git a/.mailmap b/.mailmap index ffbbe5d9b..fe16b5b26 100644 --- a/.mailmap +++ b/.mailmap @@ -6,6 +6,7 @@ Alexander Hartmaier Alexander Kuznetsov +Alastair McGowan-Douglas Amiri Barksdale Andrew Rodland Arthur Axel "fREW" Schmidt @@ -14,6 +15,7 @@ Brendan Byrd Brendan Byrd Brendan Byrd Brian Phillips +C.J. Adams-Collier Christian Walde Jess Robinson Dagfinn Ilmari Mannsåker @@ -35,11 +37,14 @@ Jonathan Chu Jose Luis Martinez Kent Fredric Matt Phillips +Matt Phillips +Michael Reddick Norbert Csongrádi Peter Rabbitson Roman Filippov Ronald J Kimball Samuel Kaufman +Sebastian Willert Tim Bunce Toby Corkindale Tommy Butler diff --git a/AUTHORS b/AUTHORS index 3fbf27ae9..e0d52526b 100644 --- a/AUTHORS +++ b/AUTHORS @@ -21,7 +21,7 @@ Alexander Keusch alexrj: Alessandro Ranellucci alh: Matthew Horsfall alnewkirk: Al Newkirk -Altreus: Alastair McGowan-Douglas +Altreus: Alastair McGowan-Douglas amiri: Amiri Barksdale amoore: Andrew Moore Andrew Mehta @@ -32,6 +32,7 @@ ank: Andres Kievsky arc: Aaron Crane arcanez: Justin Hunter ash: Ash Berlin +batman: Jan Henning Thorsen bert: Norbert Csongrádi bfwg: Colin Newell blblack: Brandon L. Black @@ -218,6 +219,7 @@ uwe: Uwe Voelker Vadim Pushtaev vanstyn: Henry Van Styn victori: Victor Igumnov +vovkasm: Vladimir Timofeev wdh: Will Hawes wesm: Wes Malone willert: Sebastian Willert diff --git a/xt/dist/authors.t b/xt/dist/authors.t index ff7d5e27c..7f0537bc8 100644 --- a/xt/dist/authors.t +++ b/xt/dist/authors.t @@ -77,7 +77,7 @@ if ( for ( map { my ($gitname) = m/^ \s* \d+ \s* (.+?) \s* $/mx; utf8::decode($gitname); $gitname } - qx( git shortlog -e -s ) + qx( git shortlog HEAD --remotes=historic/ghpr/applied/ --remotes=historic/ghpr/closed/ -e -s ) ) { my ($eml) = $_ =~ $email_re; From c356fcb1919c92e9f9b1dfe9fcc4c4cd33dc5ad6 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 13 Jul 2016 17:06:30 +0200 Subject: [PATCH 202/262] Fix inexplicable 5.8.x C3 errors - roll back e6efde04 The optimization ends up breaking the entire C3 subsystem at a crucial time when add_columns has to see the correct register_column in order for IC::DT to populate the right column_info. Most importantly it seems that Class::C3::XS makes this optimization entirely moot (in fact minimal testing indicates things getting *faster* instead) --- Changes | 2 ++ lib/DBIx/Class/Schema.pm | 21 +++++---------------- t/lib/DBICTest/DeployComponent.pm | 5 +++++ t/lib/DBICTest/Schema/Track.pm | 2 ++ 4 files changed, 14 insertions(+), 16 deletions(-) diff --git a/Changes b/Changes index 1884dd021..72d7647b8 100644 --- a/Changes +++ b/Changes @@ -65,6 +65,8 @@ Revision history for DBIx::Class create()/populate() - Fix spurious warning on MSSQL cursor invalidation retries (RT#102166) - Fix several corner cases with Many2Many over custom relationships + - Fix corner cases of C3 composition being broken on OLD_MRO (5.8.x) + only: https://github.com/frioux/DBIx-Class-Helpers/issues/61 * Misc - Add explicit test for pathological example of asymmetric IC::DT setup diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 83d7e091c..17a8bbafc 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -244,10 +244,6 @@ sub load_namespaces { my @to_register; { - no warnings qw/redefine/; - local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; - use warnings qw/redefine/; - # ensure classes are loaded and attached in inheritance order for my $result_class (values %$results_by_source_name) { $class->ensure_class_loaded($result_class); @@ -301,8 +297,6 @@ sub load_namespaces { .'with no corresponding Result class'; } - Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; - $class->register_class(@$_) for (@to_register); return; @@ -384,10 +378,6 @@ sub load_classes { my @to_register; { - no warnings qw/redefine/; - local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; - use warnings qw/redefine/; - foreach my $prefix (keys %comps_for) { foreach my $comp (@{$comps_for{$prefix}||[]}) { my $comp_class = "${prefix}::${comp}"; @@ -404,7 +394,6 @@ sub load_classes { } } } - Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; foreach my $to (@to_register) { $class->register_class(@$to); @@ -1041,10 +1030,6 @@ sub compose_namespace { #$schema->class_mappings({}); { - no warnings qw/redefine/; - local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; - use warnings qw/redefine/; - foreach my $source_name ($self->sources) { my $orig_source = $self->source($source_name); @@ -1064,7 +1049,8 @@ sub compose_namespace { for qw(class source resultset); } - Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; + # needed to cover the newly installed stuff via quote_sub above + Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; # Give each composed class yet another *schema-less* source copy # this is used for the freeze/thaw cycle @@ -1752,6 +1738,9 @@ sub compose_connection { my $schema = $self->compose_namespace($target, 'DBIx::Class::ResultSetProxy'); quote_sub "${target}::schema", '$s', { '$s' => \$schema }; + # needed to cover the newly installed stuff via quote_sub above + Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; + $schema->connection(@info); foreach my $source_name ($schema->sources) { my $source = $schema->source($source_name); diff --git a/t/lib/DBICTest/DeployComponent.pm b/t/lib/DBICTest/DeployComponent.pm index 590fc25ab..99fbbd743 100644 --- a/t/lib/DBICTest/DeployComponent.pm +++ b/t/lib/DBICTest/DeployComponent.pm @@ -1,9 +1,14 @@ # belongs to t/86sqlt.t package # hide from PAUSE DBICTest::DeployComponent; + use warnings; use strict; +# Part of a test, important to remain as-is +# see also DBICTest::Schema::Track +use base 'DBIx::Class::Core'; + our $hook_cb; sub sqlt_deploy_hook { diff --git a/t/lib/DBICTest/Schema/Track.pm b/t/lib/DBICTest/Schema/Track.pm index 10d49f7b4..ef3b14de4 100644 --- a/t/lib/DBICTest/Schema/Track.pm +++ b/t/lib/DBICTest/Schema/Track.pm @@ -7,6 +7,8 @@ use strict; use base 'DBICTest::BaseResult'; use DBICTest::Util 'check_customcond_args'; +# The component order is Part of a test, +# important to remain as-is __PACKAGE__->load_components(qw{ +DBICTest::DeployComponent InflateColumn::DateTime From 58c8eea05831756529c053be936eeba5483831de Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 26 Jul 2016 19:41:27 +0200 Subject: [PATCH 203/262] Enable the schema SanChecks on 5.8 as well See how DarkPAN will react to this - it may be just fine. Backing it out in a standalone commit so it can be reinstated easily before stable --- lib/DBIx/Class/Schema.pm | 42 -------------------------- lib/DBIx/Class/Schema/SanityChecker.pm | 11 ++----- 2 files changed, 3 insertions(+), 50 deletions(-) diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 17a8bbafc..19434b4cf 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -30,7 +30,6 @@ __PACKAGE__->mk_classaccessor('source_registrations' => {}); __PACKAGE__->mk_group_accessors( component_class => 'schema_sanity_checker' ); __PACKAGE__->schema_sanity_checker( - DBIx::Class::_ENV_::OLD_MRO ? false : 'DBIx::Class::Schema::SanityChecker' ); @@ -926,47 +925,6 @@ sub connection { $storage->connect_info(\@info); $self->storage($storage); - -### -### Begin 5.8 "you have not selected a checker" warning -### - # We can not blanket-enable this on 5.8 - it is just too expensive for - # day to day execution. We also can't just go silent - there are genuine - # regressions ( due to core changes) for which this is the only line of - # defense. So instead we whine on STDERR that folks need to do something - # - # Beyond suboptimal, but given the constraints the best we can do :( - # - # This should stay around for at least 3~4 years - # - DBIx::Class::_ENV_::OLD_MRO - and - ! $default_off_stderr_blurb_emitted - and - length ref $self->schema_sanity_checker - and - length ref __PACKAGE__->schema_sanity_checker - and - ( - refaddr( $self->schema_sanity_checker ) - == - refaddr( __PACKAGE__->schema_sanity_checker ) - ) - and - emit_loud_diag( - msg => sprintf( - "Sanity checks for schema %s are disabled on this perl $]: " - . '*THIS IS POTENTIALLY VERY DANGEROUS*. You are strongly urged to ' - . "read http://is.gd/dbic_sancheck_5_008 before proceeding\n", - ( defined( blessed $self ) ? refdesc $self : "'$self'" ) - )) - and - $default_off_stderr_blurb_emitted = 1; -### -### End 5.8 "you have not selected a checker" warning -### - - if( my $checker = $self->schema_sanity_checker ) { $checker->perform_schema_sanity_checks($self); } diff --git a/lib/DBIx/Class/Schema/SanityChecker.pm b/lib/DBIx/Class/Schema/SanityChecker.pm index e4ca5b31f..481d0f775 100644 --- a/lib/DBIx/Class/Schema/SanityChecker.pm +++ b/lib/DBIx/Class/Schema/SanityChecker.pm @@ -21,7 +21,7 @@ DBIx::Class::Schema::SanityChecker - Extensible "critic" for your Schema class h package MyApp::Schema; use base 'DBIx::Class::Schema'; - # this is the default on Perl v5.10 and later + # this is the default setting __PACKAGE__->schema_sanity_checker('DBIx::Class::Schema::SanityChecker'); ... @@ -30,8 +30,8 @@ DBIx::Class::Schema::SanityChecker - Extensible "critic" for your Schema class h This is the default implementation of the Schema and related classes L. -The validator is B on perls C and above. See -L for discussion of the runtime effects. +The validator is B. See L +for discussion of the runtime effects. Use of this class begins by invoking L (usually via L), which in turn starts @@ -101,11 +101,6 @@ test execution time (these numbers are observed with the speedups of L available, without them the slowdown reaches the whopping C<350%>). -Therefore, on these versions of perl the sanity checks are B by -default. Instead a C placeholder value is inserted into the -L, -urging the user to decide for themselves how to proceed. - It is the author's B recommendation to find a way to run the checks on your codebase continuously, even if it takes much longer. Refer to the last paragraph of L above for an example how From a91e4e34fa2312794e62f3eda073edf744542df0 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 26 Jul 2016 09:00:50 +0200 Subject: [PATCH 204/262] (travis) cPerl 5.24.0 has shipped --- .travis.yml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index b37c43109..d18ef1b2b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -212,7 +212,7 @@ matrix: # MAKE SURE TO KEEP THE FLAGS IDENTICAL TO CPERL BELOW # allows for easier side-by-side comparison # vcpu=1 for even more stable results - - perl: "5.22.2_thr_qm" + - perl: "5.24.0_thr_qm" # explicit new infra spec preparing for a future forced upgrade # also need to pull in a sufficiently new compiler for quadmath.h sudo: required @@ -222,7 +222,7 @@ matrix: - CLEANTEST=true - POISON_ENV=true - MVDT=false - - BREWVER=5.22.2 + - BREWVER=5.24.0 - BREWOPTS="-Duseithreads -Dusequadmath" ### @@ -231,7 +231,7 @@ matrix: # MAKE SURE TO KEEP THE FLAGS IDENTICAL TO STOCK 5.latest.comparable ABOVE # allows for easier side-by-side comparison # vcpu=1 for even more stable results - - perl: "cperl-5.22.3_thr_qm" + - perl: "cperl-5.24.0_thr_qm" # explicit new infra spec preparing for a future forced upgrade # also need to pull in a sufficiently new compiler for quadmath.h sudo: required @@ -241,7 +241,7 @@ matrix: - CLEANTEST=true - POISON_ENV=true - MVDT=false - - BREWVER=cperl-5.22.3 + - BREWVER=cperl-5.24.0 - BREWOPTS="-Duseithreads -Dusequadmath" - perl: "cperl-master_thr" @@ -364,7 +364,7 @@ matrix: allow_failures: # these run with various dev snapshots - allowed to fail - - perl: cperl-5.22.3_thr_qm + - perl: cperl-5.24.0_thr_qm - perl: cperl-master_thr - perl: devcpan_5.8.1_thr_mb - perl: devcpan_5.8.1 From 2781bf350385459d9da6a511a9ef776d41e5f93d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= Date: Fri, 29 Jul 2016 15:43:11 +0100 Subject: [PATCH 205/262] Fix "overriden" typo --- lib/DBIx/Class/MethodAttributes.pm | 2 +- lib/DBIx/Class/ResultSource.pm | 2 +- lib/DBIx/Class/Schema/SanityChecker.pm | 6 +++--- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/DBIx/Class/MethodAttributes.pm b/lib/DBIx/Class/MethodAttributes.pm index 8dfb0727c..9bf5a2d7a 100644 --- a/lib/DBIx/Class/MethodAttributes.pm +++ b/lib/DBIx/Class/MethodAttributes.pm @@ -274,7 +274,7 @@ in a Result class and "hope for the best". The subtle changes of various internal call-chains in C make this silent uncertainty untenable. As a solution any such override will now issue a descriptive warning that it has been bypassed during a -C<< $rsrc->overriden_function >> invocation. A user B determine how +C<< $rsrc->overridden_function >> invocation. A user B determine how each individual override must behave in this situation, and tag it with one of the above two attributes. diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 9470546ac..4d33970c2 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -457,7 +457,7 @@ sub __emit_stale_metadata_diag { =head2 clone - $rsrc_instance->clone( atribute_name => overriden_value ); + $rsrc_instance->clone( atribute_name => overridden_value ); A wrapper around L inheriting any defaults from the callee. This method also not normally invoked directly by end users. diff --git a/lib/DBIx/Class/Schema/SanityChecker.pm b/lib/DBIx/Class/Schema/SanityChecker.pm index 481d0f775..b048edd9d 100644 --- a/lib/DBIx/Class/Schema/SanityChecker.pm +++ b/lib/DBIx/Class/Schema/SanityChecker.pm @@ -341,8 +341,8 @@ sub format_no_indirect_method_overrides_errors { . "chain of calls within the convenience shortcut as seen when running:\n " . '~$ perl -M%2$s -MDevel::Dwarn -e "Ddie { %3$s => %2$s->can(q(%3$s)) }"', join (', ', map { "$_()" } sort @{ $_->{by} } ), - $_->{overriden}{via_class}, - $_->{overriden}{name}, + $_->{overridden}{via_class}, + $_->{overridden}{name}, )} @{ $_[1] } ] } @@ -364,7 +364,7 @@ sub check_no_indirect_method_overrides { unless $_->{attributes}{DBIC_method_is_indirect_sugar}; push @err, { - overriden => { + overridden => { name => $_->{name}, via_class => ( # this way we report a much better Dwarn oneliner in the error From 91028369783da0db94a61e879860b8da97417fbb Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 1 Aug 2016 18:42:53 +0200 Subject: [PATCH 206/262] Some (very minor) fixups of emit_dups calls in e570488a --- lib/DBIx/Class/ResultSourceProxy.pm | 6 ++++-- lib/DBIx/Class/Schema.pm | 3 +-- t/lib/DBICTest/BaseSchema.pm | 3 ++- 3 files changed, 7 insertions(+), 5 deletions(-) diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm index b8f008258..7a6ab9d06 100644 --- a/lib/DBIx/Class/ResultSourceProxy.pm +++ b/lib/DBIx/Class/ResultSourceProxy.pm @@ -306,9 +306,11 @@ EOC my $fqmeth = $in_class . '::' . %1$s . '()'; DBIx::Class::_Util::emit_loud_diag( - # Repurpose the assertion envvar ( the override-check is independent - # from the schema san-checker, but the spirit is the same ) + + # Repurpose the assertion envvar ( the override-check is independent + # from the schema san-checker, but the spirit is the same ) confess => $ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS}, + msg => "The override method $fqmeth$possible_supers has been bypassed " . "$cs\n" diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 19434b4cf..5987f757b 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -9,8 +9,7 @@ use DBIx::Class::Carp; use Try::Tiny; use Scalar::Util qw( weaken blessed refaddr ); use DBIx::Class::_Util qw( - false emit_loud_diag refdesc - refcount quote_sub scope_guard + refdesc refcount quote_sub scope_guard is_exception dbic_internal_try fail_on_internal_call emit_loud_diag ); diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index 396367867..3ccd016e8 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -483,6 +483,7 @@ sub connection { emit_loud_diag( # not much else we can do (aside from exit(1) which is too obnoxious) msg => 'Incorrect call of result_source() in an eval', + emit_dups => 1, ); @@ -564,7 +565,7 @@ sub connection { # not much else we can do (aside from exit(1) which is too obnoxious) msg => 'Incorrect call of result_source_instance() in an eval', skip_frames => 1, - show_dups => 1, + emit_dups => 1, ); &$orig_rsrc_instance; From c61b8903ab2184af785474c545f1cf50281e4786 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 30 Jul 2016 14:54:01 +0200 Subject: [PATCH 207/262] Add missing contribs ( GH#6 / GH#28 ) Also mailmap fixups to go with 93f1cd05 --- .mailmap | 1 + AUTHORS | 4 +++- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/.mailmap b/.mailmap index fe16b5b26..3a450400c 100644 --- a/.mailmap +++ b/.mailmap @@ -19,6 +19,7 @@ C.J. Adams-Collier Christian Walde Jess Robinson Dagfinn Ilmari Mannsåker +Damien Krotkine David Kamholz David Schmidt David Schmidt diff --git a/AUTHORS b/AUTHORS index e0d52526b..36e39912f 100644 --- a/AUTHORS +++ b/AUTHORS @@ -88,7 +88,8 @@ gregoa: Gregor Herrmann groditi: Guillermo Roditi gshank: Gerda Shank guacamole: Fred Steinberg -Haarg: Graham Knop +haarg: Graham Knop +hisaichi: Hisada Kazuki hobbs: Andrew Rodland Ian Wells idn: Ian Norton @@ -183,6 +184,7 @@ Robert Olson robkinyon: Rob Kinyon Roman Ardern-Corris ruoso: Daniel Ruoso +rwtnorton: Richard W. Norton Sadrak: Felix Antonius Wilhelm Ostmann sc_: Just Another Perl Hacker schwern: Michael G Schwern From c33d5ebc4d84e4338f269565f6fe011801cb9fd4 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 1 Aug 2016 18:43:44 +0200 Subject: [PATCH 208/262] Bump version to accomodate pre-beta testers --- lib/DBIx/Class.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index fe27d47d2..bdcc96031 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -14,7 +14,7 @@ our $VERSION; # $VERSION declaration must stay up here, ahead of any other package # declarations, as to not confuse various modules attempting to determine # this ones version, whether that be s.c.o. or Module::Metadata, etc -$VERSION = '0.082899_15'; +$VERSION = '0.082899_25'; $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases From 65f6f753b02b99f68d772114974376d086d9992f Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 8 Aug 2016 20:45:11 +0200 Subject: [PATCH 209/262] (travis) Better diagnostics when perl compilation bails out --- maint/travis-ci_scripts/20_install.bash | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/maint/travis-ci_scripts/20_install.bash b/maint/travis-ci_scripts/20_install.bash index 3a4ff7b7b..ed7bc003e 100755 --- a/maint/travis-ci_scripts/20_install.bash +++ b/maint/travis-ci_scripts/20_install.bash @@ -50,7 +50,7 @@ if [[ -n "$BREWVER" ]] ; then # FIXME work around https://github.com/perl11/cperl/issues/144 # (still affecting 5.22.3) if is_cperl && ! [[ -f ~/perl5/perlbrew/perls/$BREWVER/bin/perl ]] ; then - ln -s ~/perl5/perlbrew/perls/$BREWVER/bin/cperl ~/perl5/perlbrew/perls/$BREWVER/bin/perl + ln -s ~/perl5/perlbrew/perls/$BREWVER/bin/cperl ~/perl5/perlbrew/perls/$BREWVER/bin/perl || /bin/true fi # can not do 'perlbrew use' in the run_or_err subshell above, or a $() @@ -58,7 +58,10 @@ if [[ -n "$BREWVER" ]] ; then # the perl is found (won't be there unless compilation suceeded, wich *ALSO* returns 0) perlbrew use $BREWVER || /bin/true - if [[ "$( perlbrew use | grep -oP '(?<=Currently using ).+' )" != "$BREWVER" ]] ; then + if \ + ! [[ -x ~/perl5/perlbrew/perls/$BREWVER/bin/perl ]] \ + || [[ "$( perlbrew use | grep -oP '(?<=Currently using ).+' )" != "$BREWVER" ]] + then echo_err "Unable to switch to $BREWVER - compilation failed...?" echo_err "$LASTOUT" exit 1 From 96a3f32a0f85c26078265a7462da791a524180b0 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 9 Aug 2016 08:29:04 +0200 Subject: [PATCH 210/262] (travis) Build cperl 5.25.x properly --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index d18ef1b2b..173bdb246 100644 --- a/.travis.yml +++ b/.travis.yml @@ -252,7 +252,7 @@ matrix: - POISON_ENV=true - MVDT=false - BREWVER=cperl-master - - BREWOPTS="-Duseithreads" + - BREWOPTS="-Duseithreads -Dusedevel" # threaded oldest possible with blead CPAN - perl: "devcpan_5.8.1_thr_mb" From b4532c43fcddd43dba8b0fc58022ed6f48f80351 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 8 Aug 2016 20:49:39 +0200 Subject: [PATCH 211/262] (travis) Work around RT#116788 --- maint/travis-ci_scripts/50_after_success.bash | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/maint/travis-ci_scripts/50_after_success.bash b/maint/travis-ci_scripts/50_after_success.bash index 8b44371cb..41b2fd1a0 100755 --- a/maint/travis-ci_scripts/50_after_success.bash +++ b/maint/travis-ci_scripts/50_after_success.bash @@ -27,6 +27,12 @@ if [[ "$DEVREL_DEPS" == "true" ]] && perl -M5.008003 -e1 &>/dev/null ; then parallel_installdeps_notest YAML Lexical::SealRequireHints fi + # FIXME - workaround for RT#116788 + # ( two instances, see below ) + if ! perl -M5.008007 -e1 &>/dev/null; then + parallel_installdeps_notest 'Encode~!=2.85' + fi + # FIXME Change when Moose goes away installdeps Moose $(perl -Ilib -MDBIx::Class::Optional::Dependencies=-list_missing,dist_dir) @@ -34,6 +40,13 @@ if [[ "$DEVREL_DEPS" == "true" ]] && perl -M5.008003 -e1 &>/dev/null ; then tarball_assembled=1 elif [[ "$CLEANTEST" != "true" ]] ; then + + # FIXME - workaround for RT#116788 + # ( two instances, see above ) + if ! perl -M5.008007 -e1 &>/dev/null; then + parallel_installdeps_notest 'Encode~!=2.85' + fi + parallel_installdeps_notest $(perl -Ilib -MDBIx::Class::Optional::Dependencies=-list_missing,dist_dir) run_or_err "Attempt to build a dist from original checkout" "make dist" From 63ee8b7896e02ee888eb26251fc28311721832c5 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 9 Aug 2016 18:45:06 +0200 Subject: [PATCH 212/262] (travis) Remove makefile fixup, now hardcoded in the subrepo --- maint/travis-ci_scripts/10_before_install.bash | 1 - 1 file changed, 1 deletion(-) diff --git a/maint/travis-ci_scripts/10_before_install.bash b/maint/travis-ci_scripts/10_before_install.bash index 157320ef4..7f911ad69 100755 --- a/maint/travis-ci_scripts/10_before_install.bash +++ b/maint/travis-ci_scripts/10_before_install.bash @@ -186,7 +186,6 @@ if [[ "$CLEANTEST" != "true" ]]; then cd "$(mktemp -d)" wget -qO- https://github.com/dbsrgits/Firebird-ODBC-driver/archive/2.0.2.153.tar.gz | tar -zx --strip-components 1 cd Builds/Gcc.lin - perl -p -i -e "s|/usr/lib64|/usr/lib/x86_64-linux-gnu|g" ../makefile.environ make -f makefile.linux sudo make -f makefile.linux install ' From 9ab03b7c122ecdf0779aaaa599423a6a92a8533a Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 10 Aug 2016 15:14:41 +0200 Subject: [PATCH 213/262] (travis) Fix unixodbc-dev overwrite on newer CI images --- maint/travis-ci_scripts/10_before_install.bash | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/maint/travis-ci_scripts/10_before_install.bash b/maint/travis-ci_scripts/10_before_install.bash index 7f911ad69..547fa8b05 100755 --- a/maint/travis-ci_scripts/10_before_install.bash +++ b/maint/travis-ci_scripts/10_before_install.bash @@ -124,9 +124,11 @@ if [[ "$CLEANTEST" != "true" ]]; then "sudo dpkg -i $( echo ${manual_debs[@]/#/$CACHE_DIR/*/*/} ) || sudo bash -c 'source maint/travis-ci_scripts/common.bash && apt_install -f'" - # needs to happen separately and *after* db2exc, as the former shits all over /usr/include (wtf?!) - # for more info look at /opt/ibm/db2/V9.7/instance/db2iutil :: create_links() - apt_install unixodbc-dev + # Needs to happen separately and *after* db2exc, as the former shits all over /usr/include (wtf?!) + # For more info look at /opt/ibm/db2/V9.7/instance/db2iutil :: create_links() + # The --reinstall is there in case it was already in place and got destroyed + # (this is the case on newer trusty images) + apt_install --reinstall unixodbc-dev ### config memcached From 81cf62797401df759ea308f8bacfcbccbc302104 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 10 Aug 2016 15:16:56 +0200 Subject: [PATCH 214/262] (travis) Temporarily allow-fail all trusty-based builds Until the fallout from https://www.traviscistatus.com/incidents/2p40l49r3yxd ( https://github.com/travis-ci/travis-ci/issues/6439 ) is fixed... --- .travis.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.travis.yml b/.travis.yml index 173bdb246..bfda0e531 100644 --- a/.travis.yml +++ b/.travis.yml @@ -363,6 +363,10 @@ matrix: # which ones of the above can fail allow_failures: + # FIXME work around https://github.com/travis-ci/travis-ci/issues/6439 + - perl: 5.18-extras + - perl: 5.24.0_thr_qm + # these run with various dev snapshots - allowed to fail - perl: cperl-5.24.0_thr_qm - perl: cperl-master_thr From 50841788d03e2342a00470eb2f458e717922615b Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 9 Aug 2016 10:53:30 +0200 Subject: [PATCH 215/262] Some cosmetic fixes in ANFANG --- t/lib/ANFANG.pm | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/t/lib/ANFANG.pm b/t/lib/ANFANG.pm index 4e49fe05e..c60ba9efe 100644 --- a/t/lib/ANFANG.pm +++ b/t/lib/ANFANG.pm @@ -91,8 +91,9 @@ $INC{$_} ||= __FILE__ for (qw( ANFANG.pm t/lib/ANFANG.pm ./t/lib/ANFANG.pm )); require Carp; - # not loading warnings.pm - local $^W = 0; + # in case we loaded warnings.pm / used -w + # ( do not do `no warnings ...` as it is also a load ) + local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /redefined/ }; *UNIVERSAL::VERSION = sub { Carp::carp( 'Argument "blah bleh bloh" isn\'t numeric in subroutine entry' ); @@ -114,8 +115,9 @@ $INC{$_} ||= __FILE__ for (qw( ANFANG.pm t/lib/ANFANG.pm ./t/lib/ANFANG.pm )); require Try::Tiny; my $orig = \&Try::Tiny::try; - # not loading warnings.pm - local $^W = 0; + # in case we loaded warnings.pm / used -w + # ( do not do `no warnings ...` as it is also a load ) + local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /redefined/ }; *Try::Tiny::try = sub (&;@) { my ($fr, $first_pkg) = 0; @@ -140,15 +142,22 @@ $INC{$_} ||= __FILE__ for (qw( ANFANG.pm t/lib/ANFANG.pm ./t/lib/ANFANG.pm )); } -require lib; -lib->import('t/lib'); +unshift @INC, 't/lib'; # everything expects this to be there -! -d 't/var' and ( +! -d 't/var' + and +( mkdir 't/var' or - die "Unable to create 't/var': $!\n" + # creation is inherently racy + do { + my $err = $!; + require Errno; + die "Unable to create 't/var': $err\n" + unless $err == Errno::EEXIST(); + } ); From 497d0451bd98892c7bc2228c5ca82ca8592a5558 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 10 Aug 2016 17:16:32 +0200 Subject: [PATCH 216/262] Extract two stateless DBIHacks routines into a utility package Further commits will need them in places where $storage isn't yet available. There are zero functional changes Best read under -C -C -M --color-words --- lib/DBIx/Class/ResultSet.pm | 5 +- lib/DBIx/Class/ResultSource.pm | 13 +- lib/DBIx/Class/SQLMaker/OracleJoins.pm | 4 +- lib/DBIx/Class/SQLMaker/Util.pm | 447 +++++++++++++++++ lib/DBIx/Class/Storage/DBIHacks.pm | 452 +----------------- xt/extra/internals/namespaces_cleaned.t | 1 + .../extra/internals/sqla_condition_parsers.t | 273 ++++++----- 7 files changed, 616 insertions(+), 579 deletions(-) create mode 100644 lib/DBIx/Class/SQLMaker/Util.pm rename t/sqlmaker/dbihacks_internals.t => xt/extra/internals/sqla_condition_parsers.t (64%) diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 3d06065d2..97cfe5073 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -13,6 +13,7 @@ use DBIx::Class::_Util qw( dbic_internal_try dump_value fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION ); +use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); use Try::Tiny; BEGIN { @@ -662,7 +663,7 @@ sub _stack_cond { return undef } else { - return $self->result_source->schema->storage->_collapse_cond({ -and => [$left, $right] }); + return normalize_sqla_condition({ -and => [$left, $right] }); } } @@ -2618,7 +2619,7 @@ sub _merge_with_rscond { @cols_from_relations = keys %{ $implied_data || {} }; } else { - my $eqs = $self->result_source->schema->storage->_extract_fixed_condition_columns($self->{cond}, 'consider_nulls'); + my $eqs = extract_equality_conditions( $self->{cond}, 'consider_nulls' ); $implied_data = { map { ( ($eqs->{$_}||'') eq UNRESOLVABLE_CONDITION ) ? () : ( $_ => $eqs->{$_} ) } keys %$eqs }; diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 4d33970c2..c598b1db2 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -21,6 +21,7 @@ use DBIx::Class::_Util qw( dbic_internal_try fail_on_internal_call refdesc emit_loud_diag ); +use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); use SQL::Abstract 'is_literal_value'; use Devel::GlobalDestruction; use Scalar::Util qw( blessed weaken isweak refaddr ); @@ -1928,7 +1929,7 @@ sub _minimal_valueset_satisfying_constraint { $args->{columns_info} ||= $self->columns_info; - my $vals = $self->schema->storage->_extract_fixed_condition_columns( + my $vals = extract_equality_conditions( $args->{values}, ($args->{carp_on_nulls} ? 'consider_nulls' : undef ), ); @@ -1942,7 +1943,7 @@ sub _minimal_valueset_satisfying_constraint { $cols->{$args->{carp_on_nulls} ? 'undefined' : 'missing'}{$col} = undef; } else { - # we need to inject back the '=' as _extract_fixed_condition_columns + # we need to inject back the '=' as extract_equality_conditions() # will strip it from literals and values alike, resulting in an invalid # condition in the end $cols->{present}{$col} = { '=' => $vals->{$col} }; @@ -2304,7 +2305,7 @@ sub _resolve_relationship_condition { qw( columns relationships ) ; - my $equivalencies = $storage->_extract_fixed_condition_columns( + my $equivalencies = extract_equality_conditions( $args->{foreign_values}, 'consider nulls', ); @@ -2520,10 +2521,10 @@ sub _resolve_relationship_condition { and $ret->{join_free_condition} ne UNRESOLVABLE_CONDITION and - my $jfc = $storage->_collapse_cond( $ret->{join_free_condition} ) + my $jfc = normalize_sqla_condition( $ret->{join_free_condition} ) ) { - my $jfc_eqs = $storage->_extract_fixed_condition_columns($jfc, 'consider_nulls'); + my $jfc_eqs = extract_equality_conditions( $jfc, 'consider_nulls' ); if (keys %$jfc_eqs) { @@ -2563,7 +2564,7 @@ sub _resolve_relationship_condition { # (may already be there, since easy to calculate on the fly in the HASH case) if ( ! $ret->{identity_map} ) { - my $col_eqs = $storage->_extract_fixed_condition_columns($ret->{condition}); + my $col_eqs = extract_equality_conditions($ret->{condition}); my $colinfos; for my $lhs (keys %$col_eqs) { diff --git a/lib/DBIx/Class/SQLMaker/OracleJoins.pm b/lib/DBIx/Class/SQLMaker/OracleJoins.pm index 0f50467ed..00e58fb05 100644 --- a/lib/DBIx/Class/SQLMaker/OracleJoins.pm +++ b/lib/DBIx/Class/SQLMaker/OracleJoins.pm @@ -81,8 +81,8 @@ sub _recurse_oracle_joins { } # FIXME - the code below *UTTERLY* doesn't work with custom conds... sigh - # for the time being do not do any processing with the likes of _collapse_cond - # instead only unroll the -and hack if present + # for the time being do not do any processing with the likes of + # normalize_sqla_condition(), instead only unroll the -and hack if present $on = $on->{-and}[0] if ( ref $on eq 'HASH' and diff --git a/lib/DBIx/Class/SQLMaker/Util.pm b/lib/DBIx/Class/SQLMaker/Util.pm new file mode 100644 index 000000000..ec83edde0 --- /dev/null +++ b/lib/DBIx/Class/SQLMaker/Util.pm @@ -0,0 +1,447 @@ +package #hide from PAUSE + DBIx::Class::SQLMaker::Util; + +use strict; +use warnings; + +use base 'Exporter'; +our @EXPORT_OK = qw( + normalize_sqla_condition + extract_equality_conditions +); + +use DBIx::Class::Carp; +use Carp 'croak'; +use SQL::Abstract qw( is_literal_value is_plain_value ); +use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION serialize dump_value ); + + +# Attempts to flatten a passed in SQLA condition as much as possible towards +# a plain hashref, *without* altering its semantics. +# +# FIXME - while relatively robust, this is still imperfect, one of the first +# things to tackle when we get access to a formalized AST. Note that this code +# is covered by a *ridiculous* amount of tests, so starting with porting this +# code would be a rather good exercise +sub normalize_sqla_condition { + my ($where, $where_is_anded_array) = @_; + + my $fin; + + if (! $where) { + return; + } + elsif ($where_is_anded_array or ref $where eq 'HASH') { + + my @pairs; + + my @pieces = $where_is_anded_array ? @$where : $where; + while (@pieces) { + my $chunk = shift @pieces; + + if (ref $chunk eq 'HASH') { + for (sort keys %$chunk) { + + # Match SQLA 1.79 behavior + unless( length $_ ) { + is_literal_value($chunk->{$_}) + ? carp 'Hash-pairs consisting of an empty string with a literal are deprecated, use -and => [ $literal ] instead' + : croak 'Supplying an empty left hand side argument is not supported in hash-pairs' + ; + } + + push @pairs, $_ => $chunk->{$_}; + } + } + elsif (ref $chunk eq 'ARRAY') { + push @pairs, -or => $chunk + if @$chunk; + } + elsif ( ! length ref $chunk) { + + # Match SQLA 1.79 behavior + croak("Supplying an empty left hand side argument is not supported in array-pairs") + if $where_is_anded_array and (! defined $chunk or ! length $chunk); + + push @pairs, $chunk, shift @pieces; + } + else { + push @pairs, '', $chunk; + } + } + + return unless @pairs; + + my @conds = _normalize_cond_unroll_pairs(\@pairs) + or return; + + # Consolidate various @conds back into something more compact + for my $c (@conds) { + if (ref $c ne 'HASH') { + push @{$fin->{-and}}, $c; + } + else { + for my $col (sort keys %$c) { + + # consolidate all -and nodes + if ($col =~ /^\-and$/i) { + push @{$fin->{-and}}, + ref $c->{$col} eq 'ARRAY' ? @{$c->{$col}} + : ref $c->{$col} eq 'HASH' ? %{$c->{$col}} + : { $col => $c->{$col} } + ; + } + elsif ($col =~ /^\-/) { + push @{$fin->{-and}}, { $col => $c->{$col} }; + } + elsif (exists $fin->{$col}) { + $fin->{$col} = [ -and => map { + (ref $_ eq 'ARRAY' and ($_->[0]||'') =~ /^\-and$/i ) + ? @{$_}[1..$#$_] + : $_ + ; + } ($fin->{$col}, $c->{$col}) ]; + } + else { + $fin->{$col} = $c->{$col}; + } + } + } + } + } + elsif (ref $where eq 'ARRAY') { + # we are always at top-level here, it is safe to dump empty *standalone* pieces + my $fin_idx; + + for (my $i = 0; $i <= $#$where; $i++ ) { + + # Match SQLA 1.79 behavior + croak( + "Supplying an empty left hand side argument is not supported in array-pairs" + ) if (! defined $where->[$i] or ! length $where->[$i]); + + my $logic_mod = lc ( ($where->[$i] =~ /^(\-(?:and|or))$/i)[0] || '' ); + + if ($logic_mod) { + $i++; + croak("Unsupported top-level op/arg pair: [ $logic_mod => $where->[$i] ]") + unless ref $where->[$i] eq 'HASH' or ref $where->[$i] eq 'ARRAY'; + + my $sub_elt = normalize_sqla_condition({ $logic_mod => $where->[$i] }) + or next; + + my @keys = keys %$sub_elt; + if ( @keys == 1 and $keys[0] !~ /^\-/ ) { + $fin_idx->{ "COL_$keys[0]_" . serialize $sub_elt } = $sub_elt; + } + else { + $fin_idx->{ "SER_" . serialize $sub_elt } = $sub_elt; + } + } + elsif (! length ref $where->[$i] ) { + my $sub_elt = normalize_sqla_condition({ @{$where}[$i, $i+1] }) + or next; + + $fin_idx->{ "COL_$where->[$i]_" . serialize $sub_elt } = $sub_elt; + $i++; + } + else { + $fin_idx->{ "SER_" . serialize $where->[$i] } = normalize_sqla_condition( $where->[$i] ) || next; + } + } + + if (! $fin_idx) { + return; + } + elsif ( keys %$fin_idx == 1 ) { + $fin = (values %$fin_idx)[0]; + } + else { + my @or; + + # at this point everything is at most one level deep - unroll if needed + for (sort keys %$fin_idx) { + if ( ref $fin_idx->{$_} eq 'HASH' and keys %{$fin_idx->{$_}} == 1 ) { + my ($l, $r) = %{$fin_idx->{$_}}; + + if ( + ref $r eq 'ARRAY' + and + ( + ( @$r == 1 and $l =~ /^\-and$/i ) + or + $l =~ /^\-or$/i + ) + ) { + push @or, @$r + } + + elsif ( + ref $r eq 'HASH' + and + keys %$r == 1 + and + $l =~ /^\-(?:and|or)$/i + ) { + push @or, %$r; + } + + else { + push @or, $l, $r; + } + } + else { + push @or, $fin_idx->{$_}; + } + } + + $fin->{-or} = \@or; + } + } + else { + # not a hash not an array + $fin = { -and => [ $where ] }; + } + + # unroll single-element -and's + while ( + $fin->{-and} + and + @{$fin->{-and}} < 2 + ) { + my $and = delete $fin->{-and}; + last if @$and == 0; + + # at this point we have @$and == 1 + if ( + ref $and->[0] eq 'HASH' + and + ! grep { exists $fin->{$_} } keys %{$and->[0]} + ) { + $fin = { + %$fin, %{$and->[0]} + }; + } + else { + $fin->{-and} = $and; + last; + } + } + + # compress same-column conds found in $fin + for my $col ( grep { $_ !~ /^\-/ } keys %$fin ) { + next unless ref $fin->{$col} eq 'ARRAY' and ($fin->{$col}[0]||'') =~ /^\-and$/i; + my $val_bag = { map { + (! defined $_ ) ? ( UNDEF => undef ) + : ( ! length ref $_ or is_plain_value $_ ) ? ( "VAL_$_" => $_ ) + : ( ( 'SER_' . serialize $_ ) => $_ ) + } @{$fin->{$col}}[1 .. $#{$fin->{$col}}] }; + + if (keys %$val_bag == 1 ) { + ($fin->{$col}) = values %$val_bag; + } + else { + $fin->{$col} = [ -and => map { $val_bag->{$_} } sort keys %$val_bag ]; + } + } + + return keys %$fin ? $fin : (); +} + +sub _normalize_cond_unroll_pairs { + my $pairs = shift; + + my @conds; + + while (@$pairs) { + my ($lhs, $rhs) = splice @$pairs, 0, 2; + + if (! length $lhs) { + push @conds, normalize_sqla_condition($rhs); + } + elsif ( $lhs =~ /^\-and$/i ) { + push @conds, normalize_sqla_condition($rhs, (ref $rhs eq 'ARRAY')); + } + elsif ( $lhs =~ /^\-or$/i ) { + push @conds, normalize_sqla_condition( + (ref $rhs eq 'HASH') ? [ map { $_ => $rhs->{$_} } sort keys %$rhs ] : $rhs + ); + } + else { + if (ref $rhs eq 'HASH' and ! keys %$rhs) { + # FIXME - SQLA seems to be doing... nothing...? + } + # normalize top level -ident, for saner extract_fixed_condition_columns code + elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-ident}) { + push @conds, { $lhs => { '=', $rhs } }; + } + elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-value} and is_plain_value $rhs->{-value}) { + push @conds, { $lhs => $rhs->{-value} }; + } + elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='}) { + if ( length ref $rhs->{'='} and is_literal_value $rhs->{'='} ) { + push @conds, { $lhs => $rhs }; + } + else { + for my $p (_normalize_cond_unroll_pairs([ $lhs => $rhs->{'='} ])) { + + # extra sanity check + if (keys %$p > 1) { + local $Data::Dumper::Deepcopy = 1; + croak( + "Internal error: unexpected collapse unroll:" + . dump_value { in => { $lhs => $rhs }, out => $p } + ); + } + + my ($l, $r) = %$p; + + push @conds, ( + ! length ref $r + or + # the unroller recursion may return a '=' prepended value already + ref $r eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='} + or + is_plain_value($r) + ) + ? { $l => $r } + : { $l => { '=' => $r } } + ; + } + } + } + elsif (ref $rhs eq 'ARRAY') { + # some of these conditionals encounter multi-values - roll them out using + # an unshift, which will cause extra looping in the while{} above + if (! @$rhs ) { + push @conds, { $lhs => [] }; + } + elsif ( ($rhs->[0]||'') =~ /^\-(?:and|or)$/i ) { + croak("Value modifier not followed by any values: $lhs => [ $rhs->[0] ] ") + if @$rhs == 1; + + if( $rhs->[0] =~ /^\-and$/i ) { + unshift @$pairs, map { $lhs => $_ } @{$rhs}[1..$#$rhs]; + } + # if not an AND then it's an OR + elsif(@$rhs == 2) { + unshift @$pairs, $lhs => $rhs->[1]; + } + else { + push @conds, { $lhs => [ @{$rhs}[1..$#$rhs] ] }; + } + } + elsif (@$rhs == 1) { + unshift @$pairs, $lhs => $rhs->[0]; + } + else { + push @conds, { $lhs => $rhs }; + } + } + # unroll func + { -value => ... } + elsif ( + ref $rhs eq 'HASH' + and + ( my ($subop) = keys %$rhs ) == 1 + and + length ref ((values %$rhs)[0]) + and + my $vref = is_plain_value( (values %$rhs)[0] ) + ) { + push @conds, { $lhs => { $subop => $$vref } } + } + else { + push @conds, { $lhs => $rhs }; + } + } + } + + return @conds; +} + +# Analyzes a given condition and attempts to extract all columns +# with a definitive fixed-condition criteria. Returns a hashref +# of k/v pairs suitable to be passed to set_columns(), with a +# MAJOR CAVEAT - multi-value (contradictory) equalities are still +# represented as a reference to the UNRESOVABLE_CONDITION constant +# The reason we do this is that some codepaths only care about the +# codition being stable, as opposed to actually making sense +# +# The normal mode is used to figure out if a resultset is constrained +# to a column which is part of a unique constraint, which in turn +# allows us to better predict how ordering will behave etc. +# +# With the optional "consider_nulls" boolean argument, the function +# is instead used to infer inambiguous values from conditions +# (e.g. the inheritance of resultset conditions on new_result) +# +sub extract_equality_conditions { + my ($where, $consider_nulls) = @_; + my $where_hash = normalize_sqla_condition($where); + + my $res = {}; + my ($c, $v); + for $c (keys %$where_hash) { + my $vals; + + if (!defined ($v = $where_hash->{$c}) ) { + $vals->{UNDEF} = $v if $consider_nulls + } + elsif ( + ref $v eq 'HASH' + and + keys %$v == 1 + ) { + if (exists $v->{-value}) { + if (defined $v->{-value}) { + $vals->{"VAL_$v->{-value}"} = $v->{-value} + } + elsif( $consider_nulls ) { + $vals->{UNDEF} = $v->{-value}; + } + } + # do not need to check for plain values - normalize_sqla_condition did it for us + elsif( + length ref $v->{'='} + and + ( + ( ref $v->{'='} eq 'HASH' and keys %{$v->{'='}} == 1 and exists $v->{'='}{-ident} ) + or + is_literal_value($v->{'='}) + ) + ) { + $vals->{ 'SER_' . serialize $v->{'='} } = $v->{'='}; + } + } + elsif ( + ! length ref $v + or + is_plain_value ($v) + ) { + $vals->{"VAL_$v"} = $v; + } + elsif (ref $v eq 'ARRAY' and ($v->[0]||'') eq '-and') { + for ( @{$v}[1..$#$v] ) { + my $subval = extract_equality_conditions({ $c => $_ }, 'consider nulls'); # always fish nulls out on recursion + next unless exists $subval->{$c}; # didn't find anything + $vals->{ + ! defined $subval->{$c} ? 'UNDEF' + : ( ! length ref $subval->{$c} or is_plain_value $subval->{$c} ) ? "VAL_$subval->{$c}" + : ( 'SER_' . serialize $subval->{$c} ) + } = $subval->{$c}; + } + } + + if (keys %$vals == 1) { + ($res->{$c}) = (values %$vals) + unless !$consider_nulls and exists $vals->{UNDEF}; + } + elsif (keys %$vals > 1) { + $res->{$c} = UNRESOLVABLE_CONDITION; + } + } + + $res; +} + +1; diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm index c700d54eb..317dbd85a 100644 --- a/lib/DBIx/Class/Storage/DBIHacks.pm +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -5,7 +5,7 @@ package #hide from PAUSE # This module contains code supporting a battery of special cases and tests for # many corner cases pushing the envelope of what DBIC can do. When work on # these utilities began in mid 2009 (51a296b402c) it wasn't immediately obvious -# that these pieces, despite their misleading on-first-sighe-flakiness, will +# that these pieces, despite their misleading on-first-sight-flakiness, will # become part of the generic query rewriting machinery of DBIC, allowing it to # both generate and process queries representing incredibly complex sets with # reasonable efficiency. @@ -29,8 +29,10 @@ use base 'DBIx::Class::Storage'; use mro 'c3'; use Scalar::Util 'blessed'; -use DBIx::Class::_Util qw(UNRESOLVABLE_CONDITION serialize dump_value); -use SQL::Abstract qw(is_plain_value is_literal_value); +use DBIx::Class::_Util qw( + dump_value fail_on_internal_call +); +use DBIx::Class::SQLMaker::Util 'extract_equality_conditions'; use DBIx::Class::Carp; use namespace::clean; @@ -992,7 +994,7 @@ sub _order_by_is_stable { my @cols = ( ( map { $_->[0] } $self->_extract_order_criteria($order_by) ), - ( $where ? keys %{ $self->_extract_fixed_condition_columns($where) } : () ), + ( $where ? keys %{ extract_equality_conditions( $where ) } : () ), ) or return 0; my $colinfo = $self->_resolve_column_info($ident, \@cols); @@ -1057,9 +1059,9 @@ sub _extract_colinfo_of_stable_main_source_order_by_portion { if $colinfo->{-source_alias} eq $attrs->{alias}; } - # FIXME the condition may be singling out things on its own, so we - # conceivable could come back wi "stable-ordered by nothing" - # not confient enough in the parser yet, so punt for the time being + # FIXME: the condition may be singling out things on its own, so we + # conceivably could come back with "stable-ordered by nothing" + # not confident enough in the parser yet, so punt for the time being return unless $seen_main_src_cols; my $main_src_fixed_cols_from_cond = [ $attrs->{where} @@ -1070,7 +1072,7 @@ sub _extract_colinfo_of_stable_main_source_order_by_portion { ? $colinfos->{$_}{-colname} : () } - keys %{ $self->_extract_fixed_condition_columns($attrs->{where}) } + keys %{ extract_equality_conditions( $attrs->{where} ) } ) : () ]; @@ -1081,434 +1083,20 @@ sub _extract_colinfo_of_stable_main_source_order_by_portion { ]) ? $colinfos_to_return : (); } -# Attempts to flatten a passed in SQLA condition as much as possible towards -# a plain hashref, *without* altering its semantics. Required by -# create/populate being able to extract definitive conditions from preexisting -# resultset {where} stacks -# -# FIXME - while relatively robust, this is still imperfect, one of the first -# things to tackle when we get access to a formalized AST. Note that this code -# is covered by a *ridiculous* amount of tests, so starting with porting this -# code would be a rather good exercise -sub _collapse_cond { - my ($self, $where, $where_is_anded_array) = @_; - - my $fin; - - if (! $where) { - return; - } - elsif ($where_is_anded_array or ref $where eq 'HASH') { - - my @pairs; - - my @pieces = $where_is_anded_array ? @$where : $where; - while (@pieces) { - my $chunk = shift @pieces; - - if (ref $chunk eq 'HASH') { - for (sort keys %$chunk) { - - # Match SQLA 1.79 behavior - unless( length $_ ) { - is_literal_value($chunk->{$_}) - ? carp 'Hash-pairs consisting of an empty string with a literal are deprecated, use -and => [ $literal ] instead' - : $self->throw_exception("Supplying an empty left hand side argument is not supported in hash-pairs") - ; - } - - push @pairs, $_ => $chunk->{$_}; - } - } - elsif (ref $chunk eq 'ARRAY') { - push @pairs, -or => $chunk - if @$chunk; - } - elsif ( ! length ref $chunk) { - - # Match SQLA 1.79 behavior - $self->throw_exception("Supplying an empty left hand side argument is not supported in array-pairs") - if $where_is_anded_array and (! defined $chunk or ! length $chunk); - - push @pairs, $chunk, shift @pieces; - } - else { - push @pairs, '', $chunk; - } - } - - return unless @pairs; - - my @conds = $self->_collapse_cond_unroll_pairs(\@pairs) - or return; - - # Consolidate various @conds back into something more compact - for my $c (@conds) { - if (ref $c ne 'HASH') { - push @{$fin->{-and}}, $c; - } - else { - for my $col (sort keys %$c) { - - # consolidate all -and nodes - if ($col =~ /^\-and$/i) { - push @{$fin->{-and}}, - ref $c->{$col} eq 'ARRAY' ? @{$c->{$col}} - : ref $c->{$col} eq 'HASH' ? %{$c->{$col}} - : { $col => $c->{$col} } - ; - } - elsif ($col =~ /^\-/) { - push @{$fin->{-and}}, { $col => $c->{$col} }; - } - elsif (exists $fin->{$col}) { - $fin->{$col} = [ -and => map { - (ref $_ eq 'ARRAY' and ($_->[0]||'') =~ /^\-and$/i ) - ? @{$_}[1..$#$_] - : $_ - ; - } ($fin->{$col}, $c->{$col}) ]; - } - else { - $fin->{$col} = $c->{$col}; - } - } - } - } - } - elsif (ref $where eq 'ARRAY') { - # we are always at top-level here, it is safe to dump empty *standalone* pieces - my $fin_idx; - - for (my $i = 0; $i <= $#$where; $i++ ) { - - # Match SQLA 1.79 behavior - $self->throw_exception( - "Supplying an empty left hand side argument is not supported in array-pairs" - ) if (! defined $where->[$i] or ! length $where->[$i]); - - my $logic_mod = lc ( ($where->[$i] =~ /^(\-(?:and|or))$/i)[0] || '' ); - - if ($logic_mod) { - $i++; - $self->throw_exception("Unsupported top-level op/arg pair: [ $logic_mod => $where->[$i] ]") - unless ref $where->[$i] eq 'HASH' or ref $where->[$i] eq 'ARRAY'; - - my $sub_elt = $self->_collapse_cond({ $logic_mod => $where->[$i] }) - or next; - - my @keys = keys %$sub_elt; - if ( @keys == 1 and $keys[0] !~ /^\-/ ) { - $fin_idx->{ "COL_$keys[0]_" . serialize $sub_elt } = $sub_elt; - } - else { - $fin_idx->{ "SER_" . serialize $sub_elt } = $sub_elt; - } - } - elsif (! length ref $where->[$i] ) { - my $sub_elt = $self->_collapse_cond({ @{$where}[$i, $i+1] }) - or next; - - $fin_idx->{ "COL_$where->[$i]_" . serialize $sub_elt } = $sub_elt; - $i++; - } - else { - $fin_idx->{ "SER_" . serialize $where->[$i] } = $self->_collapse_cond( $where->[$i] ) || next; - } - } - - if (! $fin_idx) { - return; - } - elsif ( keys %$fin_idx == 1 ) { - $fin = (values %$fin_idx)[0]; - } - else { - my @or; - - # at this point everything is at most one level deep - unroll if needed - for (sort keys %$fin_idx) { - if ( ref $fin_idx->{$_} eq 'HASH' and keys %{$fin_idx->{$_}} == 1 ) { - my ($l, $r) = %{$fin_idx->{$_}}; - - if ( - ref $r eq 'ARRAY' - and - ( - ( @$r == 1 and $l =~ /^\-and$/i ) - or - $l =~ /^\-or$/i - ) - ) { - push @or, @$r - } - - elsif ( - ref $r eq 'HASH' - and - keys %$r == 1 - and - $l =~ /^\-(?:and|or)$/i - ) { - push @or, %$r; - } - - else { - push @or, $l, $r; - } - } - else { - push @or, $fin_idx->{$_}; - } - } - - $fin->{-or} = \@or; - } - } - else { - # not a hash not an array - $fin = { -and => [ $where ] }; - } - - # unroll single-element -and's - while ( - $fin->{-and} - and - @{$fin->{-and}} < 2 - ) { - my $and = delete $fin->{-and}; - last if @$and == 0; - - # at this point we have @$and == 1 - if ( - ref $and->[0] eq 'HASH' - and - ! grep { exists $fin->{$_} } keys %{$and->[0]} - ) { - $fin = { - %$fin, %{$and->[0]} - }; - } - else { - $fin->{-and} = $and; - last; - } - } +sub _collapse_cond :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + carp_unique("_collapse_cond() is deprecated, ask on IRC for a better alternative"); - # compress same-column conds found in $fin - for my $col ( grep { $_ !~ /^\-/ } keys %$fin ) { - next unless ref $fin->{$col} eq 'ARRAY' and ($fin->{$col}[0]||'') =~ /^\-and$/i; - my $val_bag = { map { - (! defined $_ ) ? ( UNDEF => undef ) - : ( ! length ref $_ or is_plain_value $_ ) ? ( "VAL_$_" => $_ ) - : ( ( 'SER_' . serialize $_ ) => $_ ) - } @{$fin->{$col}}[1 .. $#{$fin->{$col}}] }; - - if (keys %$val_bag == 1 ) { - ($fin->{$col}) = values %$val_bag; - } - else { - $fin->{$col} = [ -and => map { $val_bag->{$_} } sort keys %$val_bag ]; - } - } - - return keys %$fin ? $fin : (); + shift; + DBIx::Class::SQLMaker::Util::normalize_sqla_condition(@_); } -sub _collapse_cond_unroll_pairs { - my ($self, $pairs) = @_; - - my @conds; - - while (@$pairs) { - my ($lhs, $rhs) = splice @$pairs, 0, 2; - - if (! length $lhs) { - push @conds, $self->_collapse_cond($rhs); - } - elsif ( $lhs =~ /^\-and$/i ) { - push @conds, $self->_collapse_cond($rhs, (ref $rhs eq 'ARRAY')); - } - elsif ( $lhs =~ /^\-or$/i ) { - push @conds, $self->_collapse_cond( - (ref $rhs eq 'HASH') ? [ map { $_ => $rhs->{$_} } sort keys %$rhs ] : $rhs - ); - } - else { - if (ref $rhs eq 'HASH' and ! keys %$rhs) { - # FIXME - SQLA seems to be doing... nothing...? - } - # normalize top level -ident, for saner extract_fixed_condition_columns code - elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-ident}) { - push @conds, { $lhs => { '=', $rhs } }; - } - elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-value} and is_plain_value $rhs->{-value}) { - push @conds, { $lhs => $rhs->{-value} }; - } - elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='}) { - if ( length ref $rhs->{'='} and is_literal_value $rhs->{'='} ) { - push @conds, { $lhs => $rhs }; - } - else { - for my $p ($self->_collapse_cond_unroll_pairs([ $lhs => $rhs->{'='} ])) { - - # extra sanity check - if (keys %$p > 1) { - local $Data::Dumper::Deepcopy = 1; - $self->throw_exception( - "Internal error: unexpected collapse unroll:" - . dump_value { in => { $lhs => $rhs }, out => $p } - ); - } - - my ($l, $r) = %$p; - - push @conds, ( - ! length ref $r - or - # the unroller recursion may return a '=' prepended value already - ref $r eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='} - or - is_plain_value($r) - ) - ? { $l => $r } - : { $l => { '=' => $r } } - ; - } - } - } - elsif (ref $rhs eq 'ARRAY') { - # some of these conditionals encounter multi-values - roll them out using - # an unshift, which will cause extra looping in the while{} above - if (! @$rhs ) { - push @conds, { $lhs => [] }; - } - elsif ( ($rhs->[0]||'') =~ /^\-(?:and|or)$/i ) { - $self->throw_exception("Value modifier not followed by any values: $lhs => [ $rhs->[0] ] ") - if @$rhs == 1; - - if( $rhs->[0] =~ /^\-and$/i ) { - unshift @$pairs, map { $lhs => $_ } @{$rhs}[1..$#$rhs]; - } - # if not an AND then it's an OR - elsif(@$rhs == 2) { - unshift @$pairs, $lhs => $rhs->[1]; - } - else { - push @conds, { $lhs => [ @{$rhs}[1..$#$rhs] ] }; - } - } - elsif (@$rhs == 1) { - unshift @$pairs, $lhs => $rhs->[0]; - } - else { - push @conds, { $lhs => $rhs }; - } - } - # unroll func + { -value => ... } - elsif ( - ref $rhs eq 'HASH' - and - ( my ($subop) = keys %$rhs ) == 1 - and - length ref ((values %$rhs)[0]) - and - my $vref = is_plain_value( (values %$rhs)[0] ) - ) { - push @conds, { $lhs => { $subop => $$vref } } - } - else { - push @conds, { $lhs => $rhs }; - } - } - } - - return @conds; -} - -# Analyzes a given condition and attempts to extract all columns -# with a definitive fixed-condition criteria. Returns a hashref -# of k/v pairs suitable to be passed to set_columns(), with a -# MAJOR CAVEAT - multi-value (contradictory) equalities are still -# represented as a reference to the UNRESOVABLE_CONDITION constant -# The reason we do this is that some codepaths only care about the -# codition being stable, as opposed to actually making sense -# -# The normal mode is used to figure out if a resultset is constrained -# to a column which is part of a unique constraint, which in turn -# allows us to better predict how ordering will behave etc. -# -# With the optional "consider_nulls" boolean argument, the function -# is instead used to infer inambiguous values from conditions -# (e.g. the inheritance of resultset conditions on new_result) -# -sub _extract_fixed_condition_columns { - my ($self, $where, $consider_nulls) = @_; - my $where_hash = $self->_collapse_cond($_[1]); - - my $res = {}; - my ($c, $v); - for $c (keys %$where_hash) { - my $vals; - - if (!defined ($v = $where_hash->{$c}) ) { - $vals->{UNDEF} = $v if $consider_nulls - } - elsif ( - ref $v eq 'HASH' - and - keys %$v == 1 - ) { - if (exists $v->{-value}) { - if (defined $v->{-value}) { - $vals->{"VAL_$v->{-value}"} = $v->{-value} - } - elsif( $consider_nulls ) { - $vals->{UNDEF} = $v->{-value}; - } - } - # do not need to check for plain values - _collapse_cond did it for us - elsif( - length ref $v->{'='} - and - ( - ( ref $v->{'='} eq 'HASH' and keys %{$v->{'='}} == 1 and exists $v->{'='}{-ident} ) - or - is_literal_value($v->{'='}) - ) - ) { - $vals->{ 'SER_' . serialize $v->{'='} } = $v->{'='}; - } - } - elsif ( - ! length ref $v - or - is_plain_value ($v) - ) { - $vals->{"VAL_$v"} = $v; - } - elsif (ref $v eq 'ARRAY' and ($v->[0]||'') eq '-and') { - for ( @{$v}[1..$#$v] ) { - my $subval = $self->_extract_fixed_condition_columns({ $c => $_ }, 'consider nulls'); # always fish nulls out on recursion - next unless exists $subval->{$c}; # didn't find anything - $vals->{ - ! defined $subval->{$c} ? 'UNDEF' - : ( ! length ref $subval->{$c} or is_plain_value $subval->{$c} ) ? "VAL_$subval->{$c}" - : ( 'SER_' . serialize $subval->{$c} ) - } = $subval->{$c}; - } - } - - if (keys %$vals == 1) { - ($res->{$c}) = (values %$vals) - unless !$consider_nulls and exists $vals->{UNDEF}; - } - elsif (keys %$vals > 1) { - $res->{$c} = UNRESOLVABLE_CONDITION; - } - } +sub _extract_fixed_condition_columns :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + carp_unique("_extract_fixed_condition_columns() is deprecated, ask on IRC for a better alternative"); - $res; + shift; + extract_equality_conditions(@_); } 1; diff --git a/xt/extra/internals/namespaces_cleaned.t b/xt/extra/internals/namespaces_cleaned.t index 2230957d2..b0a7cdb62 100644 --- a/xt/extra/internals/namespaces_cleaned.t +++ b/xt/extra/internals/namespaces_cleaned.t @@ -80,6 +80,7 @@ my $skip_idx = { map { $_ => 1 } ( # utility classes, not part of the inheritance chain 'DBIx::Class::Optional::Dependencies', 'DBIx::Class::ResultSource::RowParser::Util', + 'DBIx::Class::SQLMaker::Util', 'DBIx::Class::_Util', ) }; diff --git a/t/sqlmaker/dbihacks_internals.t b/xt/extra/internals/sqla_condition_parsers.t similarity index 64% rename from t/sqlmaker/dbihacks_internals.t rename to xt/extra/internals/sqla_condition_parsers.t index 4e34f13e6..5c94edc65 100644 --- a/t/sqlmaker/dbihacks_internals.t +++ b/xt/extra/internals/sqla_condition_parsers.t @@ -9,6 +9,7 @@ use Test::Exception; use DBICTest ':DiffSQL'; use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dump_value ); +use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); BEGIN { if ( eval { require Test::Differences } ) { @@ -17,8 +18,7 @@ BEGIN { } } -my $schema = DBICTest->init_schema( no_deploy => 1); -my $sm = $schema->storage->sql_maker; +my $sm = DBICTest->init_schema( no_deploy => 1)->storage->sql_maker; { package # hideee @@ -37,95 +37,95 @@ is("$num", 69, 'test overloaded object is "sane"'); my @tests = ( { where => { artistid => 1, charfield => undef }, - cc_result => { artistid => 1, charfield => undef }, + normalized => { artistid => 1, charfield => undef }, sql => 'WHERE artistid = ? AND charfield IS NULL', - efcc_result => { artistid => 1 }, - efcc_n_result => { artistid => 1, charfield => undef }, + equality_extract => { artistid => 1 }, + equality_considering_nulls_extract => { artistid => 1, charfield => undef }, }, { where => { -and => [ artistid => 1, charfield => undef, { rank => 13 } ] }, - cc_result => { artistid => 1, charfield => undef, rank => 13 }, + normalized => { artistid => 1, charfield => undef, rank => 13 }, sql => 'WHERE artistid = ? AND charfield IS NULL AND rank = ?', - efcc_result => { artistid => 1, rank => 13 }, - efcc_n_result => { artistid => 1, charfield => undef, rank => 13 }, + equality_extract => { artistid => 1, rank => 13 }, + equality_considering_nulls_extract => { artistid => 1, charfield => undef, rank => 13 }, }, { where => { -and => [ { artistid => 1, charfield => undef}, { rank => 13 } ] }, - cc_result => { artistid => 1, charfield => undef, rank => 13 }, + normalized => { artistid => 1, charfield => undef, rank => 13 }, sql => 'WHERE artistid = ? AND charfield IS NULL AND rank = ?', - efcc_result => { artistid => 1, rank => 13 }, - efcc_n_result => { artistid => 1, charfield => undef, rank => 13 }, + equality_extract => { artistid => 1, rank => 13 }, + equality_considering_nulls_extract => { artistid => 1, charfield => undef, rank => 13 }, }, { where => { -and => [ -or => { name => 'Caterwauler McCrae' }, 'rank' ] }, - cc_result => { name => 'Caterwauler McCrae', rank => undef }, + normalized => { name => 'Caterwauler McCrae', rank => undef }, sql => 'WHERE name = ? AND rank IS NULL', - efcc_result => { name => 'Caterwauler McCrae' }, - efcc_n_result => { name => 'Caterwauler McCrae', rank => undef }, + equality_extract => { name => 'Caterwauler McCrae' }, + equality_considering_nulls_extract => { name => 'Caterwauler McCrae', rank => undef }, }, { where => { -and => [ [ [ artist => {'=' => \'foo' } ] ], { name => \[ '= ?', 'bar' ] } ] }, - cc_result => { artist => {'=' => \'foo' }, name => \[ '= ?', 'bar' ] }, + normalized => { artist => {'=' => \'foo' }, name => \[ '= ?', 'bar' ] }, sql => 'WHERE artist = foo AND name = ?', - efcc_result => { artist => \'foo' }, + equality_extract => { artist => \'foo' }, }, { where => { -and => [ -or => { name => 'Caterwauler McCrae', artistid => 2 } ] }, - cc_result => { -or => [ artistid => 2, name => 'Caterwauler McCrae' ] }, + normalized => { -or => [ artistid => 2, name => 'Caterwauler McCrae' ] }, sql => 'WHERE artistid = ? OR name = ?', - efcc_result => {}, + equality_extract => {}, }, { where => { -or => { name => 'Caterwauler McCrae', artistid => 2 } }, - cc_result => { -or => [ artistid => 2, name => 'Caterwauler McCrae' ] }, + normalized => { -or => [ artistid => 2, name => 'Caterwauler McCrae' ] }, sql => 'WHERE artistid = ? OR name = ?', - efcc_result => {}, + equality_extract => {}, }, { where => { -and => [ \'foo=bar', [ { artistid => { '=', $num } } ], { name => 'Caterwauler McCrae'} ] }, - cc_result => { -and => [ \'foo=bar' ], name => 'Caterwauler McCrae', artistid => $num }, + normalized => { -and => [ \'foo=bar' ], name => 'Caterwauler McCrae', artistid => $num }, sql => 'WHERE foo=bar AND artistid = ? AND name = ?', - efcc_result => { name => 'Caterwauler McCrae', artistid => $num }, + equality_extract => { name => 'Caterwauler McCrae', artistid => $num }, }, { where => { -and => [ \'foo=bar', [ { artistid => { '=', $num } } ], { name => 'Caterwauler McCrae'}, \'buzz=bozz' ] }, - cc_result => { -and => [ \'foo=bar', \'buzz=bozz' ], name => 'Caterwauler McCrae', artistid => $num }, - sql => 'WHERE foo=bar AND artistid = ? AND name = ? AND buzz=bozz', - collapsed_sql => 'WHERE foo=bar AND buzz=bozz AND artistid = ? AND name = ?', - efcc_result => { name => 'Caterwauler McCrae', artistid => $num }, + normalized => { -and => [ \'foo=bar', \'buzz=bozz' ], name => 'Caterwauler McCrae', artistid => $num }, + sql => 'WHERE foo=bar AND artistid = ? AND name = ? AND buzz=bozz', + normalized_sql => 'WHERE foo=bar AND buzz=bozz AND artistid = ? AND name = ?', + equality_extract => { name => 'Caterwauler McCrae', artistid => $num }, }, { where => { artistid => [ $num ], rank => [ 13, 2, 3 ], charfield => [ undef ] }, - cc_result => { artistid => $num, charfield => undef, rank => [13, 2, 3] }, + normalized => { artistid => $num, charfield => undef, rank => [13, 2, 3] }, sql => 'WHERE artistid = ? AND charfield IS NULL AND ( rank = ? OR rank = ? OR rank = ? )', - efcc_result => { artistid => $num }, - efcc_n_result => { artistid => $num, charfield => undef }, + equality_extract => { artistid => $num }, + equality_considering_nulls_extract => { artistid => $num, charfield => undef }, }, { where => { artistid => { '=' => 1 }, rank => { '>' => 12 }, charfield => { '=' => undef } }, - cc_result => { artistid => 1, charfield => undef, rank => { '>' => 12 } }, + normalized => { artistid => 1, charfield => undef, rank => { '>' => 12 } }, sql => 'WHERE artistid = ? AND charfield IS NULL AND rank > ?', - efcc_result => { artistid => 1 }, - efcc_n_result => { artistid => 1, charfield => undef }, + equality_extract => { artistid => 1 }, + equality_considering_nulls_extract => { artistid => 1, charfield => undef }, }, { where => { artistid => { '=' => [ 1 ], }, charfield => { '=' => [ -AND => \'1', \['?',2] ] }, rank => { '=' => [ -OR => $num, $num ] } }, - cc_result => { artistid => 1, charfield => [-and => { '=' => \['?',2] }, { '=' => \'1' } ], rank => { '=' => [$num, $num] } }, - sql => 'WHERE artistid = ? AND charfield = 1 AND charfield = ? AND ( rank = ? OR rank = ? )', - collapsed_sql => 'WHERE artistid = ? AND charfield = ? AND charfield = 1 AND ( rank = ? OR rank = ? )', - efcc_result => { artistid => 1, charfield => UNRESOLVABLE_CONDITION }, + normalized => { artistid => 1, charfield => [-and => { '=' => \['?',2] }, { '=' => \'1' } ], rank => { '=' => [$num, $num] } }, + sql => 'WHERE artistid = ? AND charfield = 1 AND charfield = ? AND ( rank = ? OR rank = ? )', + normalized_sql => 'WHERE artistid = ? AND charfield = ? AND charfield = 1 AND ( rank = ? OR rank = ? )', + equality_extract => { artistid => 1, charfield => UNRESOLVABLE_CONDITION }, }, { where => { -and => [ artistid => 1, artistid => 2 ], name => [ -and => { '!=', 1 }, 2 ], charfield => [ -or => { '=', 2 } ], rank => [-and => undef, { '=', undef }, { '!=', 2 } ] }, - cc_result => { artistid => [ -and => 1, 2 ], name => [ -and => { '!=', 1 }, 2 ], charfield => 2, rank => [ -and => { '!=', 2 }, undef ] }, - sql => 'WHERE artistid = ? AND artistid = ? AND charfield = ? AND name != ? AND name = ? AND rank IS NULL AND rank IS NULL AND rank != ?', - collapsed_sql => 'WHERE artistid = ? AND artistid = ? AND charfield = ? AND name != ? AND name = ? AND rank != ? AND rank IS NULL', - efcc_result => { + normalized => { artistid => [ -and => 1, 2 ], name => [ -and => { '!=', 1 }, 2 ], charfield => 2, rank => [ -and => { '!=', 2 }, undef ] }, + sql => 'WHERE artistid = ? AND artistid = ? AND charfield = ? AND name != ? AND name = ? AND rank IS NULL AND rank IS NULL AND rank != ?', + normalized_sql => 'WHERE artistid = ? AND artistid = ? AND charfield = ? AND name != ? AND name = ? AND rank != ? AND rank IS NULL', + equality_extract => { artistid => UNRESOLVABLE_CONDITION, name => 2, charfield => 2, }, - efcc_n_result => { + equality_considering_nulls_extract => { artistid => UNRESOLVABLE_CONDITION, name => 2, charfield => 2, @@ -134,14 +134,14 @@ my @tests = ( }, (map { { where => $_, - sql => 'WHERE (rank = 13 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank != 42)', - collapsed_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank = 13) AND (artistid = ? OR charfield IS NULL OR rank != 42)', - cc_result => { -and => [ + sql => 'WHERE (rank = 13 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank != 42)', + normalized_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank = 13) AND (artistid = ? OR charfield IS NULL OR rank != 42)', + normalized => { -and => [ { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, { -or => [ artistid => 1, charfield => undef, rank => { '!=' => \42 } ] }, ] }, - efcc_result => {}, - efcc_n_result => {}, + equality_extract => {}, + equality_considering_nulls_extract => {}, } } ( { -and => [ @@ -162,37 +162,37 @@ my @tests = ( baz => { '!=' => { -ident => 'bozz' } }, baz => { -ident => 'buzz' }, ] }, - sql => 'WHERE ( foo IS NOT NULL AND bar IN ( ?, ? ) ) OR foo IS NULL OR baz != bozz OR baz = buzz', - collapsed_sql => 'WHERE baz != bozz OR baz = buzz OR foo IS NULL OR ( bar IN ( ?, ? ) AND foo IS NOT NULL )', - cc_result => { -or => [ + sql => 'WHERE ( foo IS NOT NULL AND bar IN ( ?, ? ) ) OR foo IS NULL OR baz != bozz OR baz = buzz', + normalized_sql => 'WHERE baz != bozz OR baz = buzz OR foo IS NULL OR ( bar IN ( ?, ? ) AND foo IS NOT NULL )', + normalized => { -or => [ baz => { '!=' => { -ident => 'bozz' } }, baz => { '=' => { -ident => 'buzz' } }, foo => undef, { bar => { -in => [ 69, 42 ] }, foo => { '!=', undef } } ] }, - efcc_result => {}, + equality_extract => {}, }, { where => { -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => { '=' => 1 }, genreid => { '=' => \['?', 2] } ] }, - sql => 'WHERE rank = 13 OR charfield IS NULL OR artistid = ? OR genreid = ?', - collapsed_sql => 'WHERE artistid = ? OR charfield IS NULL OR genreid = ? OR rank = 13', - cc_result => { -or => [ artistid => 1, charfield => undef, genreid => { '=' => \['?', 2] }, rank => { '=' => \13 } ] }, - efcc_result => {}, - efcc_n_result => {}, + sql => 'WHERE rank = 13 OR charfield IS NULL OR artistid = ? OR genreid = ?', + normalized_sql => 'WHERE artistid = ? OR charfield IS NULL OR genreid = ? OR rank = 13', + normalized => { -or => [ artistid => 1, charfield => undef, genreid => { '=' => \['?', 2] }, rank => { '=' => \13 } ] }, + equality_extract => {}, + equality_considering_nulls_extract => {}, }, { where => { -and => [ -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ], -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '=' => \13 } }, ] }, - cc_result => { -and => [ + normalized => { -and => [ { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, ] }, - sql => 'WHERE (rank = 13 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank = 13)', - collapsed_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank = 13) AND (artistid = ? OR charfield IS NULL OR rank = 13)', - efcc_result => {}, - efcc_n_result => {}, + sql => 'WHERE (rank = 13 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank = 13)', + normalized_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank = 13) AND (artistid = ? OR charfield IS NULL OR rank = 13)', + equality_extract => {}, + equality_considering_nulls_extract => {}, }, { where => { -and => [ @@ -217,7 +217,7 @@ my @tests = ( AND NOT foo = ? AND NOT foo = ? ', - collapsed_sql => 'WHERE + normalized_sql => 'WHERE ( artistid = ? OR charfield IS NULL OR rank = 13 ) AND ( artistid = ? OR charfield IS NULL OR rank != 42 ) AND (EXISTS (SELECT 1)) @@ -229,7 +229,7 @@ my @tests = ( AND foo = 1 AND foo = ? ', - cc_result => { + normalized => { -and => [ { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, { -or => [ artistid => 1, charfield => undef, rank => { '!=' => \42 } ] }, @@ -241,11 +241,11 @@ my @tests = ( foo => [ -and => { '=' => \1 }, 3 ], bar => [ -and => { '=' => \4 }, 2 ], }, - efcc_result => { + equality_extract => { foo => UNRESOLVABLE_CONDITION, bar => UNRESOLVABLE_CONDITION, }, - efcc_n_result => { + equality_considering_nulls_extract => { foo => UNRESOLVABLE_CONDITION, bar => UNRESOLVABLE_CONDITION, }, @@ -255,7 +255,7 @@ my @tests = ( [ '_macro.to' => { -like => '%correct%' }, '_wc_macros.to' => { -like => '%correct%' } ], { -and => [ { 'group.is_active' => 1 }, { 'me.is_active' => 1 } ] } ] }, - cc_result => { + normalized => { 'group.is_active' => 1, 'me.is_active' => 1, -or => [ @@ -264,7 +264,7 @@ my @tests = ( ], }, sql => 'WHERE ( _macro.to LIKE ? OR _wc_macros.to LIKE ? ) AND group.is_active = ? AND me.is_active = ?', - efcc_result => { 'group.is_active' => 1, 'me.is_active' => 1 }, + equality_extract => { 'group.is_active' => 1, 'me.is_active' => 1 }, }, { @@ -275,18 +275,18 @@ my @tests = ( rank => { '=' => { -ident => 'bar' } }, ] }, sql => 'WHERE artistid = ? AND charfield = foo AND name IS NULL AND rank = bar', - cc_result => { + normalized => { artistid => { -value => [1] }, name => undef, charfield => { '=', { -ident => 'foo' } }, rank => { '=' => { -ident => 'bar' } }, }, - efcc_result => { + equality_extract => { artistid => [1], charfield => { -ident => 'foo' }, rank => { -ident => 'bar' }, }, - efcc_n_result => { + equality_considering_nulls_extract => { artistid => [1], name => undef, charfield => { -ident => 'foo' }, @@ -296,40 +296,40 @@ my @tests = ( { where => { artistid => [] }, - cc_result => { artistid => [] }, - efcc_result => {}, + normalized => { artistid => [] }, + equality_extract => {}, }, (map { { where => { -and => $_ }, - cc_result => undef, - efcc_result => {}, + normalized => undef, + equality_extract => {}, sql => '', }, { where => { -or => $_ }, - cc_result => undef, - efcc_result => {}, + normalized => undef, + equality_extract => {}, sql => '', }, { where => { -or => [ foo => 1, $_ ] }, - cc_result => { foo => 1 }, - efcc_result => { foo => 1 }, + normalized => { foo => 1 }, + equality_extract => { foo => 1 }, sql => 'WHERE foo = ?', }, { where => { -or => [ $_, foo => 1 ] }, - cc_result => { foo => 1 }, - efcc_result => { foo => 1 }, + normalized => { foo => 1 }, + equality_extract => { foo => 1 }, sql => 'WHERE foo = ?', }, { where => { -and => [ fuu => 2, $_, foo => 1 ] }, - sql => 'WHERE fuu = ? AND foo = ?', - collapsed_sql => 'WHERE foo = ? AND fuu = ?', - cc_result => { foo => 1, fuu => 2 }, - efcc_result => { foo => 1, fuu => 2 }, + sql => 'WHERE fuu = ? AND foo = ?', + normalized_sql => 'WHERE foo = ? AND fuu = ?', + normalized => { foo => 1, fuu => 2 }, + equality_extract => { foo => 1, fuu => 2 }, }, } ( # bare @@ -343,16 +343,16 @@ my @tests = ( )), # FIXME legacy compat crap, possibly worth undef/dieing in SQLMaker - { where => { artistid => {} }, sql => '', cc_result => undef, efcc_result => {}, efcc_n_result => {} }, + { where => { artistid => {} }, sql => '', normalized => undef, equality_extract => {}, equality_considering_nulls_extract => {} }, # batshit insanity, just to be thorough { where => { -and => [ [ 'artistid' ], [ -and => [ artistid => { '!=', 69 }, artistid => undef, artistid => { '=' => 200 } ]], artistid => [], { -or => [] }, { -and => [] }, [ 'charfield' ], { name => [] }, 'rank' ] }, - cc_result => { artistid => [ -and => [], { '!=', 69 }, undef, 200 ], charfield => undef, name => [], rank => undef }, - sql => 'WHERE artistid IS NULL AND artistid != ? AND artistid IS NULL AND artistid = ? AND 0=1 AND charfield IS NULL AND 0=1 AND rank IS NULL', - collapsed_sql => 'WHERE 0=1 AND artistid != ? AND artistid IS NULL AND artistid = ? AND charfield IS NULL AND 0=1 AND rank IS NULL', - efcc_result => { artistid => UNRESOLVABLE_CONDITION }, - efcc_n_result => { artistid => UNRESOLVABLE_CONDITION, charfield => undef, rank => undef }, + normalized => { artistid => [ -and => [], { '!=', 69 }, undef, 200 ], charfield => undef, name => [], rank => undef }, + sql => 'WHERE artistid IS NULL AND artistid != ? AND artistid IS NULL AND artistid = ? AND 0=1 AND charfield IS NULL AND 0=1 AND rank IS NULL', + normalized_sql => 'WHERE 0=1 AND artistid != ? AND artistid IS NULL AND artistid = ? AND charfield IS NULL AND 0=1 AND rank IS NULL', + equality_extract => { artistid => UNRESOLVABLE_CONDITION }, + equality_considering_nulls_extract => { artistid => UNRESOLVABLE_CONDITION, charfield => undef, rank => undef }, }, # original test from RT#93244 @@ -365,7 +365,7 @@ my @tests = ( ], [ { 'me.title' => 'Spoonful of bees' } ], ]}, - cc_result => { + normalized => { -and => [ \[ "LOWER(me.title) LIKE ?", '%spoon%', @@ -373,7 +373,7 @@ my @tests = ( 'me.title' => 'Spoonful of bees', }, sql => 'WHERE LOWER(me.title) LIKE ? AND me.title = ?', - efcc_result => { 'me.title' => 'Spoonful of bees' }, + equality_extract => { 'me.title' => 'Spoonful of bees' }, }, # crazy literals @@ -384,12 +384,12 @@ my @tests = ( ], }, sql => 'WHERE foo = bar', - cc_result => { + normalized => { -and => [ \'foo = bar', ], }, - efcc_result => {}, + equality_extract => {}, }, { where => { @@ -398,15 +398,15 @@ my @tests = ( \'baz = ber', ], }, - sql => 'WHERE foo = bar OR baz = ber', - collapsed_sql => 'WHERE baz = ber OR foo = bar', - cc_result => { + sql => 'WHERE foo = bar OR baz = ber', + normalized_sql => 'WHERE baz = ber OR foo = bar', + normalized => { -or => [ \'baz = ber', \'foo = bar', ], }, - efcc_result => {}, + equality_extract => {}, }, { where => { @@ -416,13 +416,13 @@ my @tests = ( ], }, sql => 'WHERE foo = bar AND baz = ber', - cc_result => { + normalized => { -and => [ \'foo = bar', \'baz = ber', ], }, - efcc_result => {}, + equality_extract => {}, }, { where => { @@ -433,14 +433,14 @@ my @tests = ( ], }, sql => 'WHERE foo = bar AND baz = ber AND x = y', - cc_result => { + normalized => { -and => [ \'foo = bar', \'baz = ber', ], x => { '=' => { -ident => 'y' } } }, - efcc_result => { x => { -ident => 'y' } }, + equality_extract => { x => { -ident => 'y' } }, }, ); @@ -495,8 +495,8 @@ for my $lhs (undef, '') { push @tests, { where => { $lhs => $rhs }, - cc_result => { -and => [ $rhs ] }, - efcc_result => {}, + normalized => { -and => [ $rhs ] }, + equality_extract => {}, sql => 'WHERE baz', warn => $expected_warning, }; @@ -507,12 +507,12 @@ for my $lhs (undef, '') { ) { push @tests, { where => $w, - cc_result => { + normalized => { -and => [ $rhs ], bizz => "buzz", foo => "bar", }, - efcc_result => { + equality_extract => { foo => "bar", bizz => "buzz", }, @@ -539,12 +539,12 @@ for my $eq ( ) { push @tests, { where => $where, - cc_result => { + normalized => { 0 => $eq, foo => 'bar', bizz => 'buzz', }, - efcc_result => { + equality_extract => { foo => 'bar', bizz => 'buzz', ( ref $eq eq 'HASH' ? ( 0 => $eq->{'='} ) : () ), @@ -554,12 +554,12 @@ for my $eq ( push @tests, { where => { -or => $where }, - cc_result => { -or => [ + normalized => { -or => [ "0" => $eq, bizz => 'buzz', foo => 'bar', ]}, - efcc_result => {}, + equality_extract => {}, sql => 'WHERE 0 = baz OR bizz = ? OR foo = ?', } @@ -574,14 +574,14 @@ for my $eq ( ) { push @tests, { where => { -or => $where }, - cc_result => { -or => [ + normalized => { -or => [ "0" => $eq, bizz => 'buzz', foo => 'bar', ]}, - efcc_result => {}, - sql => 'WHERE foo = ? OR 0 = baz OR bizz = ?', - collapsed_sql => 'WHERE 0 = baz OR bizz = ? OR foo = ?', + equality_extract => {}, + sql => 'WHERE foo = ? OR 0 = baz OR bizz = ?', + normalized_sql => 'WHERE 0 = baz OR bizz = ? OR foo = ?', } } @@ -591,14 +591,14 @@ for my $eq ( ) { push @tests, { where => { -or => $where }, - cc_result => { -or => [ + normalized => { -or => [ "0" => 'baz', bizz => 'buzz', foo => 'bar', ]}, - efcc_result => {}, - sql => 'WHERE foo = ? OR 0 = ? OR bizz = ?', - collapsed_sql => 'WHERE 0 = ? OR bizz = ? OR foo = ?', + equality_extract => {}, + sql => 'WHERE foo = ? OR 0 = ? OR bizz = ?', + normalized_sql => 'WHERE 0 = ? OR bizz = ? OR foo = ?', }; } @@ -627,25 +627,24 @@ for my $t (@tests) { my $name = do { local $Data::Dumper::Indent = 0; dump_value $w }; - my ($collapsed_cond, $collapsed_cond_as_sql); + my ($normalized_cond, $normalized_cond_as_sql); if ($t->{throw}) { throws_ok { - $collapsed_cond = $schema->storage->_collapse_cond($w); - ($collapsed_cond_as_sql) = $sm->where($collapsed_cond); + $sm->where( normalize_sqla_condition($w) ); } $t->{throw}, "Exception on attempted collapse/render of $name" and next; } warnings_exist { - $collapsed_cond = $schema->storage->_collapse_cond($w); - ($collapsed_cond_as_sql) = $sm->where($collapsed_cond); + $normalized_cond = normalize_sqla_condition($w); + ($normalized_cond_as_sql) = $sm->where($normalized_cond); } $t->{warn} || [], "Expected warning when collapsing/rendering $name"; is_deeply( - $collapsed_cond, - $t->{cc_result}, + $normalized_cond, + $t->{normalized}, "Expected collapsed condition produced on $name", ); @@ -658,27 +657,27 @@ for my $t (@tests) { if exists $t->{sql}; is_same_sql( - $collapsed_cond_as_sql, - ( $t->{collapsed_sql} || $t->{sql} || $original_sql ), - "Collapse did not alter *the semantics* of the final SQL based on $name", + $normalized_cond_as_sql, + ( $t->{normalized_sql} || $t->{sql} || $original_sql ), + "Normalization did not alter *the semantics* of the final SQL based on $name", ); is_deeply( - $schema->storage->_extract_fixed_condition_columns($collapsed_cond), - $t->{efcc_result}, - "Expected fixed_condition produced on $name", + extract_equality_conditions($normalized_cond), + $t->{equality_extract}, + "Expected equality_conditions produced on $name", ); is_deeply( - $schema->storage->_extract_fixed_condition_columns($collapsed_cond, 'consider_nulls'), - $t->{efcc_n_result}, - "Expected fixed_condition including NULLs produced on $name", - ) if $t->{efcc_n_result}; + extract_equality_conditions($normalized_cond, 'consider_nulls'), + ( $t->{equality_considering_nulls_extract} || $t->{equality_extract} ), + "Expected equality_conditions including NULLs produced on $name", + ); is_deeply( - $collapsed_cond, - $t->{cc_result}, - "Collapsed condition result unaltered by fixed condition extractor", + $normalized_cond, + $t->{normalized}, + "Collapsed condition result unaltered by equality conditions extractor", ); } } From aa072cab54f2e6af9a9db82b3cdec0ebb97717cc Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 20 Aug 2016 11:09:39 +0200 Subject: [PATCH 217/262] Fix SQLA condition normalizer sometimes stripping -value ops --- lib/DBIx/Class/SQLMaker/Util.pm | 6 +++++- xt/extra/internals/sqla_condition_parsers.t | 11 ++++++++++- 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/lib/DBIx/Class/SQLMaker/Util.pm b/lib/DBIx/Class/SQLMaker/Util.pm index ec83edde0..e538843c1 100644 --- a/lib/DBIx/Class/SQLMaker/Util.pm +++ b/lib/DBIx/Class/SQLMaker/Util.pm @@ -348,7 +348,11 @@ sub _normalize_cond_unroll_pairs { and my $vref = is_plain_value( (values %$rhs)[0] ) ) { - push @conds, { $lhs => { $subop => $$vref } } + push @conds, ( + (length ref $$vref) + ? { $lhs => $rhs } + : { $lhs => { $subop => $$vref } } + ); } else { push @conds, { $lhs => $rhs }; diff --git a/xt/extra/internals/sqla_condition_parsers.t b/xt/extra/internals/sqla_condition_parsers.t index 5c94edc65..14a2c31a7 100644 --- a/xt/extra/internals/sqla_condition_parsers.t +++ b/xt/extra/internals/sqla_condition_parsers.t @@ -273,14 +273,17 @@ my @tests = ( charfield => { -ident => 'foo' }, name => { '=' => { -value => undef } }, rank => { '=' => { -ident => 'bar' } }, + arrayfield => { '>' => { -value => [3,1] } }, ] }, - sql => 'WHERE artistid = ? AND charfield = foo AND name IS NULL AND rank = bar', normalized => { artistid => { -value => [1] }, name => undef, charfield => { '=', { -ident => 'foo' } }, rank => { '=' => { -ident => 'bar' } }, + arrayfield => { '>' => { -value => [3,1] } }, }, + sql => 'WHERE artistid = ? AND charfield = foo AND name IS NULL AND rank = bar AND arrayfield > ?', + normalized_sql => 'WHERE arrayfield > ? AND artistid = ? AND charfield = foo AND name IS NULL AND rank = bar', equality_extract => { artistid => [1], charfield => { -ident => 'foo' }, @@ -682,4 +685,10 @@ for my $t (@tests) { } } +# test separately +is_deeply( + normalize_sqla_condition( UNRESOLVABLE_CONDITION ), + { -and => [ UNRESOLVABLE_CONDITION ] }, +); + done_testing; From d6c13bfdf6656317fedbf7e9deeb450cf42efb5b Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 7 Nov 2015 11:49:37 +0100 Subject: [PATCH 218/262] Add an explicit deduplication of identical condition in cond normalizer In order to make everything work consistently add a "lax serializer" based on Data::Dumper, as Storable is sensitive to IV vs PVIV differences. While at it tighten up the serialize/dump env in DBIC::_Util --- lib/DBIx/Class/SQLMaker/Util.pm | 93 +++++++++++++++++++-- lib/DBIx/Class/_Util.pm | 50 +++++++++-- t/52leaks.t | 9 ++ t/search/stack_cond.t | 6 +- xt/extra/internals/sqla_condition_parsers.t | 68 +++++++++------ 5 files changed, 180 insertions(+), 46 deletions(-) diff --git a/lib/DBIx/Class/SQLMaker/Util.pm b/lib/DBIx/Class/SQLMaker/Util.pm index e538843c1..f029e24a9 100644 --- a/lib/DBIx/Class/SQLMaker/Util.pm +++ b/lib/DBIx/Class/SQLMaker/Util.pm @@ -13,7 +13,71 @@ our @EXPORT_OK = qw( use DBIx::Class::Carp; use Carp 'croak'; use SQL::Abstract qw( is_literal_value is_plain_value ); -use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION serialize dump_value ); +use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dump_value modver_gt_or_eq ); + +# Can not use DBIx::Class::_Util::serialize as it is based on +# Storable and leaks through differences between PVIV and an identical IV +# Since SQLA itself is lossy in this regard (it does not make proper copies +# for efficiency) one could end up in a situation where semantically +# identical values aren't treated as such +my $dd_obj; +sub lax_serialize ($) { + my $dump_str = ( + $dd_obj + ||= + do { + require Data::Dumper; + + # Warnings without this on early loads under -w + # Why? Because fuck me, that's why :/ + local $Data::Dumper::Indent = 0 + unless defined $Data::Dumper::Indent; + + # Make sure each option is spelled out with a value, so that + # global environment changes can not override any of these + # between two serialization calls + # + my $d = Data::Dumper->new([]) + ->Indent('0') + ->Purity(0) + ->Pad('') + ->Useqq(0) + ->Terse(1) + ->Freezer('') + ->Toaster('') + ->Deepcopy(0) + ->Quotekeys(0) + ->Bless('bless') + ->Pair(' => ') + ->Maxdepth(0) + ->Useperl(0) + ->Sortkeys(1) + ->Deparse(0) + ; + + # FIXME - this is kinda ridiculous - there ought to be a + # Data::Dumper->new_with_defaults or somesuch... + # + if( modver_gt_or_eq ( 'Data::Dumper', '2.136' ) ) { + $d->Sparseseen(1); + + if( modver_gt_or_eq ( 'Data::Dumper', '2.153' ) ) { + $d->Maxrecurse(1000); + + if( modver_gt_or_eq ( 'Data::Dumper', '2.160' ) ) { + $d->Trailingcomma(0); + } + } + } + + $d; + } + )->Values([$_[0]])->Dump; + + $dd_obj->Reset->Values([]); + + $dump_str; +} # Attempts to flatten a passed in SQLA condition as much as possible towards @@ -81,7 +145,7 @@ sub normalize_sqla_condition { push @{$fin->{-and}}, $c; } else { - for my $col (sort keys %$c) { + for my $col (keys %$c) { # consolidate all -and nodes if ($col =~ /^\-and$/i) { @@ -108,6 +172,17 @@ sub normalize_sqla_condition { } } } + + # a deduplication (and sort) pass on all individual -and/-or members + for my $op (qw( -and -or )) { + if( @{ $fin->{$op} || [] } > 1 ) { + my $seen_chunks = { map { + lax_serialize($_) => $_ + } @{$fin->{$op}} }; + + $fin->{$op} = [ @{$seen_chunks}{ sort keys %$seen_chunks } ]; + } + } } elsif (ref $where eq 'ARRAY') { # we are always at top-level here, it is safe to dump empty *standalone* pieces @@ -132,21 +207,21 @@ sub normalize_sqla_condition { my @keys = keys %$sub_elt; if ( @keys == 1 and $keys[0] !~ /^\-/ ) { - $fin_idx->{ "COL_$keys[0]_" . serialize $sub_elt } = $sub_elt; + $fin_idx->{ "COL_$keys[0]_" . lax_serialize $sub_elt } = $sub_elt; } else { - $fin_idx->{ "SER_" . serialize $sub_elt } = $sub_elt; + $fin_idx->{ "SER_" . lax_serialize $sub_elt } = $sub_elt; } } elsif (! length ref $where->[$i] ) { my $sub_elt = normalize_sqla_condition({ @{$where}[$i, $i+1] }) or next; - $fin_idx->{ "COL_$where->[$i]_" . serialize $sub_elt } = $sub_elt; + $fin_idx->{ "COL_$where->[$i]_" . lax_serialize $sub_elt } = $sub_elt; $i++; } else { - $fin_idx->{ "SER_" . serialize $where->[$i] } = normalize_sqla_condition( $where->[$i] ) || next; + $fin_idx->{ "SER_" . lax_serialize $where->[$i] } = normalize_sqla_condition( $where->[$i] ) || next; } } @@ -234,7 +309,7 @@ sub normalize_sqla_condition { my $val_bag = { map { (! defined $_ ) ? ( UNDEF => undef ) : ( ! length ref $_ or is_plain_value $_ ) ? ( "VAL_$_" => $_ ) - : ( ( 'SER_' . serialize $_ ) => $_ ) + : ( ( 'SER_' . lax_serialize $_ ) => $_ ) } @{$fin->{$col}}[1 .. $#{$fin->{$col}}] }; if (keys %$val_bag == 1 ) { @@ -414,7 +489,7 @@ sub extract_equality_conditions { is_literal_value($v->{'='}) ) ) { - $vals->{ 'SER_' . serialize $v->{'='} } = $v->{'='}; + $vals->{ 'SER_' . lax_serialize $v->{'='} } = $v->{'='}; } } elsif ( @@ -431,7 +506,7 @@ sub extract_equality_conditions { $vals->{ ! defined $subval->{$c} ? 'UNDEF' : ( ! length ref $subval->{$c} or is_plain_value $subval->{$c} ) ? "VAL_$subval->{$c}" - : ( 'SER_' . serialize $subval->{$c} ) + : ( 'SER_' . lax_serialize $subval->{$c} ) } = $subval->{$c}; } } diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index ac3a93715..7d4a4075c 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -352,7 +352,19 @@ sub set_subname ($$) { } sub serialize ($) { + # stable hash order local $Storable::canonical = 1; + + # explicitly false - there is nothing sensible that can come out of + # an attempt at CODE serialization + local $Storable::Deparse; + + # take no chances + local $Storable::forgive_me; + + # FIXME + # A number of codepaths *expect* this to be Storable.pm-based so that + # the STORABLE_freeze hooks in the metadata subtree get executed properly nfreeze($_[0]); } @@ -388,9 +400,20 @@ sub dump_value ($) { ->Deparse(1) ; - $d->Sparseseen(1) if modver_gt_or_eq ( - 'Data::Dumper', '2.136' - ); + # FIXME - this is kinda ridiculous - there ought to be a + # Data::Dumper->new_with_defaults or somesuch... + # + if( modver_gt_or_eq ( 'Data::Dumper', '2.136' ) ) { + $d->Sparseseen(1); + + if( modver_gt_or_eq ( 'Data::Dumper', '2.153' ) ) { + $d->Maxrecurse(1000); + + if( modver_gt_or_eq ( 'Data::Dumper', '2.160' ) ) { + $d->Trailingcomma(1); + } + } + } $d; } @@ -723,11 +746,10 @@ sub modver_gt_or_eq ($$) { croak "Nonsensical minimum version supplied" if ! defined $ver or $ver !~ $ver_rx; - no strict 'refs'; - my $ver_cache = ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= ( $mod->VERSION - ? {} - : croak "$mod does not seem to provide a version (perhaps it never loaded)" - ); + my $ver_cache = do { + no strict 'refs'; + ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= {} + }; ! defined $ver_cache->{$ver} and @@ -736,6 +758,18 @@ sub modver_gt_or_eq ($$) { local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ ) if SPURIOUS_VERSION_CHECK_WARNINGS; + # prevent captures by potential __WARN__ hooks or the like: + # there is nothing of value that can be happening here, and + # leaving a hook in-place can only serve to fail some test + local $SIG{__WARN__} if ( + ! SPURIOUS_VERSION_CHECK_WARNINGS + and + $SIG{__WARN__} + ); + + croak "$mod does not seem to provide a version (perhaps it never loaded)" + unless $mod->VERSION; + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; eval { $mod->VERSION($ver) } ? 1 : 0; diff --git a/t/52leaks.t b/t/52leaks.t index ae96a2176..bd159a7ff 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -461,6 +461,15 @@ for my $addr (keys %$weak_registry) { delete $weak_registry->{$addr} unless $cleared->{bheos_pptiehinthashfieldhash}++; } + elsif ( + $names =~ /^Data::Dumper/m + and + $weak_registry->{$addr}{stacktrace} =~ /\bDBIx::Class::SQLMaker::Util::lax_serialize\b/ + ) { + # only clear one object of a specific behavior - more would indicate trouble + delete $weak_registry->{$addr} + unless $cleared->{dd_lax_serializer}++; + } elsif ($names =~ /^DateTime::TimeZone::UTC/m) { # DT is going through a refactor it seems - let it leak zones for now delete $weak_registry->{$addr}; diff --git a/t/search/stack_cond.t b/t/search/stack_cond.t index 497b69834..6989c6fdd 100644 --- a/t/search/stack_cond.t +++ b/t/search/stack_cond.t @@ -72,9 +72,7 @@ for my $c ( SELECT me.title FROM cd me WHERE - ( genreid != 42 OR genreid IS NULL ) - AND - ( genreid != 42 OR genreid IS NULL ) + ( genreid IS NULL OR genreid != 42 ) AND title != bar AND @@ -85,7 +83,7 @@ for my $c ( year $c->{sql} )", \@bind, - 'Double condition correctly collapsed for steps' . dump_value \@query_steps, + 'Double condition correctly collapsed for steps:' . join( '', map { "\n\t" . dump_value($_) } @query_steps ), ); } diff --git a/xt/extra/internals/sqla_condition_parsers.t b/xt/extra/internals/sqla_condition_parsers.t index 14a2c31a7..98a76b088 100644 --- a/xt/extra/internals/sqla_condition_parsers.t +++ b/xt/extra/internals/sqla_condition_parsers.t @@ -34,6 +34,9 @@ my $num = bless( \do { my $foo = 69 }, 'DBICTest::SillyInt' ); is($num, 69, 'test overloaded object is "sane"'); is("$num", 69, 'test overloaded object is "sane"'); +my $AttUQoLtUaE = 42; +my $PVIVmaker = $AttUQoLtUaE . ''; + my @tests = ( { where => { artistid => 1, charfield => undef }, @@ -89,9 +92,9 @@ my @tests = ( }, { where => { -and => [ \'foo=bar', [ { artistid => { '=', $num } } ], { name => 'Caterwauler McCrae'}, \'buzz=bozz' ] }, - normalized => { -and => [ \'foo=bar', \'buzz=bozz' ], name => 'Caterwauler McCrae', artistid => $num }, + normalized => { -and => [ \'buzz=bozz', \'foo=bar' ], name => 'Caterwauler McCrae', artistid => $num }, sql => 'WHERE foo=bar AND artistid = ? AND name = ? AND buzz=bozz', - normalized_sql => 'WHERE foo=bar AND buzz=bozz AND artistid = ? AND name = ?', + normalized_sql => 'WHERE buzz=bozz AND foo=bar AND artistid = ? AND name = ?', equality_extract => { name => 'Caterwauler McCrae', artistid => $num }, }, { @@ -110,9 +113,8 @@ my @tests = ( }, { where => { artistid => { '=' => [ 1 ], }, charfield => { '=' => [ -AND => \'1', \['?',2] ] }, rank => { '=' => [ -OR => $num, $num ] } }, - normalized => { artistid => 1, charfield => [-and => { '=' => \['?',2] }, { '=' => \'1' } ], rank => { '=' => [$num, $num] } }, + normalized => { artistid => 1, charfield => [-and => { '=' => \'1' }, { '=' => \['?',2] } ], rank => { '=' => [$num, $num] } }, sql => 'WHERE artistid = ? AND charfield = 1 AND charfield = ? AND ( rank = ? OR rank = ? )', - normalized_sql => 'WHERE artistid = ? AND charfield = ? AND charfield = 1 AND ( rank = ? OR rank = ? )', equality_extract => { artistid => 1, charfield => UNRESOLVABLE_CONDITION }, }, { @@ -135,10 +137,10 @@ my @tests = ( (map { { where => $_, sql => 'WHERE (rank = 13 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank != 42)', - normalized_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank = 13) AND (artistid = ? OR charfield IS NULL OR rank != 42)', + normalized_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank != 42) AND (artistid = ? OR charfield IS NULL OR rank = 13)', normalized => { -and => [ - { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, { -or => [ artistid => 1, charfield => undef, rank => { '!=' => \42 } ] }, + { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, ] }, equality_extract => {}, equality_considering_nulls_extract => {}, @@ -146,7 +148,7 @@ my @tests = ( { -and => [ -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ], - -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '!=' => \42 } }, + -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '!=' => \$AttUQoLtUaE } }, ] }, { @@ -182,18 +184,32 @@ my @tests = ( }, { where => { -and => [ - -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ], - -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '=' => \13 } }, - ] }, - normalized => { -and => [ - { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, - { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, + -or => [ rank => { '=' => \$AttUQoLtUaE }, charfield => { '=' => undef }, artistid => 1 ], + -or => { artistid => { '=' => 1 }, charfield => undef, rank => { '=' => \42 } }, ] }, - sql => 'WHERE (rank = 13 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank = 13)', - normalized_sql => 'WHERE (artistid = ? OR charfield IS NULL OR rank = 13) AND (artistid = ? OR charfield IS NULL OR rank = 13)', + normalized => { + -or => [ artistid => 1, charfield => undef, rank => { '=' => \42 } ], + }, + sql => 'WHERE (rank = 42 OR charfield IS NULL OR artistid = ?) AND (artistid = ? OR charfield IS NULL OR rank = 42)', + normalized_sql => 'WHERE artistid = ? OR charfield IS NULL OR rank = 42', equality_extract => {}, equality_considering_nulls_extract => {}, }, + { + where => { -and => [ + { -or => [ \42 ] }, + { -and => [ + { -or => [ \$AttUQoLtUaE ] }, + { -or => [ \13 ] }, + ] }, + ] }, + normalized => { + -and => [ \13, \42 ], + }, + sql => 'WHERE 42 AND 42 AND 13', + normalized_sql => 'WHERE 13 AND 42', + equality_extract => {}, + }, { where => { -and => [ -or => [ rank => { '=' => \13 }, charfield => { '=' => undef }, artistid => 1 ], @@ -218,12 +234,12 @@ my @tests = ( AND NOT foo = ? ', normalized_sql => 'WHERE - ( artistid = ? OR charfield IS NULL OR rank = 13 ) - AND ( artistid = ? OR charfield IS NULL OR rank != 42 ) - AND (EXISTS (SELECT 1)) + (EXISTS (SELECT 1)) AND (EXISTS (SELECT 2)) AND NOT foo = ? AND NOT foo = ? + AND ( artistid = ? OR charfield IS NULL OR rank != 42 ) + AND ( artistid = ? OR charfield IS NULL OR rank = 13 ) AND bar = 4 AND bar = ? AND foo = 1 @@ -231,12 +247,12 @@ my @tests = ( ', normalized => { -and => [ - { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, - { -or => [ artistid => 1, charfield => undef, rank => { '!=' => \42 } ] }, { -exists => \'(SELECT 1)' }, { -exists => \'(SELECT 2)' }, - { -not => { foo => 69 } }, { -not => { foo => 42 } }, + { -not => { foo => 69 } }, + { -or => [ artistid => 1, charfield => undef, rank => { '!=' => \42 } ] }, + { -or => [ artistid => 1, charfield => undef, rank => { '=' => \13 } ] }, ], foo => [ -and => { '=' => \1 }, 3 ], bar => [ -and => { '=' => \4 }, 2 ], @@ -418,13 +434,14 @@ my @tests = ( \'baz = ber', ], }, - sql => 'WHERE foo = bar AND baz = ber', normalized => { -and => [ - \'foo = bar', \'baz = ber', + \'foo = bar', ], }, + sql => 'WHERE foo = bar AND baz = ber', + normalized_sql => 'WHERE baz = ber AND foo = bar', equality_extract => {}, }, { @@ -435,14 +452,15 @@ my @tests = ( x => { -ident => 'y' }, ], }, - sql => 'WHERE foo = bar AND baz = ber AND x = y', normalized => { -and => [ - \'foo = bar', \'baz = ber', + \'foo = bar', ], x => { '=' => { -ident => 'y' } } }, + sql => 'WHERE foo = bar AND baz = ber AND x = y', + normalized_sql => 'WHERE baz = ber AND foo = bar AND x = y', equality_extract => { x => { -ident => 'y' } }, }, ); From c9087040faf8de638936b163c20f702a2878d7ab Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 2 Jan 2015 15:10:13 +0100 Subject: [PATCH 219/262] Only normalize conditions during resolution time, instead on every ->search The normalization operation isn't cheap. Should result in no changes. --- lib/DBIx/Class/ResultSet.pm | 23 ++++++++++++----------- xt/extra/lean_startup.t | 1 + 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 97cfe5073..1b35cf391 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -654,17 +654,15 @@ sub _stack_cond { (ref $_ eq 'HASH' and ! keys %$_) ) and $_ = undef for ($left, $right); - # either one of the two undef - if ( (defined $left) xor (defined $right) ) { - return defined $left ? $left : $right; - } - # both undef - elsif ( ! defined $left ) { - return undef - } - else { - return normalize_sqla_condition({ -and => [$left, $right] }); - } + return( + # either one of the two undef + ( (defined $left) xor (defined $right) ) ? ( defined $left ? $left : $right ) + + # both undef + : ( ! defined $left ) ? undef + + : { -and => [$left, $right] } + ); } =head2 search_literal @@ -3529,6 +3527,9 @@ sub _resolved_attrs { if ( $attrs->{rows} =~ /[^0-9]/ or $attrs->{rows} <= 0 ); } + # normalize where condition + $attrs->{where} = normalize_sqla_condition( $attrs->{where} ) + if $attrs->{where}; # default selection list $attrs->{columns} = [ $source->columns ] diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index 2731f0c7c..f915819de 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -184,6 +184,7 @@ BEGIN { register_lazy_loadable_requires(qw( DBI Hash::Merge + Data::Dumper )); { From 4a27d168d64e0c2c61ddbfa367c360ed5028a3d3 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 9 Aug 2016 14:55:06 +0200 Subject: [PATCH 220/262] Remove bizarre $_[$#_] idiom from the codebase Zero functional changes --- lib/DBIx/Class/CDBICompat/Relationships.pm | 2 +- lib/DBIx/Class/ResultSet.pm | 14 +++++++------- lib/DBIx/Class/ResultSource.pm | 2 +- lib/DBIx/Class/Row.pm | 2 +- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm index ecbc5c2d9..f3c0c9c7a 100644 --- a/lib/DBIx/Class/CDBICompat/Relationships.pm +++ b/lib/DBIx/Class/CDBICompat/Relationships.pm @@ -199,7 +199,7 @@ sub meta_info { sub search { my $self = shift; my $attrs = {}; - if (@_ > 1 && ref $_[$#_] eq 'HASH') { + if (@_ > 1 && ref $_[-1] eq 'HASH') { $attrs = { %{ pop(@_) } }; } my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift) diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 1b35cf391..7ab7a7299 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -775,7 +775,7 @@ See also L and L. sub find { my $self = shift; - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); my $rsrc = $self->result_source; @@ -819,7 +819,7 @@ sub find { my $relinfo = $rsrc->relationship_info($key) and # implicitly skip has_many's (likely MC) - (ref (my $val = delete $call_cond->{$key}) ne 'ARRAY' ) + ( ref( my $val = delete $call_cond->{$key} ) ne 'ARRAY' ) ) { my ($rel_cond, $crosstable) = $rsrc->_resolve_condition( $relinfo->{cond}, $val, $key, $key @@ -1162,7 +1162,7 @@ sub search_like { .' Instead use ->search({ x => { -like => "y%" } })' .' (note the outer pair of {}s - they are important!)' ); - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); my $query = ref $_[0] eq 'HASH' ? { %{shift()} }: {@_}; $query->{$_} = { 'like' => $query->{$_} } for keys %$query; return $class->search($query, { %$attrs }); @@ -2777,7 +2777,7 @@ all in the call to C, even when set to C. sub find_or_new { my $self = shift; - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); my $hash = ref $_[0] eq 'HASH' ? shift : {@_}; if (keys %$hash and my $row = $self->find($hash, $attrs) ) { return $row; @@ -2946,7 +2946,7 @@ database! sub find_or_create { my $self = shift; - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); my $hash = ref $_[0] eq 'HASH' ? shift : {@_}; if (keys %$hash and my $row = $self->find($hash, $attrs) ) { return $row; @@ -3012,7 +3012,7 @@ database! sub update_or_create { my $self = shift; - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); my $cond = ref $_[0] eq 'HASH' ? shift : {@_}; my $row = $self->find($cond, $attrs); @@ -3075,7 +3075,7 @@ See also L, L and L. sub update_or_new { my $self = shift; - my $attrs = ( @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {} ); + my $attrs = ( @_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {} ); my $cond = ref $_[0] eq 'HASH' ? shift : {@_}; my $row = $self->find( $cond, $attrs ); diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index c598b1db2..e5af674b4 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -4,7 +4,7 @@ package DBIx::Class::ResultSource; # # Some of the methods defined here will be around()-ed by code at the # end of ::ResultSourceProxy. The reason for this strange arrangement -# is that the list of around()s of methods in this # class depends +# is that the list of around()s of methods in this class depends # directly on the list of may-not-be-defined-yet methods within # ::ResultSourceProxy itself. # If this sounds terrible - it is. But got to work with what we have. diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 7ccebb41e..87f3716c1 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -625,7 +625,7 @@ sub delete { $self->in_storage(0); } else { - my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {}; + my $attrs = @_ > 1 && ref $_[-1] eq 'HASH' ? { %{pop(@_)} } : {}; my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_}; $self->result_source->resultset->search_rs(@_)->delete; } From 4baa3b95cf1a0c69079babf37371f346edd08855 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 22 Aug 2016 12:27:22 +0200 Subject: [PATCH 221/262] Remove hostile test added by stupid-me 7 years ago in 3bb4eb8f --- t/60core.t | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/t/60core.t b/t/60core.t index 0420a9fc5..2f30ad74b 100644 --- a/t/60core.t +++ b/t/60core.t @@ -539,17 +539,6 @@ lives_ok (sub { my $newlink = $newbook->link}, "stringify to false value doesn't isa_ok( $new_artist, 'DBIx::Class::Row', '$rs->new gives a row object' ); } - -# make sure we got rid of the compat shims -SKIP: { - my $remove_version = 0.083; - skip "Remove in $remove_version", 3 if $DBIx::Class::VERSION < $remove_version; - - for (qw/compare_relationship_keys pk_depends_on resolve_condition/) { - ok (! DBIx::Class::ResultSource->can ($_), "$_ no longer provided by DBIx::Class::ResultSource, removed before $remove_version"); - } -} - #------------------------------ # READ THIS BEFORE "FIXING" #------------------------------ From b78ed1e42494c2d9afc81d24cc9b67563fe135e0 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 22 Aug 2016 13:19:41 +0200 Subject: [PATCH 222/262] Centralize loading of DBIx::Class::Exception No functional, nor even load-order changes --- lib/DBIx/Class.pm | 1 - lib/DBIx/Class/Schema/SanityChecker.pm | 1 - lib/DBIx/Class/Storage.pm | 8 ++++---- lib/DBIx/Class/Storage/BlockRunner.pm | 1 - lib/DBIx/Class/_Util.pm | 6 +++++- lib/SQL/Translator/Parser/DBIx/Class.pm | 1 - xt/dist/loadable_standalone_testschema_resultclasses.t | 2 +- 7 files changed, 10 insertions(+), 10 deletions(-) diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index bdcc96031..cdcbcbbef 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -21,7 +21,6 @@ $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev relea use mro 'c3'; use base qw/DBIx::Class::Componentised DBIx::Class::AccessorGroup/; -use DBIx::Class::Exception; __PACKAGE__->mk_classaccessor( _skip_namespace_frames => join( '|', map { '^' . $_ } qw( diff --git a/lib/DBIx/Class/Schema/SanityChecker.pm b/lib/DBIx/Class/Schema/SanityChecker.pm index b048edd9d..61936d9ac 100644 --- a/lib/DBIx/Class/Schema/SanityChecker.pm +++ b/lib/DBIx/Class/Schema/SanityChecker.pm @@ -8,7 +8,6 @@ use DBIx::Class::_Util qw( describe_class_methods emit_loud_diag ); use DBIx::Class (); -use DBIx::Class::Exception (); use Scalar::Util qw( blessed refaddr ); use namespace::clean; diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm index c8f0180ef..acae96a56 100644 --- a/lib/DBIx/Class/Storage.pm +++ b/lib/DBIx/Class/Storage.pm @@ -6,10 +6,10 @@ use warnings; use base qw/DBIx::Class/; use mro 'c3'; -{ - package # Hide from PAUSE - DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION; - use base 'DBIx::Class::Exception'; +BEGIN { + no warnings 'once'; + @DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION::ISA + = 'DBIx::Class::Exception'; } use DBIx::Class::Carp; diff --git a/lib/DBIx/Class/Storage/BlockRunner.pm b/lib/DBIx/Class/Storage/BlockRunner.pm index 9d191c873..63f5be381 100644 --- a/lib/DBIx/Class/Storage/BlockRunner.pm +++ b/lib/DBIx/Class/Storage/BlockRunner.pm @@ -4,7 +4,6 @@ package # hide from pause until we figure it all out use warnings; use strict; -use DBIx::Class::Exception; use DBIx::Class::Carp; use Context::Preserve 'preserve_context'; use DBIx::Class::_Util qw( is_exception qsub dbic_internal_try ); diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 7d4a4075c..7d268504c 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -1,7 +1,8 @@ package # hide from PAUSE DBIx::Class::_Util; -use DBIx::Class::StartupCheck; # load es early as we can, usually a noop +# load es early as we can, usually a noop +use DBIx::Class::StartupCheck; use warnings; use strict; @@ -173,6 +174,9 @@ use constant SPURIOUS_VERSION_CHECK_WARNINGS => ( DBIx::Class::_ENV_::PERL_VERSI # Carp::Skip to the rescue soon use DBIx::Class::Carp '^DBIx::Class|^DBICTest'; +# Ensure it is always there, in case we need to do a $schema-less throw() +use DBIx::Class::Exception (); + use B (); use Carp 'croak'; use Storable 'nfreeze'; diff --git a/lib/SQL/Translator/Parser/DBIx/Class.pm b/lib/SQL/Translator/Parser/DBIx/Class.pm index 4ca3f933a..ff636943d 100644 --- a/lib/SQL/Translator/Parser/DBIx/Class.pm +++ b/lib/SQL/Translator/Parser/DBIx/Class.pm @@ -16,7 +16,6 @@ use Exporter; use SQL::Translator::Utils qw(debug normalize_name); use DBIx::Class::Carp qw/^SQL::Translator|^DBIx::Class|^Try::Tiny/; use DBIx::Class::_Util 'dbic_internal_try'; -use DBIx::Class::Exception; use Class::C3::Componentised; use Scalar::Util 'blessed'; use Try::Tiny; diff --git a/xt/dist/loadable_standalone_testschema_resultclasses.t b/xt/dist/loadable_standalone_testschema_resultclasses.t index 95dd24f4f..5a9c6f62b 100644 --- a/xt/dist/loadable_standalone_testschema_resultclasses.t +++ b/xt/dist/loadable_standalone_testschema_resultclasses.t @@ -15,7 +15,7 @@ use File::Find; my $worker = sub { my $fn = shift; - if (my @offenders = grep { $_ !~ m{DBIx/Class/(?:_Util|Carp|StartupCheck)\.pm} } grep { $_ =~ /(^|\/)DBI/ } keys %INC) { + if (my @offenders = grep { $_ !~ m{DBIx/Class/(?:_Util|Carp|Exception|StartupCheck)\.pm} } grep { $_ =~ /(^|\/)DBI/ } keys %INC) { die "Wtf - DBI* modules present in %INC: @offenders"; } From adcc1df0049e0093cb94c867bd2be8c9fe242a61 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 13 Sep 2016 17:15:48 +0200 Subject: [PATCH 223/262] Fix for upcoming (not yet available via DBD::SQLite) libsqlite version --- Changes | 2 ++ t/prefetch/grouped.t | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/Changes b/Changes index 72d7647b8..e402e5a7e 100644 --- a/Changes +++ b/Changes @@ -73,6 +73,8 @@ Revision history for DBIx::Class working with copy() in t/icdt/engine_specific/sybase.t (GH#84) - Fix t/54taint.t failing on local::lib's with upgraded Carp on 5.8.* - Fix invalid variable names in ResultSource::View examples + - Fix missing ORDER BY leading to failures of t/prefetch/grouped.t + under upcoming libsqlite (RT#117271) - Skip tests in a way more intelligent and speedy manner when optional dependencies are missing - Make the Optional::Dependencies error messages cpanm-friendly diff --git a/t/prefetch/grouped.t b/t/prefetch/grouped.t index 4aad6b197..c0d2224e9 100644 --- a/t/prefetch/grouped.t +++ b/t/prefetch/grouped.t @@ -101,7 +101,7 @@ my @cdids = sort $cd_rs->get_column ('cdid')->all; # add an extra track to one of the cds, and then make sure we can get it on top # (check if limit works) - my $top_cd = $cd_rs->slice (1,1)->next; + my $top_cd = $cd_rs->search({}, { order_by => 'cdid' })->slice (1,1)->next; $top_cd->create_related ('tracks', { title => 'over the top', }); From 3aa25d8b47104964c689be4ca8c1fc5b17781a7f Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 12 Sep 2016 14:12:35 +0200 Subject: [PATCH 224/262] Fixup several tests silently broken by 12e7015a A number of tests that we do not run during CI (lack of RDBMS) have run-time tests concerning backcompat along the lines of: $schema->class('Artist')->load_components('PK::Auto...') The above causes the class' mro to be switched after $schema instantiation and subsequently triggers the sanitychecker. Instead of ripping these lines out (without a way to test them) - simply augment the ::Artist based set of classes to preempt the check failures in the first place. --- lib/DBIx/Class/Schema/SanityChecker.pm | 3 ++- t/lib/DBICTest/Base.pm | 2 ++ t/lib/DBICTest/Schema/Artist.pm | 2 ++ t/lib/DBICTest/Schema/ArtistSourceName.pm | 2 ++ t/lib/DBICTest/Schema/ArtistSubclass.pm | 1 + t/lib/DBICTest/Schema/CustomSql.pm | 1 + 6 files changed, 10 insertions(+), 1 deletion(-) diff --git a/lib/DBIx/Class/Schema/SanityChecker.pm b/lib/DBIx/Class/Schema/SanityChecker.pm index 61936d9ac..4cc7958f6 100644 --- a/lib/DBIx/Class/Schema/SanityChecker.pm +++ b/lib/DBIx/Class/Schema/SanityChecker.pm @@ -505,7 +505,8 @@ sub check_valid_c3_composition { push @err, { class => $class, - isa => $desc->{isa}, + initial_linear_isa => $desc->{linear_isa}, + current_linear_isa => do { (undef, my @isa) = @{ mro::get_linear_isa($class) }; \@isa }, initial_mro => $desc->{mro}{type}, current_mro => mro::get_mro($class), affected_methods => $affected_methods, diff --git a/t/lib/DBICTest/Base.pm b/t/lib/DBICTest/Base.pm index 9024f8e0e..861020886 100644 --- a/t/lib/DBICTest/Base.pm +++ b/t/lib/DBICTest/Base.pm @@ -6,6 +6,8 @@ use warnings; use DBICTest::Util; +# FIXME - Carp::Skip should somehow allow for augmentation based on +# mro::get_linear_isa or somesuch... sub _skip_namespace_frames { '^DBICTest' } 1; diff --git a/t/lib/DBICTest/Schema/Artist.pm b/t/lib/DBICTest/Schema/Artist.pm index 00c1ef670..808e05a2c 100644 --- a/t/lib/DBICTest/Schema/Artist.pm +++ b/t/lib/DBICTest/Schema/Artist.pm @@ -5,6 +5,8 @@ use warnings; use strict; use base 'DBICTest::BaseResult'; +use mro 'c3'; + use DBICTest::Util 'check_customcond_args'; __PACKAGE__->table('artist'); diff --git a/t/lib/DBICTest/Schema/ArtistSourceName.pm b/t/lib/DBICTest/Schema/ArtistSourceName.pm index 3e6a7e657..cf1b5de6d 100644 --- a/t/lib/DBICTest/Schema/ArtistSourceName.pm +++ b/t/lib/DBICTest/Schema/ArtistSourceName.pm @@ -5,6 +5,8 @@ use warnings; use strict; use base 'DBICTest::Schema::Artist'; +use mro 'c3'; + __PACKAGE__->table(__PACKAGE__->table); __PACKAGE__->source_name('SourceNameArtists'); diff --git a/t/lib/DBICTest/Schema/ArtistSubclass.pm b/t/lib/DBICTest/Schema/ArtistSubclass.pm index e1b97fa40..31062b5e9 100644 --- a/t/lib/DBICTest/Schema/ArtistSubclass.pm +++ b/t/lib/DBICTest/Schema/ArtistSubclass.pm @@ -5,6 +5,7 @@ use warnings; use strict; use base 'DBICTest::Schema::Artist'; +use mro 'c3'; __PACKAGE__->table(__PACKAGE__->table); diff --git a/t/lib/DBICTest/Schema/CustomSql.pm b/t/lib/DBICTest/Schema/CustomSql.pm index d22b3febf..d179464a4 100644 --- a/t/lib/DBICTest/Schema/CustomSql.pm +++ b/t/lib/DBICTest/Schema/CustomSql.pm @@ -5,6 +5,7 @@ use warnings; use strict; use base qw/DBICTest::Schema::Artist/; +use mro 'c3'; __PACKAGE__->table('dummy'); From 7305f6f933813eaa1a4a7b65bfc5f158d0d65c4d Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 13 Sep 2016 06:41:16 +0200 Subject: [PATCH 225/262] Fix silent failures on autoinc PK without an is_auto_increment attribute Back in fabbd5cc the refactor of the subsystem left out this corner case, resulting in drivers without a functioning last_insert_id() to either fail to retrieve the autoinc value, or in case of the suboptimal ->_identity()-based implementations ( MSSQL / Sybase ) to *reuse* the last successfully retrieved value (sigh) Since the entire codepath is a hot mess, not changing much aside from an extra pass to enable implicit inferrence of an is_auto_increment setting. Several different codepaths in the test suite were used to ensure everything meshes correctly with retrieve_on_insert and similar --- Changes | 3 + lib/DBIx/Class/Storage/DBI.pm | 59 +++++++++++++++++++- t/46where_attribute.t | 10 +++- t/72pg.t | 3 + t/746mssql.t | 33 ++++++++++- t/cdbi/copy.t | 5 ++ t/cdbi/testlib/Actor.pm | 5 ++ t/cdbi/testlib/ActorAlias.pm | 5 ++ t/cdbi/testlib/ColumnObject.pm | 5 ++ t/cdbi/testlib/Film.pm | 5 ++ t/cdbi/testlib/ImplicitInflate.pm | 6 ++ t/cdbi/testlib/Log.pm | 5 ++ t/cdbi/testlib/MyFoo.pm | 6 ++ t/lib/DBICTest/Schema/BooksInLibrary.pm | 5 +- t/lib/DBICTest/Schema/TimestampPrimaryKey.pm | 1 + t/row/inflate_result.t | 5 +- 16 files changed, 150 insertions(+), 11 deletions(-) diff --git a/Changes b/Changes index e402e5a7e..e40b03e35 100644 --- a/Changes +++ b/Changes @@ -54,6 +54,9 @@ Revision history for DBIx::Class result source metadata (RT#107462) - Fix incorrect SQL generated with invalid {rows} on complex resultset operations, generally more robust handling of rows/offset attrs + - Fix silent failure to retrieve a primary key (RT#80283) or worse: + returning an incorrect value (RT#115381) in case a rdbms-side autoinc + column is declared as PK with the is_auto_increment attribute unset - Fix incorrect $storage state on unexpected RDBMS disconnects and other failure events, preventing clean reconnection (RT#110429) - Make sure exception objects stringifying to '' are properly handled diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 9da3bd9ba..1a9d792f0 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -2001,19 +2001,43 @@ sub insert { # they can be fused once again with the final return $to_insert = { %$to_insert, %$prefetched_values }; - # FIXME - we seem to assume undef values as non-supplied. This is wrong. - # Investigate what does it take to s/defined/exists/ my %pcols = map { $_ => 1 } $source->primary_columns; + my (%retrieve_cols, $autoinc_supplied, $retrieve_autoinc_col); + for my $col ($source->columns) { + + # first autoinc wins - this is why ->columns() in-order iteration is important + # + # FIXME - there ought to be a sanity-check for multiple is_auto_increment settings + # or something... + # if ($col_infos->{$col}{is_auto_increment}) { + + # FIXME - we seem to assume undef values as non-supplied. + # This is wrong. + # Investigate what does it take to s/defined/exists/ + # ( fails t/cdbi/copy.t amoong other things ) $autoinc_supplied ||= 1 if defined $to_insert->{$col}; + $retrieve_autoinc_col ||= $col unless $autoinc_supplied; } # nothing to retrieve when explicit values are supplied next if ( - defined $to_insert->{$col} and ! is_literal_value($to_insert->{$col}) + # FIXME - we seem to assume undef values as non-supplied. + # This is wrong. + # Investigate what does it take to s/defined/exists/ + # ( fails t/cdbi/copy.t amoong other things ) + defined $to_insert->{$col} + and + ( + # not a ref - cheaper to check before a call to is_literal_value() + ! length ref $to_insert->{$col} + or + # not a literal we *MAY* need to pull out ( see check below ) + ! is_literal_value( $to_insert->{$col} ) + ) ); # the 'scalar keys' is a trick to preserve the ->columns declaration order @@ -2024,6 +2048,35 @@ sub insert { ); }; + # corner case of a non-supplied PK which is *not* declared as autoinc + if ( + ! $autoinc_supplied + and + ! defined $retrieve_autoinc_col + and + # FIXME - first come-first serve, suboptimal... + ($retrieve_autoinc_col) = ( grep + { + $pcols{$_} + and + ! $col_infos->{$_}{retrieve_on_insert} + and + ! defined $col_infos->{$_}{is_auto_increment} + } + sort + { $retrieve_cols{$a} <=> $retrieve_cols{$b} } + keys %retrieve_cols + ) + ) { + carp_unique( + "Missing value for primary key column '$retrieve_autoinc_col' on " + . "@{[ $source->source_name ]} - perhaps you forgot to set its " + . "'is_auto_increment' attribute during add_columns()? Treating " + . "'$retrieve_autoinc_col' implicitly as an autoinc, and attempting " + . 'value retrieval' + ); + } + local $self->{_autoinc_supplied_for_op} = $autoinc_supplied; local $self->{_perform_autoinc_retrieval} = $retrieve_autoinc_col; diff --git a/t/46where_attribute.t b/t/46where_attribute.t index ba1c7d09e..0fedbe7b3 100644 --- a/t/46where_attribute.t +++ b/t/46where_attribute.t @@ -4,6 +4,7 @@ use strict; use warnings; use Test::More; +use Test::Warn; use DBICTest; my $schema = DBICTest->init_schema(); @@ -22,9 +23,12 @@ is($programming_perl->id, 1, 'select from a resultset with find_or_create for ex # and inserts? my $see_spot; -$see_spot = eval { $owner->books->find_or_create({ title => "See Spot Run" }) }; -if ($@) { print $@ } -ok(!$@, 'find_or_create on resultset with attribute for non-existent entry did not throw'); +$see_spot = eval { + warnings_exist { + $owner->books->find_or_create({ title => "See Spot Run" }) + } qr/Missing value for primary key column 'id' on BooksInLibrary - perhaps you forgot to set its 'is_auto_increment'/; +}; +is ($@, '', 'find_or_create on resultset with attribute for non-existent entry did not throw'); ok(defined $see_spot, 'successfully did insert on resultset with attribute for non-existent entry'); my $see_spot_rs = $owner->books->search({ title => "See Spot Run" }); diff --git a/t/72pg.t b/t/72pg.t index 9d379302e..1f0cc0700 100644 --- a/t/72pg.t +++ b/t/72pg.t @@ -196,6 +196,9 @@ for my $use_insert_returning ($test_server_supports_insert_returning __PACKAGE__->column_info_from_storage(1); __PACKAGE__->set_primary_key('id'); + # FIXME - for some reason column_info_from_storage does not properly find + # the is_auto_increment setting... + __PACKAGE__->column_info('id')->{is_auto_increment} = 1; } SKIP: { skip "Need DBD::Pg 2.9.2 or newer for array tests", 4 if $DBD::Pg::VERSION < 2.009002; diff --git a/t/746mssql.t b/t/746mssql.t index d1b8773f0..5fc3d3000 100644 --- a/t/746mssql.t +++ b/t/746mssql.t @@ -9,7 +9,6 @@ use Test::Exception; use Test::Warn; use Try::Tiny; - use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/}; @@ -519,6 +518,38 @@ SQL 'updated money value to NULL round-trip'; } } + +# Test leakage of PK on implicit retrieval + { + + my $next_owner = $schema->resultset('Owners')->get_column('id')->max + 1; + my $next_book = $schema->resultset('BooksInLibrary')->get_column('id')->max + 1; + + cmp_ok( + $next_owner, + '!=', + $next_book, + 'Preexisting auto-inc PKs staggered' + ); + + my $yet_another_owner = $schema->resultset('Owners')->create({ name => 'YAO' }); + my $yet_another_book; + warnings_exist { + $yet_another_book = $yet_another_owner->create_related( books => { title => 'YAB' }) + } qr/Missing value for primary key column 'id' on BooksInLibrary - perhaps you forgot to set its 'is_auto_increment'/; + + is( + $yet_another_owner->id, + $next_owner, + 'Expected Owner id' + ); + + is( + $yet_another_book->id, + $next_book, + 'Expected Book id' + ); + } } } diff --git a/t/cdbi/copy.t b/t/cdbi/copy.t index 2741aadaf..b1227816b 100644 --- a/t/cdbi/copy.t +++ b/t/cdbi/copy.t @@ -18,6 +18,11 @@ use lib 't/cdbi/testlib'; __PACKAGE__->set_table('Movies'); __PACKAGE__->columns(All => qw(id title)); + # Disables the implicit autoinc-on-non-supplied-pk behavior + # (and the warning that goes with it) + # This is the same behavior as it was pre 0.082900 + __PACKAGE__->column_info('id')->{is_auto_increment} = 0; + sub create_sql { return qq{ id INTEGER PRIMARY KEY AUTOINCREMENT, diff --git a/t/cdbi/testlib/Actor.pm b/t/cdbi/testlib/Actor.pm index 83a03b9fe..3bffd09d3 100644 --- a/t/cdbi/testlib/Actor.pm +++ b/t/cdbi/testlib/Actor.pm @@ -13,6 +13,11 @@ __PACKAGE__->columns(All => qw/ Name Film Salary /); __PACKAGE__->columns(TEMP => qw/ nonpersistent /); __PACKAGE__->add_constructor(salary_between => 'salary >= ? AND salary <= ?'); +# Disables the implicit autoinc-on-non-supplied-pk behavior +# (and the warning that goes with it) +# This is the same behavior as it was pre 0.082900 +__PACKAGE__->column_info('id')->{is_auto_increment} = 0; + sub mutator_name_for { "set_$_[1]" } sub create_sql { diff --git a/t/cdbi/testlib/ActorAlias.pm b/t/cdbi/testlib/ActorAlias.pm index 862a410b4..5fb9456d1 100644 --- a/t/cdbi/testlib/ActorAlias.pm +++ b/t/cdbi/testlib/ActorAlias.pm @@ -13,6 +13,11 @@ __PACKAGE__->columns( All => qw/ actor alias / ); __PACKAGE__->has_a( actor => 'Actor' ); __PACKAGE__->has_a( alias => 'Actor' ); +# Disables the implicit autoinc-on-non-supplied-pk behavior +# (and the warning that goes with it) +# This is the same behavior as it was pre 0.082900 +__PACKAGE__->column_info('id')->{is_auto_increment} = 0; + sub create_sql { return qq{ id INTEGER PRIMARY KEY, diff --git a/t/cdbi/testlib/ColumnObject.pm b/t/cdbi/testlib/ColumnObject.pm index 11eeb893e..0811367e0 100644 --- a/t/cdbi/testlib/ColumnObject.pm +++ b/t/cdbi/testlib/ColumnObject.pm @@ -18,6 +18,11 @@ __PACKAGE__->columns( All => ( Class::DBI::Column->new('columnb' => {mutator => 'columnb_as_write'}), )); +# Disables the implicit autoinc-on-non-supplied-pk behavior +# (and the warning that goes with it) +# This is the same behavior as it was pre 0.082900 +__PACKAGE__->column_info('id')->{is_auto_increment} = 0; + sub create_sql { return qq{ id INTEGER PRIMARY KEY, diff --git a/t/cdbi/testlib/Film.pm b/t/cdbi/testlib/Film.pm index 3bbd755e0..5c43f5a2a 100644 --- a/t/cdbi/testlib/Film.pm +++ b/t/cdbi/testlib/Film.pm @@ -12,6 +12,11 @@ __PACKAGE__->columns('Essential', qw( Title )); __PACKAGE__->columns('Directors', qw( Director CoDirector )); __PACKAGE__->columns('Other', qw( Rating NumExplodingSheep HasVomit )); +# Disables the implicit autoinc-on-non-supplied-pk behavior +# (and the warning that goes with it) +# This is the same behavior as it was pre 0.082900 +__PACKAGE__->column_info('title')->{is_auto_increment} = 0; + sub create_sql { return qq{ title VARCHAR(255), diff --git a/t/cdbi/testlib/ImplicitInflate.pm b/t/cdbi/testlib/ImplicitInflate.pm index 610e83550..14b2bf854 100644 --- a/t/cdbi/testlib/ImplicitInflate.pm +++ b/t/cdbi/testlib/ImplicitInflate.pm @@ -19,6 +19,12 @@ __PACKAGE__->has_a( update_datetime => 'MyDateStamp', ); + +# Disables the implicit autoinc-on-non-supplied-pk behavior +# (and the warning that goes with it) +# This is the same behavior as it was pre 0.082900 +__PACKAGE__->column_info('id')->{is_auto_increment} = 0; + sub create_sql { # SQLite doesn't support Datetime datatypes. return qq{ diff --git a/t/cdbi/testlib/Log.pm b/t/cdbi/testlib/Log.pm index 362b61e6d..c17b9bbde 100644 --- a/t/cdbi/testlib/Log.pm +++ b/t/cdbi/testlib/Log.pm @@ -17,6 +17,11 @@ __PACKAGE__->has_a( deflate => 'mysql_datetime' ); +# Disables the implicit autoinc-on-non-supplied-pk behavior +# (and the warning that goes with it) +# This is the same behavior as it was pre 0.082900 +__PACKAGE__->column_info('id')->{is_auto_increment} = 0; + __PACKAGE__->add_trigger(before_create => \&set_dts); __PACKAGE__->add_trigger(before_update => \&set_dts); diff --git a/t/cdbi/testlib/MyFoo.pm b/t/cdbi/testlib/MyFoo.pm index 7df9c6f6d..fa45d7dab 100644 --- a/t/cdbi/testlib/MyFoo.pm +++ b/t/cdbi/testlib/MyFoo.pm @@ -13,6 +13,12 @@ __PACKAGE__->has_a( inflate => sub { Date::Simple->new(shift) }, deflate => 'format', ); + +# Disables the implicit autoinc-on-non-supplied-pk behavior +# (and the warning that goes with it) +# This is the same behavior as it was pre 0.082900 +__PACKAGE__->column_info('myid')->{is_auto_increment} = 0; + #__PACKAGE__->find_column('tdate')->placeholder("IF(1, CURDATE(), ?)"); sub create_sql { diff --git a/t/lib/DBICTest/Schema/BooksInLibrary.pm b/t/lib/DBICTest/Schema/BooksInLibrary.pm index cd6f37531..c69ea5ddf 100644 --- a/t/lib/DBICTest/Schema/BooksInLibrary.pm +++ b/t/lib/DBICTest/Schema/BooksInLibrary.pm @@ -9,8 +9,11 @@ use base qw/DBICTest::BaseResult/; __PACKAGE__->table('books'); __PACKAGE__->add_columns( 'id' => { + # part of a test (auto-retrieval of PK regardless of autoinc status) + # DO NOT define + #is_auto_increment => 1, + data_type => 'integer', - is_auto_increment => 1, }, 'source' => { data_type => 'varchar', diff --git a/t/lib/DBICTest/Schema/TimestampPrimaryKey.pm b/t/lib/DBICTest/Schema/TimestampPrimaryKey.pm index 8ec4cf981..a52f0db07 100644 --- a/t/lib/DBICTest/Schema/TimestampPrimaryKey.pm +++ b/t/lib/DBICTest/Schema/TimestampPrimaryKey.pm @@ -12,6 +12,7 @@ __PACKAGE__->add_columns( 'id' => { data_type => 'timestamp', default_value => \'current_timestamp', + retrieve_on_insert => 1, }, ); diff --git a/t/row/inflate_result.t b/t/row/inflate_result.t index 9fa49ac18..b6503025a 100644 --- a/t/row/inflate_result.t +++ b/t/row/inflate_result.t @@ -20,9 +20,8 @@ my $admin_class = __PACKAGE__ . '::Admin'; __PACKAGE__->table('users'); __PACKAGE__->add_columns( - qw/user_id email password - firstname lastname active - admin/ + user_id => { retrieve_on_insert => 1 }, + qw( email password firstname lastname active admin ), ); __PACKAGE__->set_primary_key('user_id'); From 82c5f9168e30bc9dc7b681058298bb342582c5ec Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 13 Sep 2016 07:03:52 +0200 Subject: [PATCH 226/262] Remove non-functional part of ::Storage::DBI::Sybase::_ping This code has existed in one form or another since about 322b7a6b, and failed multiple levels of review and later was left as-is due to a lack of a testing rig :/ It seems that the simple change is sufficient, but more testing with more obscure Sybase driver combinations is certainly needed --- Changes | 1 + lib/DBIx/Class/Storage/DBI/Sybase.pm | 25 ++++--------------------- 2 files changed, 5 insertions(+), 21 deletions(-) diff --git a/Changes b/Changes index e40b03e35..8ca5192c3 100644 --- a/Changes +++ b/Changes @@ -67,6 +67,7 @@ Revision history for DBIx::Class - Fix corner case of stringify-only overloaded objects being used in create()/populate() - Fix spurious warning on MSSQL cursor invalidation retries (RT#102166) + - Fix incorrect ::Storage->_ping() behavior under Sybase (RT#114214) - Fix several corner cases with Many2Many over custom relationships - Fix corner cases of C3 composition being broken on OLD_MRO (5.8.x) only: https://github.com/frioux/DBIx-Class-Helpers/issues/61 diff --git a/lib/DBIx/Class/Storage/DBI/Sybase.pm b/lib/DBIx/Class/Storage/DBI/Sybase.pm index 9072b3869..9f2b84a6c 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase.pm @@ -76,27 +76,10 @@ sub _ping { local $dbh->{RaiseError} = 1; local $dbh->{PrintError} = 0; -# FIXME if the main connection goes stale, does opening another for this statement -# really determine anything? -# FIXME (2) THIS MAKES 0 SENSE!!! Need to test later - if ($dbh->{syb_no_child_con}) { - return dbic_internal_try { - $self->_connect->do('select 1'); - 1; - } - catch { - 0; - }; - } - - return ( - (dbic_internal_try { - $dbh->do('select 1'); - 1; - }) - ? 1 - : 0 - ); + ( dbic_internal_try { $dbh->do('select 1'); 1 } ) + ? 1 + : 0 + ; } sub _set_max_connect { From e2741c7fd695dca054614f297b01d351a45bbf38 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 5 Sep 2016 14:27:24 +0200 Subject: [PATCH 227/262] Remove use of Try::Tiny entirely (the missing part of ddcc02d1) While at the time it seemed expedient to keep relying on Try::Tiny::catch and only replace Try::Tiny::try internally, it turns out that the current naming behavior of T::T [1] means we can not get DBIC::Carp to report a friendly callsite, as finding which catch{} frames are skippable becomes problematic. Additionally this drops a flurry of runtime Sub::Name calls which in turn is likely to take less time ( note - this has not been explicitly timed, but seems to pop up often in profiles: https://youtu.be/PYCbumw0Fis?t=1919 ) In any case - one less dep that we do not really use is always a win Despite the large changeset there should be zero functional changes This essentially reverts the entirety of 9b58d129 Read under -w [1] https://metacpan.org/diff/file?source=DOY/Try-Tiny-0.14&target=DOY/Try-Tiny-0.15#lib/Try/Tiny.pm --- Makefile.PL | 1 - lib/DBIx/Class/InflateColumn/DateTime.pm | 8 +- lib/DBIx/Class/Relationship/Base.pm | 1 - lib/DBIx/Class/Relationship/BelongsTo.pm | 5 +- lib/DBIx/Class/Relationship/HasOne.pm | 5 +- lib/DBIx/Class/ResultSet.pm | 5 +- lib/DBIx/Class/ResultSource/RowParser.pm | 2 - lib/DBIx/Class/Schema.pm | 11 ++- lib/DBIx/Class/Storage.pm | 11 ++- lib/DBIx/Class/Storage/BlockRunner.pm | 7 +- lib/DBIx/Class/Storage/DBI.pm | 23 +++-- lib/DBIx/Class/Storage/DBI/MSSQL.pm | 5 +- lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm | 5 +- .../Storage/DBI/ODBC/Microsoft_SQL_Server.pm | 6 +- lib/DBIx/Class/Storage/DBI/Replicated.pm | 2 - lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm | 10 ++- lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm | 16 +--- lib/DBIx/Class/Storage/DBI/SQLite.pm | 8 +- lib/DBIx/Class/Storage/DBI/Sybase.pm | 6 +- lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm | 26 +++--- lib/DBIx/Class/_Util.pm | 62 ++++++++----- lib/SQL/Translator/Parser/DBIx/Class.pm | 6 +- t/52leaks.t | 19 +++- t/73oracle.t | 1 - t/73oracle_blob.t | 35 +++++--- t/745db2.t | 5 +- t/746mssql.t | 31 +++++-- t/747mssql_ado.t | 89 ++++++++++++------- t/749sqlanywhere.t | 62 ++++++++----- t/750firebird.t | 7 +- t/751msaccess.t | 34 +++---- t/icdt/engine_specific/msaccess.t | 3 +- t/icdt/engine_specific/mssql.t | 7 +- t/icdt/engine_specific/sqlite.t | 1 - t/lib/ANFANG.pm | 56 ++++++------ t/storage/debug.t | 40 ++++----- t/storage/quote_names.t | 5 +- xt/extra/internals/namespaces_cleaned.t | 5 +- xt/extra/lean_startup.t | 1 - 39 files changed, 360 insertions(+), 272 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index df82cb744..7aab0d5e7 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -58,7 +58,6 @@ my $runtime_requires = { 'namespace::clean' => '0.24', 'Scope::Guard' => '0.03', 'SQL::Abstract' => '1.81', - 'Try::Tiny' => '0.07', # Technically this is not a core dependency - it is only required # by the MySQL codepath. However this particular version is bundled diff --git a/lib/DBIx/Class/InflateColumn/DateTime.pm b/lib/DBIx/Class/InflateColumn/DateTime.pm index b284a640a..32916680a 100644 --- a/lib/DBIx/Class/InflateColumn/DateTime.pm +++ b/lib/DBIx/Class/InflateColumn/DateTime.pm @@ -4,8 +4,7 @@ use strict; use warnings; use base qw/DBIx::Class/; use DBIx::Class::Carp; -use DBIx::Class::_Util 'dbic_internal_try'; -use Try::Tiny; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); use namespace::clean; =head1 NAME @@ -216,12 +215,13 @@ sub _flate_or_fallback my $preferred_method = sprintf($method_fmt, $info->{ _ic_dt_method }); my $method = $parser->can($preferred_method) || sprintf($method_fmt, 'datetime'); - return dbic_internal_try { + dbic_internal_try { $parser->$method($value); } - catch { + dbic_internal_catch { $self->throw_exception ("Error while inflating '$value' for $info->{__dbic_colname} on ${self}: $_") unless $info->{datetime_undef_if_invalid}; + undef; # rv }; } diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index 007676e04..8e4b28015 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -6,7 +6,6 @@ use warnings; use base qw/DBIx::Class/; use Scalar::Util qw/weaken blessed/; -use Try::Tiny; use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION fail_on_internal_call ); use namespace::clean; diff --git a/lib/DBIx/Class/Relationship/BelongsTo.pm b/lib/DBIx/Class/Relationship/BelongsTo.pm index 50ddc2eb4..0a0f0dbd2 100644 --- a/lib/DBIx/Class/Relationship/BelongsTo.pm +++ b/lib/DBIx/Class/Relationship/BelongsTo.pm @@ -6,8 +6,7 @@ package # hide from PAUSE use strict; use warnings; -use Try::Tiny; -use DBIx::Class::_Util 'dbic_internal_try'; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); use namespace::clean; our %_pod_inherit_config = @@ -45,7 +44,7 @@ sub belongs_to { my $f_rsrc = dbic_internal_try { $f_class->result_source; } - catch { + dbic_internal_catch { $class->throw_exception( "Foreign class '$f_class' does not seem to be a Result class " . "(or it simply did not load entirely due to a circular relation chain): $_" diff --git a/lib/DBIx/Class/Relationship/HasOne.pm b/lib/DBIx/Class/Relationship/HasOne.pm index 8f74bb8a1..2894aa05b 100644 --- a/lib/DBIx/Class/Relationship/HasOne.pm +++ b/lib/DBIx/Class/Relationship/HasOne.pm @@ -4,8 +4,7 @@ package # hide from PAUSE use strict; use warnings; use DBIx::Class::Carp; -use Try::Tiny; -use DBIx::Class::_Util 'dbic_internal_try'; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); use namespace::clean; our %_pod_inherit_config = @@ -41,7 +40,7 @@ sub _has_one { unless $r->columns; $r; } - catch { + dbic_internal_catch { $class->throw_exception( "Foreign class '$f_class' does not seem to be a Result class " . "(or it simply did not load entirely due to a circular relation chain)" diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 7ab7a7299..43383926c 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -10,11 +10,10 @@ use DBIx::Class::ResultSetColumn; use DBIx::Class::ResultClass::HashRefInflator; use Scalar::Util qw( blessed reftype ); use DBIx::Class::_Util qw( - dbic_internal_try dump_value + dbic_internal_try dbic_internal_catch dump_value fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION ); use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); -use Try::Tiny; BEGIN { # De-duplication in _merge_attr() is disabled, but left in for reference @@ -884,7 +883,7 @@ sub find { $alias ); } - catch { + dbic_internal_catch { push @fc_exceptions, $_ if $_ =~ /\bFilterColumn\b/; }; } diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index 676a54896..6fe946f38 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -6,8 +6,6 @@ use warnings; use base 'DBIx::Class'; -use Try::Tiny; - use DBIx::Class::ResultSource::RowParser::Util qw( assemble_simple_parser assemble_collapsing_parser diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 5987f757b..1bf19653e 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -6,11 +6,10 @@ use warnings; use base 'DBIx::Class'; use DBIx::Class::Carp; -use Try::Tiny; use Scalar::Util qw( weaken blessed refaddr ); use DBIx::Class::_Util qw( refdesc refcount quote_sub scope_guard - is_exception dbic_internal_try + is_exception dbic_internal_try dbic_internal_catch fail_on_internal_call emit_loud_diag ); use Devel::GlobalDestruction; @@ -205,7 +204,7 @@ sub _ns_get_rsrc_instance { return dbic_internal_try { $rs_class->result_source - } catch { + } dbic_internal_catch { $me->throw_exception ( "Attempt to load_namespaces() class $rs_class failed - are you sure this is a real Result Class?: $_" ); @@ -914,7 +913,7 @@ sub connection { dbic_internal_try { $self->ensure_class_loaded ($storage_class); } - catch { + dbic_internal_catch { $self->throw_exception( "Unable to load storage class ${storage_class}: $_" ); @@ -1209,7 +1208,7 @@ This guard was activated starting", 1; } - catch { + dbic_internal_catch { # We call this to get the necessary warnings emitted and disregard the RV # as it's definitely an exception if we got as far as this catch{} block is_exception( @@ -1674,7 +1673,7 @@ sub compose_connection { dbic_internal_try { require DBIx::Class::ResultSetProxy; } - catch { + dbic_internal_catch { $self->throw_exception ("No arguments to load_classes and couldn't load DBIx::Class::ResultSetProxy ($_)") }; diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm index acae96a56..dfff9a1a4 100644 --- a/lib/DBIx/Class/Storage.pm +++ b/lib/DBIx/Class/Storage.pm @@ -16,8 +16,7 @@ use DBIx::Class::Carp; use DBIx::Class::Storage::BlockRunner; use Scalar::Util qw/blessed weaken/; use DBIx::Class::Storage::TxnScopeGuard; -use DBIx::Class::_Util qw( dbic_internal_try fail_on_internal_call ); -use Try::Tiny; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch fail_on_internal_call ); use namespace::clean; __PACKAGE__->mk_group_accessors(simple => qw/debug schema transaction_depth auto_savepoint savepoints/); @@ -152,7 +151,7 @@ For example, my $rs; try { $rs = $schema->txn_do($coderef); - } catch { + } dbic_internal_catch { my $error = shift; # Transaction failed die "something terrible has happened!" @@ -320,7 +319,7 @@ sub __delicate_rollback { dbic_internal_try { $self->txn_rollback; 1 } - catch { + dbic_internal_catch { $rbe = $_; @@ -590,7 +589,7 @@ sub debugobj { my $cfg = dbic_internal_try { Config::Any->load_files({ files => [$profile], use_ext => 1 }); - } catch { + } dbic_internal_catch { # sanitize the error message a bit $_ =~ s/at \s+ .+ Storage\.pm \s line \s \d+ $//x; $self->throw_exception("Failure processing \$ENV{DBIC_TRACE_PROFILE}: $_"); @@ -616,7 +615,7 @@ sub debugobj { # a better fix. This is another yak to shave... :( dbic_internal_try { DBIx::Class::Storage::Debug::PrettyPrint->new(@pp_args); - } catch { + } dbic_internal_catch { $self->throw_exception($_); } } diff --git a/lib/DBIx/Class/Storage/BlockRunner.pm b/lib/DBIx/Class/Storage/BlockRunner.pm index 63f5be381..64d5164cd 100644 --- a/lib/DBIx/Class/Storage/BlockRunner.pm +++ b/lib/DBIx/Class/Storage/BlockRunner.pm @@ -6,9 +6,8 @@ use strict; use DBIx::Class::Carp; use Context::Preserve 'preserve_context'; -use DBIx::Class::_Util qw( is_exception qsub dbic_internal_try ); +use DBIx::Class::_Util qw( is_exception qsub dbic_internal_try dbic_internal_catch ); use Scalar::Util qw(weaken blessed reftype); -use Try::Tiny; use Moo; use namespace::clean; @@ -127,7 +126,7 @@ sub _run { $txn_begin_ok = 1; } $cref->( @$args ); - } catch { + } dbic_internal_catch { $run_err = $_; (); # important, affects @_ below }; @@ -159,7 +158,7 @@ sub _run { $storage->txn_commit; 1; } - catch { + dbic_internal_catch { $run_err = $_; }; } diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 1a9d792f0..4a91bb445 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -10,11 +10,10 @@ use mro 'c3'; use DBIx::Class::Carp; use Scalar::Util qw/refaddr weaken reftype blessed/; use Context::Preserve 'preserve_context'; -use Try::Tiny; use SQL::Abstract qw(is_plain_value is_literal_value); use DBIx::Class::_Util qw( quote_sub perlstring serialize dump_value - dbic_internal_try + dbic_internal_try dbic_internal_catch detected_reinvoked_destructor scope_guard mkdir_p ); @@ -1174,7 +1173,7 @@ sub _server_info { my $server_version = dbic_internal_try { $self->_get_server_version - } catch { + } dbic_internal_catch { # driver determination *may* use this codepath # in which case we must rethrow $self->throw_exception($_) if $self->{_in_determine_driver}; @@ -1469,7 +1468,7 @@ sub _do_connection_actions { $self->throw_exception (sprintf ("Don't know how to process conection actions of type '%s'", ref($call)) ); } } - catch { + dbic_internal_catch { if ( $method_prefix =~ /^connect/ ) { # this is an on_connect cycle - we can't just throw while leaving # a handle in an undefined state in our storage object @@ -1619,7 +1618,7 @@ sub _connect { $dbh_error_handler_installer->($self, $dbh); } } - catch { + dbic_internal_catch { $self->throw_exception("DBI Connection failed: $_") }; @@ -2104,7 +2103,7 @@ sub insert { @ir_container = $sth->fetchrow_array; $sth->finish; - } catch { + } dbic_internal_catch { # Evict the $sth from the cache in case we got here, since the finish() # is crucial, at least on older Firebirds, possibly on other engines too # @@ -2446,7 +2445,7 @@ sub _dbh_execute_for_fetch { $tuple_status, ); } - catch { + dbic_internal_catch { $err = shift; }; @@ -2462,7 +2461,7 @@ sub _dbh_execute_for_fetch { dbic_internal_try { $sth->finish } - catch { + dbic_internal_catch { $err = shift unless defined $err }; @@ -2493,7 +2492,7 @@ sub _dbh_execute_inserts_with_no_binds { $sth->execute foreach 1..$count; } - catch { + dbic_internal_catch { $err = shift; }; @@ -2501,7 +2500,7 @@ sub _dbh_execute_inserts_with_no_binds { dbic_internal_try { $sth->finish } - catch { + dbic_internal_catch { $err = shift unless defined $err; }; @@ -2729,7 +2728,7 @@ sub _dbh_columns_info_for { $result{$col_name} = \%column_info; } - } catch { + } dbic_internal_catch { %result = (); }; @@ -3235,7 +3234,7 @@ sub deploy { # do a dbh_do cycle here, as we need some error checking in # place (even though we will ignore errors) $self->dbh_do (sub { $_[1]->do($line) }); - } catch { + } dbic_internal_catch { carp qq{$_ (running "${line}")}; }; $self->_query_end($line); diff --git a/lib/DBIx/Class/Storage/DBI/MSSQL.pm b/lib/DBIx/Class/Storage/DBI/MSSQL.pm index f07adfdc7..9a49a42db 100644 --- a/lib/DBIx/Class/Storage/DBI/MSSQL.pm +++ b/lib/DBIx/Class/Storage/DBI/MSSQL.pm @@ -9,8 +9,7 @@ use base qw/ /; use mro 'c3'; -use Try::Tiny; -use DBIx::Class::_Util qw( dbic_internal_try sigwarn_silencer ); +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch sigwarn_silencer ); use namespace::clean; __PACKAGE__->mk_group_accessors(simple => qw/ @@ -182,7 +181,7 @@ sub _ping { $dbh->do('select 1'); 1; } - catch { + dbic_internal_catch { # MSSQL is *really* annoying wrt multiple active resultsets, # and this may very well be the reason why the _ping failed # diff --git a/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm b/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm index 91f729222..1d549e856 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm @@ -7,8 +7,7 @@ use base qw/ DBIx::Class::Storage::DBI::Firebird::Common /; use mro 'c3'; -use Try::Tiny; -use DBIx::Class::_Util 'dbic_internal_try'; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); use namespace::clean; =head1 NAME @@ -52,7 +51,7 @@ sub _exec_svp_rollback { dbic_internal_try { $self->_dbh->do("ROLLBACK TO SAVEPOINT $name") } - catch { + dbic_internal_catch { # Firebird ODBC driver bug, ignore if (not /Unable to fetch information about the error/) { $self->throw_exception($_); diff --git a/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm index 4ee00eb8e..8e2564410 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm @@ -8,8 +8,7 @@ use base qw/ /; use mro 'c3'; use Scalar::Util 'reftype'; -use Try::Tiny; -use DBIx::Class::_Util 'dbic_internal_try'; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); use DBIx::Class::Carp; use namespace::clean; @@ -233,7 +232,8 @@ sub _run_connection_actions { local $dbh->{RaiseError} = 1; local $dbh->{PrintError} = 0; $dbh->do('SELECT @@IDENTITY'); - } catch { + } + dbic_internal_catch { $self->throw_exception ( 'Your drivers do not seem to support dynamic cursors (odbc_cursortype => 2).' . ( diff --git a/lib/DBIx/Class/Storage/DBI/Replicated.pm b/lib/DBIx/Class/Storage/DBI/Replicated.pm index 6a2f7ad8f..48642ece6 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated.pm @@ -20,8 +20,6 @@ use Scalar::Util 'reftype'; use Hash::Merge; use List::Util qw( min max ); use Context::Preserve 'preserve_context'; -use Try::Tiny; -use DBIx::Class::_Util 'dbic_internal_try'; use namespace::clean -except => 'meta'; diff --git a/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm b/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm index ed66b2840..cea37884c 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated/Pool.pm @@ -6,8 +6,7 @@ use Scalar::Util 'reftype'; use DBI (); use MooseX::Types::Moose qw/Num Int ClassName HashRef/; use DBIx::Class::Storage::DBI::Replicated::Types 'DBICStorageDBI'; -use DBIx::Class::_Util 'dbic_internal_try'; -use Try::Tiny; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); use namespace::clean -except => 'meta'; @@ -293,14 +292,17 @@ Returns 1 on success and undef on failure. sub _safely { my ($self, $replicant, $name, $code) = @_; - return dbic_internal_try { + dbic_internal_try { $code->(); 1; - } catch { + } + dbic_internal_catch { $replicant->debugobj->print(sprintf( "Exception trying to $name for replicant %s, error is %s", $replicant->_dbi_connect_info->[0], $_) ); + + # rv undef; }; } diff --git a/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm b/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm index 57687ad6a..e9bc10220 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm @@ -4,9 +4,6 @@ use strict; use warnings; use base qw/DBIx::Class::Storage::DBI::UniqueIdentifier/; use mro 'c3'; -use DBIx::Class::_Util 'dbic_internal_try'; -use Try::Tiny; -use namespace::clean; __PACKAGE__->mk_group_accessors(simple => qw/_identity/); __PACKAGE__->sql_limit_dialect ('RowNumberOver'); @@ -135,18 +132,11 @@ sub select_single { return @row; } -# this sub stolen from MSSQL - sub build_datetime_parser { - my $self = shift; - dbic_internal_try { - require DateTime::Format::Strptime; - } - catch { - $self->throw_exception("Couldn't load DateTime::Format::Strptime: $_"); - }; - return DateTime::Format::Strptime->new( pattern => '%Y-%m-%d %H:%M:%S.%6N' ); + require DateTime::Format::Strptime; + + DateTime::Format::Strptime->new( pattern => '%Y-%m-%d %H:%M:%S.%6N' ); } =head2 connect_call_datetime_setup diff --git a/lib/DBIx/Class/Storage/DBI/SQLite.pm b/lib/DBIx/Class/Storage/DBI/SQLite.pm index 28cadaac3..714b1073b 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLite.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLite.pm @@ -7,9 +7,11 @@ use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; use SQL::Abstract 'is_plain_value'; -use DBIx::Class::_Util qw(modver_gt_or_eq sigwarn_silencer dbic_internal_try); +use DBIx::Class::_Util qw( + modver_gt_or_eq sigwarn_silencer + dbic_internal_try dbic_internal_catch +); use DBIx::Class::Carp; -use Try::Tiny; use namespace::clean; __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::SQLite'); @@ -181,7 +183,7 @@ sub _ping { $really_not_in_txn = 1; } - catch { + dbic_internal_catch { $really_not_in_txn = ( $_[0] =~ qr/transaction within a transaction/ ? 0 : undef diff --git a/lib/DBIx/Class/Storage/DBI/Sybase.pm b/lib/DBIx/Class/Storage/DBI/Sybase.pm index 9f2b84a6c..a71426813 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase.pm @@ -2,8 +2,7 @@ package DBIx::Class::Storage::DBI::Sybase; use strict; use warnings; -use DBIx::Class::_Util 'dbic_internal_try'; -use Try::Tiny; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); use namespace::clean; use base qw/DBIx::Class::Storage::DBI/; @@ -38,7 +37,8 @@ sub _get_rdbms_name { } $name; # RV - } catch { + } + dbic_internal_catch { $self->throw_exception("Unable to establish connection to determine database type: $_") }; } diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm index 5282b7f9b..fde0b7301 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm @@ -11,9 +11,11 @@ use base qw/ use mro 'c3'; use DBIx::Class::Carp; use Scalar::Util qw/blessed weaken/; -use Try::Tiny; use Context::Preserve 'preserve_context'; -use DBIx::Class::_Util qw( sigwarn_silencer dbic_internal_try dump_value scope_guard set_subname ); +use DBIx::Class::_Util qw( + sigwarn_silencer dbic_internal_try dbic_internal_catch + dump_value scope_guard set_subname +); use namespace::clean; __PACKAGE__->sql_limit_dialect ('GenericSubQ'); @@ -653,8 +655,9 @@ sub _insert_bulk { $guard->commit; $bulk->_query_end($sql); - } catch { - $exception = shift; + } + dbic_internal_catch { + $exception = $_; }; DBD::Sybase::set_cslib_cb($orig_cslib_cb); @@ -731,11 +734,14 @@ sub _remove_blob_cols_array { sub _update_blobs { my ($self, $source, $blob_cols, $where) = @_; - my @primary_cols = dbic_internal_try - { $source->_pri_cols_or_die } - catch { + my @primary_cols = + dbic_internal_try { + $source->_pri_cols_or_die + } + dbic_internal_catch { $self->throw_exception("Cannot update TEXT/IMAGE column(s): $_") - }; + } + ; my @pks_to_update; if ( @@ -766,7 +772,7 @@ sub _insert_blobs { my @primary_cols = dbic_internal_try { $source->_pri_cols_or_die } - catch { + dbic_internal_catch { $self->throw_exception("Cannot update TEXT/IMAGE column(s): $_") }; @@ -819,7 +825,7 @@ sub _insert_blobs { $sth->func('ct_finish_send') or die $sth->errstr; } - catch { + dbic_internal_catch { if ($self->_using_freetds) { $self->throw_exception ( "TEXT/IMAGE operation failed, probably because you are using FreeTDS: $_" diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 7d268504c..b8f0b0668 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -202,7 +202,7 @@ our @EXPORT_OK = qw( refdesc refcount hrefaddr set_subname get_subname describe_class_methods scope_guard detected_reinvoked_destructor emit_loud_diag true false - is_exception dbic_internal_try visit_namespaces + is_exception dbic_internal_try dbic_internal_catch visit_namespaces quote_sub qsub perlstring serialize deep_clone dump_value uniq parent_dir mkdir_p UNRESOLVABLE_CONDITION @@ -608,10 +608,10 @@ sub is_exception ($) { { my $callstack_state; - # Recreate the logic of try(), while reusing the catch()/finally() as-is - # - # FIXME: We need to move away from Try::Tiny entirely (way too heavy and - # yes, shows up ON TOP of profiles) but this is a batle for another maint + # Recreate the logic of Try::Tiny, but without the crazy Sub::Name + # invocations and without support for finally() altogether + # ( yes, these days Try::Tiny is so "tiny" it shows *ON TOP* of most + # random profiles https://youtu.be/PYCbumw0Fis?t=1919 ) sub dbic_internal_try (&;@) { my $try_cref = shift; @@ -619,30 +619,30 @@ sub is_exception ($) { for my $arg (@_) { - if( ref($arg) eq 'Try::Tiny::Catch' ) { + croak 'dbic_internal_try() may not be followed by multiple dbic_internal_catch() blocks' + if $catch_cref; - croak 'dbic_internal_try() may not be followed by multiple catch() blocks' - if $catch_cref; + ($catch_cref = $$arg), next + if ref($arg) eq 'DBIx::Class::_Util::Catch'; - $catch_cref = $$arg; - } - elsif ( ref($arg) eq 'Try::Tiny::Finally' ) { - croak 'dbic_internal_try() does not support finally{}'; - } - else { - croak( - 'dbic_internal_try() encountered an unexpected argument ' - . "'@{[ defined $arg ? $arg : 'UNDEF' ]}' - perhaps " - . 'a missing semi-colon before or ' # trailing space important - ); - } + croak( 'Mixing dbic_internal_try() with Try::Tiny::catch() is not supported' ) + if ref($arg) eq 'Try::Tiny::Catch'; + + croak( 'dbic_internal_try() does not support finally{}' ) + if ref($arg) eq 'Try::Tiny::Finally'; + + croak( + 'dbic_internal_try() encountered an unexpected argument ' + . "'@{[ defined $arg ? $arg : 'UNDEF' ]}' - perhaps " + . 'a missing semi-colon before or ' # trailing space important + ); } my $wantarray = wantarray; my $preexisting_exception = $@; my @ret; - my $all_good = eval { + my $saul_goodman = eval { $@ = $preexisting_exception; local $callstack_state->{in_internal_try} = 1 @@ -667,7 +667,7 @@ sub is_exception ($) { my $exception = $@; $@ = $preexisting_exception; - if ( $all_good ) { + if ( $saul_goodman ) { return $wantarray ? @ret : $ret[0] } elsif ( $catch_cref ) { @@ -679,7 +679,23 @@ sub is_exception ($) { return; } - sub in_internal_try { !! $callstack_state->{in_internal_try} } + sub dbic_internal_catch (&;@) { + + croak( 'Useless use of bare dbic_internal_catch()' ) + unless wantarray; + + croak( 'dbic_internal_catch() must receive exactly one argument at end of expression' ) + if @_ > 1; + + bless( + \( $_[0] ), + 'DBIx::Class::_Util::Catch' + ), + } + + sub in_internal_try () { + !! $callstack_state->{in_internal_try} + } } { diff --git a/lib/SQL/Translator/Parser/DBIx/Class.pm b/lib/SQL/Translator/Parser/DBIx/Class.pm index ff636943d..74d455ac3 100644 --- a/lib/SQL/Translator/Parser/DBIx/Class.pm +++ b/lib/SQL/Translator/Parser/DBIx/Class.pm @@ -15,10 +15,9 @@ $DEBUG = 0 unless defined $DEBUG; use Exporter; use SQL::Translator::Utils qw(debug normalize_name); use DBIx::Class::Carp qw/^SQL::Translator|^DBIx::Class|^Try::Tiny/; -use DBIx::Class::_Util 'dbic_internal_try'; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); use Class::C3::Componentised; use Scalar::Util 'blessed'; -use Try::Tiny; use namespace::clean; use base qw(Exporter); @@ -56,7 +55,8 @@ sub parse { if (!ref $dbicschema) { dbic_internal_try { Class::C3::Componentised->ensure_class_loaded($dbicschema) - } catch { + } + dbic_internal_catch { DBIx::Class::Exception->throw("Can't load $dbicschema: $_"); } } diff --git a/t/52leaks.t b/t/52leaks.t index bd159a7ff..b395483dc 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -90,15 +90,26 @@ if ( !$ENV{DBICTEST_VIA_REPLICATED} and !DBICTest::RunMode->is_plain ) { return populate_weakregistry ($weak_registry, $obj ); }; - require Try::Tiny; - for my $func (qw/try catch finally/) { - my $orig = \&{"Try::Tiny::$func"}; - *{"Try::Tiny::$func"} = sub (&;@) { + + for my $func (qw( dbic_internal_try dbic_internal_catch )) { + my $orig = \&{"DBIx::Class::_Util::$func"}; + *{"DBIx::Class::_Util"} = sub (&;@) { populate_weakregistry( $weak_registry, $_[0] ); goto $orig; } } + if ( eval { require Try::Tiny } ) { + for my $func (qw( try catch finally )) { + my $orig = \&{"Try::Tiny::$func"}; + *{"Try::Tiny::$func"} = sub (&;@) { + populate_weakregistry( $weak_registry, $_[0] ); + goto $orig; + } + } + } + + # Some modules are known to install singletons on-load # Load them and empty the registry diff --git a/t/73oracle.t b/t/73oracle.t index e7096ea4d..c8c4cd02a 100644 --- a/t/73oracle.t +++ b/t/73oracle.t @@ -6,7 +6,6 @@ use warnings; use Test::Exception; use Test::More; -use Try::Tiny; use DBIx::Class::_Util 'set_subname'; use DBICTest; diff --git a/t/73oracle_blob.t b/t/73oracle_blob.t index d067c2b61..6e5c90337 100644 --- a/t/73oracle_blob.t +++ b/t/73oracle_blob.t @@ -6,7 +6,6 @@ use warnings; use Test::Exception; use Test::More; -use Try::Tiny; use DBICTest::Schema::BindType; BEGIN { @@ -105,10 +104,14 @@ SKIP: { 'multi-part LOB equality query was not cached', ) if $size eq 'large'; is @objs, 1, 'One row found matching on both LOBs'; - ok (try { $objs[0]->blob }||'' eq "blob:$str", 'blob inserted/retrieved correctly'); - ok (try { $objs[0]->clob }||'' eq "clob:$str", 'clob inserted/retrieved correctly'); - ok (try { $objs[0]->clb2 }||'' eq "clb2:$str", "clb2 inserted correctly"); - ok (try { $objs[0]->blb2 }||'' eq "blb2:$str", "blb2 inserted correctly"); + + for my $type (qw( blob clob clb2 blb2 )) { + is ( + eval { $objs[0]->$type }, + "$type:$str", + "$type inserted/retrieved correctly" + ); + } { local $TODO = '-like comparison on blobs not tested before ora 10 (fails on 8i)' @@ -138,10 +141,14 @@ SKIP: { @objs = $rs->search({ blob => "updated blob", clob => 'updated clob' })->all; is @objs, 1, 'found updated row'; - ok (try { $objs[0]->blob }||'' eq "updated blob", 'blob updated/retrieved correctly'); - ok (try { $objs[0]->clob }||'' eq "updated clob", 'clob updated/retrieved correctly'); - ok (try { $objs[0]->clb2 }||'' eq "updated clb2", "clb2 updated correctly"); - ok (try { $objs[0]->blb2 }||'' eq "updated blb2", "blb2 updated correctly"); + + for my $type (qw( blob clob clb2 blb2 )) { + is ( + eval { $objs[0]->$type }, + "updated $type", + "$type updated/retrieved correctly" + ); + } lives_ok { $rs->search({ id => $id }) @@ -150,8 +157,14 @@ SKIP: { @objs = $rs->search({ blob => 're-updated blob', clob => 're-updated clob' })->all; is @objs, 1, 'found updated row'; - ok (try { $objs[0]->blob }||'' eq 're-updated blob', 'blob updated/retrieved correctly'); - ok (try { $objs[0]->clob }||'' eq 're-updated clob', 'clob updated/retrieved correctly'); + + for my $type (qw( blob clob )) { + is ( + eval { $objs[0]->$type }, + "re-updated $type", + "$type updated/retrieved correctly" + ); + } lives_ok { $rs->search({ blob => "re-updated blob", clob => "re-updated clob" }) diff --git a/t/745db2.t b/t/745db2.t index 34cc2a1e5..e9a3fa6dc 100644 --- a/t/745db2.t +++ b/t/745db2.t @@ -6,7 +6,6 @@ use warnings; use Test::More; use Test::Exception; -use Try::Tiny; use DBICTest; @@ -22,9 +21,9 @@ my $dbh = $schema->storage->dbh; is $schema->storage->sql_maker->name_sep, $name_sep, 'name_sep detection'; -my $have_rno = try { +my $have_rno = eval { $dbh->selectrow_array( -"SELECT row_number() OVER (ORDER BY 1) FROM sysibm${name_sep}sysdummy1" + "SELECT row_number() OVER (ORDER BY 1) FROM sysibm${name_sep}sysdummy1" ); 1; }; diff --git a/t/746mssql.t b/t/746mssql.t index 5fc3d3000..e3ddd6d5c 100644 --- a/t/746mssql.t +++ b/t/746mssql.t @@ -7,9 +7,9 @@ use warnings; use Test::More; use Test::Exception; use Test::Warn; -use Try::Tiny; use DBICTest; +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/}; @@ -62,10 +62,10 @@ for my $opts_name (keys %opts) { my $opts = $opts{$opts_name}{opts}; $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts); - try { + dbic_internal_try { $schema->storage->ensure_connected } - catch { + dbic_internal_catch { if ($opts{$opts_name}{required}) { die "on_connect_call option '$opts_name' is not functional: $_"; } @@ -500,22 +500,35 @@ SQL $row = $rs->create({ amount => 100 }); } 'inserted a money value'; - cmp_ok ((try { $rs->find($row->id)->amount })||0, '==', 100, - 'money value round-trip'); + cmp_ok ( + ( eval { $rs->find($row->id)->amount } ) || 0, + '==', + 100, + 'money value round-trip' + ); lives_ok { $row->update({ amount => 200 }); } 'updated a money value'; - cmp_ok ((try { $rs->find($row->id)->amount })||0, '==', 200, - 'updated money value round-trip'); + cmp_ok ( + ( eval { $rs->find($row->id)->amount } ) || 0, + '==', + 200, + 'updated money value round-trip' + ); lives_ok { $row->update({ amount => undef }); } 'updated a money value to NULL'; - is try { $rs->find($row->id)->amount }, undef, - 'updated money value to NULL round-trip'; + lives_ok { + is( + $rs->find($row->id)->amount, + undef, + 'updated money value to NULL round-trip' + ); + } } } diff --git a/t/747mssql_ado.t b/t/747mssql_ado.t index d40cd17b0..a426605d4 100644 --- a/t/747mssql_ado.t +++ b/t/747mssql_ado.t @@ -6,7 +6,6 @@ use warnings; use Test::More; use Test::Exception; -use Try::Tiny; use DBICTest; @@ -40,7 +39,7 @@ is $schema->storage->sql_limit_dialect, ($ver >= 9 ? 'RowNumberOver' : 'Top'), $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; - try { local $^W = 0; $dbh->do("DROP TABLE artist") }; + eval { local $^W = 0; $dbh->do("DROP TABLE artist") }; $dbh->do(<<'SQL'); CREATE TABLE artist ( artistid INT IDENTITY NOT NULL, @@ -54,7 +53,7 @@ SQL $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; - try { local $^W = 0; $dbh->do("DROP TABLE artist_guid") }; + eval { local $^W = 0; $dbh->do("DROP TABLE artist_guid") }; $dbh->do(<<"SQL"); CREATE TABLE artist_guid ( artistid UNIQUEIDENTIFIER NOT NULL, @@ -71,7 +70,7 @@ my $have_max = $ver >= 9; # 2005 and greater $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; - try { local $^W = 0; $dbh->do("DROP TABLE varying_max_test") }; + eval { local $^W = 0; $dbh->do("DROP TABLE varying_max_test") }; $dbh->do(" CREATE TABLE varying_max_test ( id INT IDENTITY NOT NULL, @@ -115,7 +114,7 @@ my $rs1 = $schema->resultset('Artist')->search({}, { order_by => 'artistid' }); my $rs2 = $schema->resultset('Artist')->search({}, { order_by => 'name' }); while ($rs1->next) { - ok try { $rs2->next }, 'multiple active cursors'; + lives_ok { ok $rs2->next } 'multiple active cursors'; } # test bug where ADO blows up if the first bindparam is shorter than the second @@ -232,14 +231,19 @@ foreach my $size (qw/small large/) { $row->discard_changes; } 're-selected just-inserted LOBs'; - cmp_ok try { $row->varchar_max }, 'eq', $str, 'VARCHAR(MAX) matches'; - cmp_ok try { $row->nvarchar_max }, 'eq', $str, 'NVARCHAR(MAX) matches'; - cmp_ok try { $row->varbinary_max }, 'eq', $str, 'VARBINARY(MAX) matches'; + for my $type (qw( varchar nvarchar varbinary ) ) { + my $meth = "${type}_max"; + is( + eval { $row->$meth }, + $str, + ( uc $type ) . '(MAX) matches' + ); + } } # test regular blobs -try { local $^W = 0; $schema->storage->dbh->do('DROP TABLE bindtype_test') }; +eval { local $^W = 0; $schema->storage->dbh->do('DROP TABLE bindtype_test') }; $schema->storage->dbh->do(qq[ CREATE TABLE bindtype_test ( @@ -299,7 +303,7 @@ ok( ); diag $@ if $@; -my $guid = try { $row->artistid }||''; +my $guid = eval { $row->artistid }||''; ok(($guid !~ /^{.*?}\z/), 'GUID not enclosed in braces') or diag "GUID is: $guid"; @@ -313,29 +317,48 @@ diag $@ if $@; my $row_from_db = $schema->resultset('ArtistGUID') ->search({ name => 'mtfnpy' })->first; -is try { $row_from_db->artistid }, try { $row->artistid }, - 'PK GUID round trip (via ->search->next)'; +is( + eval { $row_from_db->artistid }, + eval { $row->artistid }, + 'PK GUID round trip (via ->search->next)' +); -is try { $row_from_db->a_guid }, try { $row->a_guid }, - 'NON-PK GUID round trip (via ->search->next)'; +is( + eval { $row_from_db->a_guid }, + eval { $row->a_guid }, + 'NON-PK GUID round trip (via ->search->next)' +); -$row_from_db = try { $schema->resultset('ArtistGUID') - ->find($row->artistid) }; +$row_from_db = eval { + $schema->resultset('ArtistGUID')->find($row->artistid) +}; -is try { $row_from_db->artistid }, try { $row->artistid }, - 'PK GUID round trip (via ->find)'; +is( + eval { $row_from_db->artistid }, + eval { $row->artistid }, + 'PK GUID round trip (via ->find)' +); -is try { $row_from_db->a_guid }, try { $row->a_guid }, - 'NON-PK GUID round trip (via ->find)'; +is( + eval { $row_from_db->a_guid }, + eval { $row->a_guid }, + 'NON-PK GUID round trip (via ->find)' +); ($row_from_db) = $schema->resultset('ArtistGUID') ->search({ name => 'mtfnpy' })->all; -is try { $row_from_db->artistid }, try { $row->artistid }, - 'PK GUID round trip (via ->search->all)'; +is( + eval { $row_from_db->artistid }, + eval { $row->artistid }, + 'PK GUID round trip (via ->search->all)' +); -is try { $row_from_db->a_guid }, try { $row->a_guid }, - 'NON-PK GUID round trip (via ->search->all)'; +is( + eval { $row_from_db->a_guid }, + eval { $row->a_guid }, + 'NON-PK GUID round trip (via ->search->all)' +); lives_ok { $row = $schema->resultset('ArtistGUID')->create({ @@ -344,15 +367,21 @@ lives_ok { }); } 'created a row with explicit PK GUID'; -is try { $row->artistid }, '70171270-4822-4450-81DF-921F99BA3C06', - 'row has correct PK GUID'; +is( + eval { $row->artistid }, + '70171270-4822-4450-81DF-921F99BA3C06', + 'row has correct PK GUID' +); lives_ok { $row->update({ artistid => '70171270-4822-4450-81DF-921F99BA3C07' }); } "updated row's PK GUID"; -is try { $row->artistid }, '70171270-4822-4450-81DF-921F99BA3C07', - 'row has correct PK GUID'; +is( + eval { $row->artistid }, + '70171270-4822-4450-81DF-921F99BA3C07', + 'row has correct PK GUID' +); lives_ok { $row->delete; @@ -370,8 +399,8 @@ done_testing; # clean up our mess END { local $SIG{__WARN__} = sub {}; - if (my $dbh = try { $schema->storage->_dbh }) { - (try { $dbh->do("DROP TABLE $_") }) + if (my $dbh = eval { $schema->storage->_dbh }) { + (eval { $dbh->do("DROP TABLE $_") }) for qw/artist artist_guid varying_max_test bindtype_test/; } diff --git a/t/749sqlanywhere.t b/t/749sqlanywhere.t index d4067b5bf..ed9c382ca 100644 --- a/t/749sqlanywhere.t +++ b/t/749sqlanywhere.t @@ -5,7 +5,6 @@ use warnings; use Test::More; use Test::Exception; -use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use DBIx::Class::_Util 'scope_guard'; @@ -226,35 +225,54 @@ SQL ); diag $@ if $@; - my $row_from_db = try { $schema->resultset('ArtistGUID') - ->search({ name => 'mtfnpy' })->first } - catch { diag $_ }; + my $row_from_db; + lives_ok { + $row_from_db = $schema->resultset('ArtistGUID')->search({ name => 'mtfnpy' })->first + }; - is try { $row_from_db->artistid }, $row->artistid, - 'PK GUID round trip (via ->search->next)'; + is( + eval { $row_from_db->artistid }, + $row->artistid, + 'PK GUID round trip (via ->search->next)' + ); - is try { $row_from_db->a_guid }, $row->a_guid, - 'NON-PK GUID round trip (via ->search->next)'; + is( + eval { $row_from_db->a_guid }, + $row->a_guid, + 'NON-PK GUID round trip (via ->search->next)' + ); - $row_from_db = try { $schema->resultset('ArtistGUID') - ->find($row->artistid) } - catch { diag $_ }; + lives_ok { + $row_from_db = $schema->resultset('ArtistGUID')->find($row->artistid) + }; - is try { $row_from_db->artistid }, $row->artistid, - 'PK GUID round trip (via ->find)'; + is( + eval { $row_from_db->artistid }, + $row->artistid, + 'PK GUID round trip (via ->find)' + ); - is try { $row_from_db->a_guid }, $row->a_guid, - 'NON-PK GUID round trip (via ->find)'; + is( + eval { $row_from_db->a_guid }, + $row->a_guid, + 'NON-PK GUID round trip (via ->find)' + ); - ($row_from_db) = try { $schema->resultset('ArtistGUID') - ->search({ name => 'mtfnpy' })->all } - catch { diag $_ }; + lives_ok { + ($row_from_db) = $schema->resultset('ArtistGUID')->search({ name => 'mtfnpy' })->all + }; - is try { $row_from_db->artistid }, $row->artistid, - 'PK GUID round trip (via ->search->all)'; + is( + eval { $row_from_db->artistid }, + $row->artistid, + 'PK GUID round trip (via ->search->all)' + ); - is try { $row_from_db->a_guid }, $row->a_guid, - 'NON-PK GUID round trip (via ->search->all)'; + is( + eval { $row_from_db->a_guid }, + $row->a_guid, + 'NON-PK GUID round trip (via ->search->all)' + ); } } diff --git a/t/750firebird.t b/t/750firebird.t index fac50d560..eb4122a5d 100644 --- a/t/750firebird.t +++ b/t/750firebird.t @@ -8,7 +8,6 @@ use Test::Exception; use DBIx::Class::Optional::Dependencies (); use DBIx::Class::_Util 'scope_guard'; use List::Util 'shuffle'; -use Try::Tiny; use DBICTest; @@ -218,7 +217,11 @@ EOF $row = $paged->next; } 'paged query survived'; - is try { $row->artistid }, 5, 'correct row from paged query'; + is( + eval { $row->artistid }, + 5, + 'correct row from paged query' + ); # DBD bug - if any unfinished statements are present during # DDL manipulation (test blobs below)- a segfault will occur diff --git a/t/751msaccess.t b/t/751msaccess.t index 479124aa8..2b70a4aec 100644 --- a/t/751msaccess.t +++ b/t/751msaccess.t @@ -5,7 +5,6 @@ use warnings; use Test::More; use Test::Exception; -use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use DBIx::Class::_Util 'scope_guard'; @@ -144,37 +143,38 @@ EOF title => 'my track', }); - my $joined_track = try { - $schema->resultset('Artist')->search({ + my $joined_track; + lives_ok { + $joined_track = $schema->resultset('Artist')->search({ artistid => $first_artistid, }, { join => [{ cds => 'tracks' }], '+select' => [ 'tracks.title' ], '+as' => [ 'track_title' ], })->next; - } - catch { - diag "Could not execute two-step left join: $_"; - }; + } 'Two-step left join executed'; - is try { $joined_track->get_column('track_title') }, 'my track', - 'two-step left join works'; + is( + eval { $joined_track->get_column('track_title') }, + 'my track', + 'two-step left join works' + ); - $joined_artist = try { - $schema->resultset('Track')->search({ + lives_ok { + $joined_artist = $schema->resultset('Track')->search({ trackid => $track->trackid, }, { join => [{ cd => 'artist' }], '+select' => [ 'artist.name' ], '+as' => [ 'artist_name' ], })->next; - } - catch { - diag "Could not execute two-step inner join: $_"; - }; + } 'Two-step inner join executed'; - is try { $joined_artist->get_column('artist_name') }, 'foo', - 'two-step inner join works'; + is( + eval { $joined_artist->get_column('artist_name') }, + 'foo', + 'two-step inner join works' + ); # test basic transactions $schema->txn_do(sub { diff --git a/t/icdt/engine_specific/msaccess.t b/t/icdt/engine_specific/msaccess.t index a3cb63c83..8f304ca2b 100644 --- a/t/icdt/engine_specific/msaccess.t +++ b/t/icdt/engine_specific/msaccess.t @@ -5,7 +5,6 @@ use strict; use warnings; use Test::More; -use Try::Tiny; use DBIx::Class::_Util 'scope_guard'; use DBICTest; @@ -39,7 +38,7 @@ for my $connect_info (@connect_info) { my $guard = scope_guard { cleanup($schema) }; - try { local $^W = 0; $schema->storage->dbh->do('DROP TABLE track') }; + eval { local $^W = 0; $schema->storage->dbh->do('DROP TABLE track') }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE track ( trackid AUTOINCREMENT PRIMARY KEY, diff --git a/t/icdt/engine_specific/mssql.t b/t/icdt/engine_specific/mssql.t index 2756858c8..3ba9d128b 100644 --- a/t/icdt/engine_specific/mssql.t +++ b/t/icdt/engine_specific/mssql.t @@ -6,7 +6,6 @@ use warnings; use Test::More; use Test::Exception; -use Try::Tiny; use DBIx::Class::_Util 'scope_guard'; use DBICTest; @@ -56,7 +55,7 @@ for my $connect_info (@connect_info) { my $guard = scope_guard { cleanup($schema) }; # $^W because DBD::ADO is a piece of crap - try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE track") }; + eval { local $^W = 0; $schema->storage->dbh->do("DROP TABLE track") }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE track ( trackid INT IDENTITY PRIMARY KEY, @@ -65,14 +64,14 @@ CREATE TABLE track ( last_updated_at DATETIME, ) SQL - try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE event_small_dt") }; + eval { local $^W = 0; $schema->storage->dbh->do("DROP TABLE event_small_dt") }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE event_small_dt ( id INT IDENTITY PRIMARY KEY, small_dt SMALLDATETIME, ) SQL - try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE event") }; + eval { local $^W = 0; $schema->storage->dbh->do("DROP TABLE event") }; $schema->storage->dbh->do(<<"SQL"); CREATE TABLE event ( id int IDENTITY(1,1) NOT NULL, diff --git a/t/icdt/engine_specific/sqlite.t b/t/icdt/engine_specific/sqlite.t index 1bee9d646..1c8b9215c 100644 --- a/t/icdt/engine_specific/sqlite.t +++ b/t/icdt/engine_specific/sqlite.t @@ -6,7 +6,6 @@ use warnings; use Test::More; use Test::Warn; -use Try::Tiny; use DBICTest; diff --git a/t/lib/ANFANG.pm b/t/lib/ANFANG.pm index c60ba9efe..e5e603548 100644 --- a/t/lib/ANFANG.pm +++ b/t/lib/ANFANG.pm @@ -112,32 +112,36 @@ $INC{$_} ||= __FILE__ for (qw( ANFANG.pm t/lib/ANFANG.pm ./t/lib/ANFANG.pm )); ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/dbix-class$| ) ) { - require Try::Tiny; - my $orig = \&Try::Tiny::try; - - # in case we loaded warnings.pm / used -w - # ( do not do `no warnings ...` as it is also a load ) - local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /redefined/ }; - - *Try::Tiny::try = sub (&;@) { - my ($fr, $first_pkg) = 0; - while( $first_pkg = caller($fr++) ) { - last if $first_pkg !~ /^ - __ANON__ - | - \Q(eval)\E - $/x; - } - - if ($first_pkg =~ /DBIx::Class/) { - require Test::Builder; - Test::Builder->new->ok(0, - 'Using try{} within DBIC internals is a mistake - use dbic_internal_try{} instead' - ); - } - - goto $orig; - }; + # two levels of if() because of taint mode tangling the %ENV-checks + # with the require() call, sigh... + + if ( eval { require Try::Tiny } ) { + my $orig = \&Try::Tiny::try; + + # in case we loaded warnings.pm / used -w + # ( do not do `no warnings ...` as it is also a load ) + local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /redefined/ }; + + *Try::Tiny::try = sub (&;@) { + my ($fr, $first_pkg) = 0; + while( $first_pkg = caller($fr++) ) { + last if $first_pkg !~ /^ + __ANON__ + | + \Q(eval)\E + $/x; + } + + if ($first_pkg =~ /DBIx::Class/) { + require Test::Builder; + Test::Builder->new->ok(0, + 'Using try{} within DBIC internals is a mistake - use dbic_internal_try{} instead' + ); + } + + goto $orig; + }; + } } } diff --git a/t/storage/debug.t b/t/storage/debug.t index aac2a2371..d0a6b4f7b 100644 --- a/t/storage/debug.t +++ b/t/storage/debug.t @@ -14,12 +14,11 @@ BEGIN { } use Test::More; -use Test::Exception; -use Try::Tiny; use File::Spec; use DBICTest; use DBICTest::Util 'slurp_bytes'; +use DBIx::Class::_Util 'scope_guard'; my $schema = DBICTest->init_schema(); @@ -69,15 +68,16 @@ open(STDERRCOPY, '>&STDERR'); my $exception_line_number; # STDERR will be closed, no T::B diag in blocks -my $exception = try { +my $exception = do { + my $restore_guard = scope_guard { open(STDERR, '>&STDERRCOPY') }; close(STDERR); - $exception_line_number = __LINE__ + 1; # important for test, do not reformat - $schema->resultset('CD')->search({})->count; -} catch { - $_ -} finally { - # restore STDERR - open(STDERR, '>&STDERRCOPY'); + + eval { + $exception_line_number = __LINE__ + 1; # important for test, do not reformat + $schema->resultset('CD')->search({})->count; + }; + + my $err = $@; }; ok $exception =~ / @@ -87,19 +87,19 @@ ok $exception =~ / /xms or diag "Unexpected exception text:\n\n$exception\n"; + my @warnings; -$exception = try { +$exception = do { local $SIG{__WARN__} = sub { push @warnings, @_ if $_[0] =~ /character/i }; + my $restore_guard = scope_guard { close STDERR; open(STDERR, '>&STDERRCOPY') }; close STDERR; - open(STDERR, '>', File::Spec->devnull) or die $!; - $schema->resultset('CD')->search({ title => "\x{1f4a9}" })->count; - ''; -} catch { - $_; -} finally { - # restore STDERR - close STDERR; - open(STDERR, '>&STDERRCOPY'); + + eval { + open(STDERR, '>', File::Spec->devnull) or die $!; + $schema->resultset('CD')->search({ title => "\x{1f4a9}" })->count; + }; + + my $err = $@; }; die "How did that fail... $exception" diff --git a/t/storage/quote_names.t b/t/storage/quote_names.t index 591606c4d..215c01140 100644 --- a/t/storage/quote_names.t +++ b/t/storage/quote_names.t @@ -3,7 +3,6 @@ BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } use strict; use warnings; use Test::More; -use Try::Tiny; use DBICTest; use DBIx::Class::_Util 'dump_value'; @@ -112,7 +111,7 @@ for my $db (sort { my $schema; - my $sql_maker = try { + my $sql_maker = eval { $schema = DBICTest::Schema->connect($dsn, $user, $pass, { quote_names => 1 }); @@ -140,7 +139,7 @@ for my $db (sort { # the SQLT producer has no idea what quotes are :/ ! grep { $db eq $_ } qw( SYBASE DB2 ) and - my $ddl = try { $schema->deployment_statements } + my $ddl = eval { $schema->deployment_statements } ) { my $quoted_artist = $sql_maker->_quote('artist'); diff --git a/xt/extra/internals/namespaces_cleaned.t b/xt/extra/internals/namespaces_cleaned.t index b0a7cdb62..89e2b54d0 100644 --- a/xt/extra/internals/namespaces_cleaned.t +++ b/xt/extra/internals/namespaces_cleaned.t @@ -159,7 +159,10 @@ for my $mod (@modules) { } # some common import names (these should never ever be methods) - for my $f (qw/carp carp_once carp_unique croak confess cluck try catch finally/) { + for my $f (qw( + carp carp_once carp_unique croak confess cluck + try catch finally dbic_internal_try dbic_internal_catch + )) { if ($mod->can($f)) { my $via; for (reverse @{mro::get_linear_isa($mod)} ) { diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index f915819de..b53d1e8f9 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -141,7 +141,6 @@ BEGIN { Carp namespace::clean - Try::Tiny Sub::Name Sub::Defer Sub::Quote From 9040c43abdc6182d84525e3d4c08765f989769a1 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 13 Sep 2016 12:57:00 +0200 Subject: [PATCH 228/262] (travis) Remove execution bits from the travis scripts No functional changes --- .travis.yml | 10 +++++----- maint/travis-ci_scripts/10_before_install.bash | 5 +++++ maint/travis-ci_scripts/20_install.bash | 5 +++++ maint/travis-ci_scripts/30_before_script.bash | 0 maint/travis-ci_scripts/40_script.bash | 0 maint/travis-ci_scripts/50_after_failure.bash | 0 maint/travis-ci_scripts/50_after_success.bash | 0 maint/travis-ci_scripts/60_after_script.bash | 0 maint/travis-ci_scripts/common.bash | 5 +++++ 9 files changed, 20 insertions(+), 5 deletions(-) mode change 100755 => 100644 maint/travis-ci_scripts/10_before_install.bash mode change 100755 => 100644 maint/travis-ci_scripts/20_install.bash mode change 100755 => 100644 maint/travis-ci_scripts/30_before_script.bash mode change 100755 => 100644 maint/travis-ci_scripts/40_script.bash mode change 100755 => 100644 maint/travis-ci_scripts/50_after_failure.bash mode change 100755 => 100644 maint/travis-ci_scripts/50_after_success.bash mode change 100755 => 100644 maint/travis-ci_scripts/60_after_script.bash mode change 100755 => 100644 maint/travis-ci_scripts/common.bash diff --git a/.travis.yml b/.travis.yml index bfda0e531..719a83af4 100644 --- a/.travis.yml +++ b/.travis.yml @@ -421,12 +421,12 @@ before_script: # need to invoke the after_failure script manually # because 'after_failure' runs only after 'script' fails # - - maint/getstatus maint/travis-ci_scripts/30_before_script.bash + - maint/getstatus /bin/bash maint/travis-ci_scripts/30_before_script.bash script: # Run actual tests # - - maint/getstatus maint/travis-ci_scripts/40_script.bash + - maint/getstatus /bin/bash maint/travis-ci_scripts/40_script.bash ### ### Set -e back, work around https://github.com/travis-ci/travis-ci/issues/3533 @@ -436,14 +436,14 @@ script: after_success: # Check if we can assemble a dist properly if not in CLEANTEST # - - maint/getstatus maint/travis-ci_scripts/50_after_success.bash || ( maint/travis-ci_scripts/50_after_failure.bash && /bin/false ) + - maint/getstatus /bin/bash maint/travis-ci_scripts/50_after_success.bash || ( /bin/bash maint/travis-ci_scripts/50_after_failure.bash && /bin/false ) after_failure: # Final sysinfo printout on fail # - - maint/getstatus maint/travis-ci_scripts/50_after_failure.bash + - maint/getstatus /bin/bash maint/travis-ci_scripts/50_after_failure.bash after_script: # No tasks yet # - #- maint/getstatus maint/travis-ci_scripts/60_after_script.bash + #- maint/getstatus /bin/bash maint/travis-ci_scripts/60_after_script.bash diff --git a/maint/travis-ci_scripts/10_before_install.bash b/maint/travis-ci_scripts/10_before_install.bash old mode 100755 new mode 100644 index 547fa8b05..3d5bbae55 --- a/maint/travis-ci_scripts/10_before_install.bash +++ b/maint/travis-ci_scripts/10_before_install.bash @@ -1,5 +1,10 @@ #!/bin/bash +if [[ "${BASH_SOURCE[0]}" == "${0}" ]] ; then + echo "This script can not be executed standalone - it can only be source()d" 1>&2 + exit 1 +fi + export SHORT_CIRCUIT_SMOKE if have_sudo ; then diff --git a/maint/travis-ci_scripts/20_install.bash b/maint/travis-ci_scripts/20_install.bash old mode 100755 new mode 100644 index ed7bc003e..8da037f8d --- a/maint/travis-ci_scripts/20_install.bash +++ b/maint/travis-ci_scripts/20_install.bash @@ -1,5 +1,10 @@ #!/bin/bash +if [[ "${BASH_SOURCE[0]}" == "${0}" ]] ; then + echo "This script can not be executed standalone - it can only be source()d" 1>&2 + exit 1 +fi + if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi # we need a mirror that both has the standard index and a backpan version rolled diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash old mode 100755 new mode 100644 diff --git a/maint/travis-ci_scripts/40_script.bash b/maint/travis-ci_scripts/40_script.bash old mode 100755 new mode 100644 diff --git a/maint/travis-ci_scripts/50_after_failure.bash b/maint/travis-ci_scripts/50_after_failure.bash old mode 100755 new mode 100644 diff --git a/maint/travis-ci_scripts/50_after_success.bash b/maint/travis-ci_scripts/50_after_success.bash old mode 100755 new mode 100644 diff --git a/maint/travis-ci_scripts/60_after_script.bash b/maint/travis-ci_scripts/60_after_script.bash old mode 100755 new mode 100644 diff --git a/maint/travis-ci_scripts/common.bash b/maint/travis-ci_scripts/common.bash old mode 100755 new mode 100644 index d2b77d820..48fb7c1d1 --- a/maint/travis-ci_scripts/common.bash +++ b/maint/travis-ci_scripts/common.bash @@ -1,5 +1,10 @@ #!/bin/bash +if [[ "${BASH_SOURCE[0]}" == "${0}" ]] ; then + echo "This script can not be executed standalone - it can only be source()d" 1>&2 + exit 1 +fi + # "autodie" set -e From 28f9d99c8707970d77b3a98bdc4eda9bb35d193f Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 16 Aug 2016 11:56:08 +0200 Subject: [PATCH 229/262] (travis) Revert 81cf62797 and b4532c43f (both fixed since) --- .travis.yml | 4 ---- maint/travis-ci_scripts/50_after_success.bash | 12 ------------ 2 files changed, 16 deletions(-) diff --git a/.travis.yml b/.travis.yml index 719a83af4..8ba45b2b5 100644 --- a/.travis.yml +++ b/.travis.yml @@ -363,10 +363,6 @@ matrix: # which ones of the above can fail allow_failures: - # FIXME work around https://github.com/travis-ci/travis-ci/issues/6439 - - perl: 5.18-extras - - perl: 5.24.0_thr_qm - # these run with various dev snapshots - allowed to fail - perl: cperl-5.24.0_thr_qm - perl: cperl-master_thr diff --git a/maint/travis-ci_scripts/50_after_success.bash b/maint/travis-ci_scripts/50_after_success.bash index 41b2fd1a0..83f1a89fb 100644 --- a/maint/travis-ci_scripts/50_after_success.bash +++ b/maint/travis-ci_scripts/50_after_success.bash @@ -27,12 +27,6 @@ if [[ "$DEVREL_DEPS" == "true" ]] && perl -M5.008003 -e1 &>/dev/null ; then parallel_installdeps_notest YAML Lexical::SealRequireHints fi - # FIXME - workaround for RT#116788 - # ( two instances, see below ) - if ! perl -M5.008007 -e1 &>/dev/null; then - parallel_installdeps_notest 'Encode~!=2.85' - fi - # FIXME Change when Moose goes away installdeps Moose $(perl -Ilib -MDBIx::Class::Optional::Dependencies=-list_missing,dist_dir) @@ -41,12 +35,6 @@ if [[ "$DEVREL_DEPS" == "true" ]] && perl -M5.008003 -e1 &>/dev/null ; then elif [[ "$CLEANTEST" != "true" ]] ; then - # FIXME - workaround for RT#116788 - # ( two instances, see above ) - if ! perl -M5.008007 -e1 &>/dev/null; then - parallel_installdeps_notest 'Encode~!=2.85' - fi - parallel_installdeps_notest $(perl -Ilib -MDBIx::Class::Optional::Dependencies=-list_missing,dist_dir) run_or_err "Attempt to build a dist from original checkout" "make dist" From 32871272c1fa5d098895fb3d6d2b2ed3640f371b Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 14 Sep 2016 18:07:00 +0200 Subject: [PATCH 230/262] (travis) Make sure everything works even when we are SAD http://www.martin-evans.me.uk/node/119 http://www.dagolden.com/index.php/1771/why-perl_unicode-makes-me-sad/ --- maint/travis-ci_scripts/20_install.bash | 3 +++ maint/travis-ci_scripts/30_before_script.bash | 5 +++++ maint/travis-ci_scripts/50_after_success.bash | 5 +++++ xt/extra/internals/optional_deps.t | 5 +++++ 4 files changed, 18 insertions(+) diff --git a/maint/travis-ci_scripts/20_install.bash b/maint/travis-ci_scripts/20_install.bash index 8da037f8d..1a4968f1e 100644 --- a/maint/travis-ci_scripts/20_install.bash +++ b/maint/travis-ci_scripts/20_install.bash @@ -152,6 +152,9 @@ if [[ "$POISON_ENV" = "true" ]] ; then fi done + echo "POISON_ENV: setting PERL_UNICODE=SAD" + export PERL_UNICODE=SAD + ### emulate a local::lib-like env diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 2a5532451..21df67fc4 100644 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -185,6 +185,11 @@ if [[ "$CLEANTEST" = "true" ]]; then ##### END TEMPORARY WORKAROUNDS fi + # FIXME - work around RT#117844 + if [[ "$BREWVER" == "5.10.0" ]]; then + unset PERL_UNICODE + fi + installdeps $HARD_DEPS run_or_err "Re-configure" "perl Makefile.PL" diff --git a/maint/travis-ci_scripts/50_after_success.bash b/maint/travis-ci_scripts/50_after_success.bash index 83f1a89fb..fd30331a6 100644 --- a/maint/travis-ci_scripts/50_after_success.bash +++ b/maint/travis-ci_scripts/50_after_success.bash @@ -27,6 +27,11 @@ if [[ "$DEVREL_DEPS" == "true" ]] && perl -M5.008003 -e1 &>/dev/null ; then parallel_installdeps_notest YAML Lexical::SealRequireHints fi + # FIXME - workaround for RT#117855/RT#117856 + if [[ -n "$PERL_UNICODE" ]] ; then + parallel_installdeps_notest Text::CSV + fi + # FIXME Change when Moose goes away installdeps Moose $(perl -Ilib -MDBIx::Class::Optional::Dependencies=-list_missing,dist_dir) diff --git a/xt/extra/internals/optional_deps.t b/xt/extra/internals/optional_deps.t index c1aa96e9b..e93391175 100644 --- a/xt/extra/internals/optional_deps.t +++ b/xt/extra/internals/optional_deps.t @@ -12,6 +12,11 @@ no warnings qw/once/; use Test::More; use Test::Exception; +BEGIN { + plan skip_all => 'This test breaking module loading interferes with PERL_UNICODE on perls prior to 5.12' + if exists $ENV{PERL_UNICODE} and "$]" < 5.012; +} + # load before we break require() use Scalar::Util(); use MRO::Compat(); From c6ec79000b160e7491d9ab9d95d6e69c473b0862 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 19 Sep 2016 14:14:27 +0200 Subject: [PATCH 231/262] Centralize specification of expected Result class base in the codebase Some parts of the stack need to be able to disambiguate Result instances from other objects. In odrder to avoid tight coupling introduce a single override point $DBIx::Class::ResultSource::__expected_result_class_isa for esoteric use cases No functional changes --- lib/DBIx/Class/ResultSet.pm | 54 ++++++++++++++++++++++++++++++---- lib/DBIx/Class/ResultSource.pm | 23 ++++++++++----- lib/DBIx/Class/Row.pm | 4 +-- lib/DBIx/Class/Storage/DBI.pm | 4 +-- 4 files changed, 68 insertions(+), 17 deletions(-) diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 43383926c..bf7e88f03 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -10,7 +10,7 @@ use DBIx::Class::ResultSetColumn; use DBIx::Class::ResultClass::HashRefInflator; use Scalar::Util qw( blessed reftype ); use DBIx::Class::_Util qw( - dbic_internal_try dbic_internal_catch dump_value + dbic_internal_try dbic_internal_catch dump_value emit_loud_diag fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION ); use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); @@ -2288,7 +2288,18 @@ sub populate { or ref $data->[$i][$_->{pos}] eq 'HASH' or - ( defined blessed $data->[$i][$_->{pos}] and $data->[$i][$_->{pos}]->isa('DBIx::Class::Row') ) + ( + defined blessed $data->[$i][$_->{pos}] + and + $data->[$i][$_->{pos}]->isa( + $DBIx::Class::ResultSource::__expected_result_class_isa + || + emit_loud_diag( + confess => 1, + msg => 'Global $DBIx::Class::ResultSource::__expected_result_class_isa unexpectedly unset...' + ) + ) + ) ) and 1 @@ -2296,7 +2307,18 @@ sub populate { # moar sanity check... sigh for ( ref $data->[$i][$_->{pos}] eq 'ARRAY' ? @{$data->[$i][$_->{pos}]} : $data->[$i][$_->{pos}] ) { - if ( defined blessed $_ and $_->isa('DBIx::Class::Row' ) ) { + if ( + defined blessed $_ + and + $_->isa( + $DBIx::Class::ResultSource::__expected_result_class_isa + || + emit_loud_diag( + confess => 1, + msg => 'Global $DBIx::Class::ResultSource::__expected_result_class_isa unexpectedly unset...' + ) + ) + ) { carp_unique("Fast-path populate() with supplied related objects is not possible - falling back to regular create()"); return my $throwaway = $self->populate(@_); } @@ -2338,7 +2360,18 @@ sub populate { or ref $data->[$i]{$_} eq 'HASH' or - ( defined blessed $data->[$i]{$_} and $data->[$i]{$_}->isa('DBIx::Class::Row') ) + ( + defined blessed $data->[$i]{$_} + and + $data->[$i]{$_}->isa( + $DBIx::Class::ResultSource::__expected_result_class_isa + || + emit_loud_diag( + confess => 1, + msg => 'Global $DBIx::Class::ResultSource::__expected_result_class_isa unexpectedly unset...' + ) + ) + ) ) and 1 @@ -2346,7 +2379,18 @@ sub populate { # moar sanity check... sigh for ( ref $data->[$i]{$_} eq 'ARRAY' ? @{$data->[$i]{$_}} : $data->[$i]{$_} ) { - if ( defined blessed $_ and $_->isa('DBIx::Class::Row' ) ) { + if ( + defined blessed $_ + and + $_->isa( + $DBIx::Class::ResultSource::__expected_result_class_isa + || + emit_loud_diag( + confess => 1, + msg => 'Global $DBIx::Class::ResultSource::__expected_result_class_isa unexpectedly unset...' + ) + ) + ) { carp_unique("Fast-path populate() with supplied related objects is not possible - falling back to regular create()"); return my $throwaway = $self->populate(@_); } diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index e5af674b4..0c0cb9d5e 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -31,6 +31,13 @@ use DBIx::Class::ResultSet; use namespace::clean; +# This global is present for the afaik nonexistent, but nevertheless possible +# case of folks using stock ::ResultSet with a completely custom Result-class +# hierarchy, not derived from DBIx::Class::Row at all +# Instead of patching stuff all over the place - this would be one convenient +# place to override things if need be +our $__expected_result_class_isa = 'DBIx::Class::Row'; + my @hashref_attributes = qw( source_info resultset_attributes _columns _unique_constraints _relationships @@ -2265,11 +2272,15 @@ sub _resolve_relationship_condition { $args->{require_join_free_condition} ||= !!$args->{infer_values_based_on}; - $self->throw_exception( "Argument 'self_result_object' must be an object inheriting from DBIx::Class::Row" ) + $self->throw_exception( "Argument 'self_result_object' must be an object inheriting from '$__expected_result_class_isa'" ) if ( exists $args->{self_result_object} and - ( ! defined blessed $args->{self_result_object} or ! $args->{self_result_object}->isa('DBIx::Class::Row') ) + ( + ! defined blessed $args->{self_result_object} + or + ! $args->{self_result_object}->isa( $__expected_result_class_isa ) + ) ) ; @@ -2284,8 +2295,8 @@ sub _resolve_relationship_condition { } elsif (defined blessed $args->{foreign_values}) { - $self->throw_exception( "Objects supplied as 'foreign_values' ($args->{foreign_values}) must inherit from DBIx::Class::Row" ) - unless $args->{foreign_values}->isa('DBIx::Class::Row'); + $self->throw_exception( "Objects supplied as 'foreign_values' ($args->{foreign_values}) must inherit from '$__expected_result_class_isa'" ) + unless $args->{foreign_values}->isa( $__expected_result_class_isa ); carp_unique( "Objects supplied as 'foreign_values' ($args->{foreign_values}) " @@ -2399,11 +2410,9 @@ sub _resolve_relationship_condition { ) for keys %$jfc; ( - length ref $_ - and defined blessed($_) and - $_->isa('DBIx::Class::Row') + $_->isa( $__expected_result_class_isa ) and $self->throw_exception ( "The join-free condition returned for $exception_rel_id may not " diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 87f3716c1..4188d1073 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -356,7 +356,7 @@ sub insert { my $rel_obj = $related_stuff{$rel_name}; if (! $self->{_rel_in_storage}{$rel_name}) { - next unless (blessed $rel_obj && $rel_obj->isa('DBIx::Class::Row')); + next unless (blessed $rel_obj && $rel_obj->isa(__PACKAGE__)); next unless $rsrc->_pk_depends_on( $rel_name, { $rel_obj->get_columns } @@ -441,7 +441,7 @@ sub insert { : $related_stuff{$rel_name} ; - if (@cands && blessed $cands[0] && $cands[0]->isa('DBIx::Class::Row') + if (@cands && blessed $cands[0] && $cands[0]->isa(__PACKAGE__) ) { my $reverse = $rsrc->reverse_relationship_info($rel_name); foreach my $obj (@cands) { diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 4a91bb445..99a895e8e 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -1754,9 +1754,7 @@ sub _gen_sql_bind { $op eq 'select' and grep { - length ref $_->[1] - and - blessed($_->[1]) + defined blessed($_->[1]) and $_->[1]->isa('DateTime') } @$bind From 1e8d85b39753dff2cd42b1f7b6342e145105feca Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 21 Aug 2016 10:07:17 +0200 Subject: [PATCH 232/262] With time couple DBIHacks methods became single-callsite only Remove _inner_join_to_node and _resolve_ident_sources from the callchain entirely --- lib/DBIx/Class/ResultSet.pm | 51 +++++++++++- lib/DBIx/Class/Storage/DBI.pm | 2 - lib/DBIx/Class/Storage/DBIHacks.pm | 121 ++++++++++------------------- 3 files changed, 91 insertions(+), 83 deletions(-) diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index bf7e88f03..920c7130f 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -3283,8 +3283,55 @@ sub related_resultset { # since this is search_related, and we already slid the select window inwards # (the select/as attrs were deleted in the beginning), we need to flip all # left joins to inner, so we get the expected results - # read the comment on top of the actual function to see what this does - $attrs->{from} = $storage->_inner_join_to_node( $attrs->{from}, $attrs->{alias} ); + # + # The DBIC relationship chaining implementation is pretty simple - every + # new related_relationship is pushed onto the {from} stack, and the {select} + # window simply slides further in. This means that when we count somewhere + # in the middle, we got to make sure that everything in the join chain is an + # actual inner join, otherwise the count will come back with unpredictable + # results (a resultset may be generated with _some_ rows regardless of if + # the relation which the $rs currently selects has rows or not). E.g. + # $artist_rs->cds->count - normally generates: + # SELECT COUNT( * ) FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid + # which actually returns the number of artists * (number of cds || 1) + # + # So what we do here is crawl {from}, determine if the current alias is at + # the top of the stack, and if not - make sure the chain is inner-joined down + # to the root. + # + my $switch_branch = $storage->_find_join_path_to_node( + $attrs->{from}, + $attrs->{alias}, + ); + + if ( @{ $switch_branch || [] } ) { + + # So it looks like we will have to switch some stuff around. + # local() is useless here as we will be leaving the scope + # anyway, and deep cloning is just too fucking expensive + # So replace the first hashref in the node arrayref manually + my @new_from = $attrs->{from}[0]; + my $sw_idx = { map { (values %$_), 1 } @$switch_branch }; #there's one k/v per join-path + + for my $j ( @{$attrs->{from}}[ 1 .. $#{$attrs->{from}} ] ) { + my $jalias = $j->[0]{-alias}; + + if ($sw_idx->{$jalias}) { + my %attrs = %{$j->[0]}; + delete $attrs{-join_type}; + push @new_from, [ + \%attrs, + @{$j}[ 1 .. $#$j ], + ]; + } + else { + push @new_from, $j; + } + } + + $attrs->{from} = \@new_from; + } + #XXX - temp fix for result_class bug. There likely is a more elegant fix -groditi delete $attrs->{result_class}; diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 99a895e8e..8d704bd82 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -2642,8 +2642,6 @@ sub _select_args { $orig_attrs->{_last_sqlmaker_alias_map} = $attrs->{_aliastypes}; ### - # my $alias2source = $self->_resolve_ident_sources ($ident); - # # This would be the point to deflate anything found in $attrs->{where} # (and leave $attrs->{bind} intact). Problem is - inflators historically # expect a result object. And all we have is a resultsource (it is trivial diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm index 317dbd85a..e9cbdd69a 100644 --- a/lib/DBIx/Class/Storage/DBIHacks.pm +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -769,36 +769,6 @@ sub _minmax_operator_for_datatype { $_[2] ? 'MAX' : 'MIN'; } -sub _resolve_ident_sources { - my ($self, $ident) = @_; - - my $alias2source = {}; - - # the reason this is so contrived is that $ident may be a {from} - # structure, specifying multiple tables to join - if ( blessed $ident && $ident->isa("DBIx::Class::ResultSource") ) { - # this is compat mode for insert/update/delete which do not deal with aliases - $alias2source->{me} = $ident; - } - elsif (ref $ident eq 'ARRAY') { - - for (@$ident) { - my $tabinfo; - if (ref $_ eq 'HASH') { - $tabinfo = $_; - } - if (ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH') { - $tabinfo = $_->[0]; - } - - $alias2source->{$tabinfo->{-alias}} = $tabinfo->{-rsrc} - if ($tabinfo->{-rsrc}); - } - } - - return $alias2source; -} - # Takes $ident, \@column_names # # returns { $column_name => \%column_info, ... } @@ -811,7 +781,34 @@ sub _resolve_column_info { return {} if $colnames and ! @$colnames; - my $sources = $self->_resolve_ident_sources($ident); + my $sources = ( + # this is compat mode for insert/update/delete which do not deal with aliases + ( + blessed($ident) + and + $ident->isa('DBIx::Class::ResultSource') + ) ? +{ me => $ident } + + # not a known fromspec - no columns to resolve: return directly + : ref($ident) ne 'ARRAY' ? return +{} + + : +{ + # otherwise decompose into alias/rsrc pairs + map + { + ( $_->{-rsrc} and $_->{-alias} ) + ? ( @{$_}{qw( -alias -rsrc )} ) + : () + } + map + { + ( ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH' ) ? $_->[0] + : ( ref $_ eq 'HASH' ) ? $_ + : () + } + @$ident + } + ); $_ = { rsrc => $_, colinfos => $_->columns_info } for values %$sources; @@ -873,54 +870,6 @@ sub _resolve_column_info { return \%return; } -# The DBIC relationship chaining implementation is pretty simple - every -# new related_relationship is pushed onto the {from} stack, and the {select} -# window simply slides further in. This means that when we count somewhere -# in the middle, we got to make sure that everything in the join chain is an -# actual inner join, otherwise the count will come back with unpredictable -# results (a resultset may be generated with _some_ rows regardless of if -# the relation which the $rs currently selects has rows or not). E.g. -# $artist_rs->cds->count - normally generates: -# SELECT COUNT( * ) FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid -# which actually returns the number of artists * (number of cds || 1) -# -# So what we do here is crawl {from}, determine if the current alias is at -# the top of the stack, and if not - make sure the chain is inner-joined down -# to the root. -# -sub _inner_join_to_node { - my ($self, $from, $alias) = @_; - - my $switch_branch = $self->_find_join_path_to_node($from, $alias); - - return $from unless @{$switch_branch||[]}; - - # So it looks like we will have to switch some stuff around. - # local() is useless here as we will be leaving the scope - # anyway, and deep cloning is just too fucking expensive - # So replace the first hashref in the node arrayref manually - my @new_from = ($from->[0]); - my $sw_idx = { map { (values %$_), 1 } @$switch_branch }; #there's one k/v per join-path - - for my $j (@{$from}[1 .. $#$from]) { - my $jalias = $j->[0]{-alias}; - - if ($sw_idx->{$jalias}) { - my %attrs = %{$j->[0]}; - delete $attrs{-join_type}; - push @new_from, [ - \%attrs, - @{$j}[ 1 .. $#$j ], - ]; - } - else { - push @new_from, $j; - } - } - - return \@new_from; -} - sub _find_join_path_to_node { my ($self, $from, $target_alias) = @_; @@ -1099,4 +1048,18 @@ sub _extract_fixed_condition_columns :DBIC_method_is_indirect_sugar { extract_equality_conditions(@_); } +sub _resolve_ident_sources :DBIC_method_is_indirect_sugar { + DBIx::Class::Exception->throw( + '_resolve_ident_sources() has been removed with no replacement, ' + . 'ask for advice on IRC if this affected you' + ); +} + +sub _inner_join_to_node :DBIC_method_is_indirect_sugar { + DBIx::Class::Exception->throw( + '_inner_join_to_node() has been removed with no replacement, ' + . 'ask for advice on IRC if this affected you' + ); +} + 1; From a4e4185f3c1e0af23dc3d916f706d0e92f95de45 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 27 Aug 2016 10:31:01 +0200 Subject: [PATCH 233/262] Fix unpredictable use of reverse_relationship_info() in the SQLT parser When reverse_relationship_info got introduced in de60a93d, it was inexplicably mis-applied at the very spot it was needed in the first place. A result class pair can (and sometimes do) have more than one relationship between them, possibly with differing cascade_* settings. Grabbing the first set of values from the multi-member hash is inconsistent at best. Fix so that if at least one "hard-dependency" is encountered we go ahead with marking the reverse part as a CASCADE --- Changes | 2 ++ lib/SQL/Translator/Parser/DBIx/Class.pm | 14 +++++++++++--- t/lib/DBICTest/Schema/SelfRef.pm | 1 + 3 files changed, 14 insertions(+), 3 deletions(-) diff --git a/Changes b/Changes index 8ca5192c3..91c525b52 100644 --- a/Changes +++ b/Changes @@ -69,6 +69,8 @@ Revision history for DBIx::Class - Fix spurious warning on MSSQL cursor invalidation retries (RT#102166) - Fix incorrect ::Storage->_ping() behavior under Sybase (RT#114214) - Fix several corner cases with Many2Many over custom relationships + - Fix intermittent failure to infer the CASCADE attributes of relations + during deployment_statements()/deploy() - Fix corner cases of C3 composition being broken on OLD_MRO (5.8.x) only: https://github.com/frioux/DBIx-Class-Helpers/issues/61 diff --git a/lib/SQL/Translator/Parser/DBIx/Class.pm b/lib/SQL/Translator/Parser/DBIx/Class.pm index 74d455ac3..623171e49 100644 --- a/lib/SQL/Translator/Parser/DBIx/Class.pm +++ b/lib/SQL/Translator/Parser/DBIx/Class.pm @@ -230,9 +230,9 @@ sub parse { $fk_constraint = not $source->_compare_relationship_keys(\@keys, \@primary); } - my ($otherrelname, $otherrelationship) = %{ $source->reverse_relationship_info($rel) }; my $cascade; + CASCADE_TYPE: for my $c (qw/delete update/) { if (exists $rel_info->{attrs}{"on_$c"}) { if ($fk_constraint) { @@ -243,8 +243,16 @@ sub parse { . "If you are sure that SQLT must generate a constraint for this relationship, add 'is_foreign_key_constraint => 1' to the attributes.\n"; } } - elsif (defined $otherrelationship and $otherrelationship->{attrs}{$c eq 'update' ? 'cascade_copy' : 'cascade_delete'}) { - $cascade->{$c} = 'CASCADE'; + else { + for my $revrelinfo (values %{ $source->reverse_relationship_info($rel) } ) { + ( ( $cascade->{$c} = 'CASCADE' ), next CASCADE_TYPE ) if ( + $revrelinfo->{attrs} + ->{ ($c eq 'update') + ? 'cascade_copy' + : 'cascade_delete' + } + ); + } } } diff --git a/t/lib/DBICTest/Schema/SelfRef.pm b/t/lib/DBICTest/Schema/SelfRef.pm index 41ae6d91b..8bcd24312 100644 --- a/t/lib/DBICTest/Schema/SelfRef.pm +++ b/t/lib/DBICTest/Schema/SelfRef.pm @@ -20,5 +20,6 @@ __PACKAGE__->add_columns( __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many( aliases => 'DBICTest::Schema::SelfRefAlias' => 'self_ref' ); +__PACKAGE__->has_many( aliases_no_copy => 'DBICTest::Schema::SelfRefAlias' => 'self_ref', { cascade_copy => 0 } ); 1; From 616ca57f8cd27f475da275bbef986fdd42d4069f Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 20 Aug 2016 11:31:36 +0200 Subject: [PATCH 234/262] Extract couple more stateless functions from DBIHacks (like 497d0451) Zero functional changes --- lib/DBIx/Class/ResultSet.pm | 16 +- lib/DBIx/Class/ResultSource.pm | 4 +- lib/DBIx/Class/ResultSource/FromSpec/Util.pm | 140 ++++++++++++++++ lib/DBIx/Class/SQLMaker/Util.pm | 2 +- lib/DBIx/Class/Storage/DBI.pm | 4 +- lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm | 5 +- .../Class/Storage/DBI/ADO/MS_Jet/Cursor.pm | 6 +- .../Storage/DBI/ADO/Microsoft_SQL_Server.pm | 4 +- .../DBI/ADO/Microsoft_SQL_Server/Cursor.pm | 7 +- lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm | 5 +- .../Class/Storage/DBI/SQLAnywhere/Cursor.pm | 7 +- lib/DBIx/Class/Storage/DBIHacks.pm | 154 +++--------------- xt/extra/internals/namespaces_cleaned.t | 1 + 13 files changed, 204 insertions(+), 151 deletions(-) create mode 100644 lib/DBIx/Class/ResultSource/FromSpec/Util.pm diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 920c7130f..a0305c8ca 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -14,6 +14,7 @@ use DBIx::Class::_Util qw( fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION ); use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); +use DBIx::Class::ResultSource::FromSpec::Util 'find_join_path_to_alias'; BEGIN { # De-duplication in _merge_attr() is disabled, but left in for reference @@ -2220,6 +2221,7 @@ sub populate { # At this point assume either hashes or arrays my $rsrc = $self->result_source; + my $storage = $rsrc->schema->storage; if(defined wantarray) { my (@results, $guard); @@ -2228,7 +2230,7 @@ sub populate { # column names only, nothing to do return if @$data == 1; - $guard = $rsrc->schema->storage->txn_scope_guard + $guard = $storage->txn_scope_guard if @$data > 2; @results = map @@ -2238,7 +2240,7 @@ sub populate { } else { - $guard = $rsrc->schema->storage->txn_scope_guard + $guard = $storage->txn_scope_guard if @$data > 1; @results = map { $self->new_result($_)->insert } @$data; @@ -2452,13 +2454,13 @@ sub populate { ### start work my $guard; - $guard = $rsrc->schema->storage->txn_scope_guard + $guard = $storage->txn_scope_guard if $slices_with_rels; ### main source data # FIXME - need to switch entirely to a coderef-based thing, # so that large sets aren't copied several times... I think - $rsrc->schema->storage->_insert_bulk( + $storage->_insert_bulk( $rsrc, [ @$colnames, sort keys %$rs_data ], [ map { @@ -3269,13 +3271,11 @@ sub related_resultset { my $attrs = $self->_chain_relationship($rel); - my $storage = $rsrc->schema->storage; - # Previously this atribute was deleted (instead of being set as it is now) # Doing so seems to be harmless in all available test permutations # See also 01d59a6a6 and mst's comment below # - $attrs->{alias} = $storage->relname_to_table_alias( + $attrs->{alias} = $rsrc->schema->storage->relname_to_table_alias( $rel, $attrs->{seen_join}{$rel} ); @@ -3299,7 +3299,7 @@ sub related_resultset { # the top of the stack, and if not - make sure the chain is inner-joined down # to the root. # - my $switch_branch = $storage->_find_join_path_to_node( + my $switch_branch = find_join_path_to_alias( $attrs->{from}, $attrs->{alias}, ); diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 0c0cb9d5e..ee5704fae 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -22,6 +22,7 @@ use DBIx::Class::_Util qw( refdesc emit_loud_diag ); use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; use SQL::Abstract 'is_literal_value'; use Devel::GlobalDestruction; use Scalar::Util qw( blessed weaken isweak refaddr ); @@ -2285,7 +2286,6 @@ sub _resolve_relationship_condition { ; my $rel_rsrc = $self->related_source($args->{rel_name}); - my $storage = $self->schema->storage; if (exists $args->{foreign_values}) { @@ -2583,7 +2583,7 @@ sub _resolve_relationship_condition { # there is no way to know who is right and who is left in a cref # therefore a full blown resolution call, and figure out the # direction a bit further below - $colinfos ||= $storage->_resolve_column_info([ + $colinfos ||= fromspec_columns_info([ { -alias => $args->{self_alias}, -rsrc => $self }, { -alias => $args->{foreign_alias}, -rsrc => $rel_rsrc }, ]); diff --git a/lib/DBIx/Class/ResultSource/FromSpec/Util.pm b/lib/DBIx/Class/ResultSource/FromSpec/Util.pm new file mode 100644 index 000000000..47106d7ec --- /dev/null +++ b/lib/DBIx/Class/ResultSource/FromSpec/Util.pm @@ -0,0 +1,140 @@ +package #hide from PAUSE + DBIx::Class::ResultSource::FromSpec::Util; + +use strict; +use warnings; + +use base 'Exporter'; +our @EXPORT_OK = qw( + fromspec_columns_info + find_join_path_to_alias +); + +use Scalar::Util 'blessed'; + +# Takes $fromspec, \@column_names +# +# returns { $column_name => \%column_info, ... } for fully qualified and +# where possible also unqualified variants +# also note: this adds -result_source => $rsrc to the column info +# +# If no columns_names are supplied returns info about *all* columns +# for all sources +sub fromspec_columns_info { + my ($fromspec, $colnames) = @_; + + return {} if $colnames and ! @$colnames; + + my $sources = ( + # this is compat mode for insert/update/delete which do not deal with aliases + ( + blessed($fromspec) + and + $fromspec->isa('DBIx::Class::ResultSource') + ) ? +{ me => $fromspec } + + # not a known fromspec - no columns to resolve: return directly + : ref($fromspec) ne 'ARRAY' ? return +{} + + : +{ + # otherwise decompose into alias/rsrc pairs + map + { + ( $_->{-rsrc} and $_->{-alias} ) + ? ( @{$_}{qw( -alias -rsrc )} ) + : () + } + map + { + ( ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH' ) ? $_->[0] + : ( ref $_ eq 'HASH' ) ? $_ + : () + } + @$fromspec + } + ); + + $_ = { rsrc => $_, colinfos => $_->columns_info } + for values %$sources; + + my (%seen_cols, @auto_colnames); + + # compile a global list of column names, to be able to properly + # disambiguate unqualified column names (if at all possible) + for my $alias (keys %$sources) { + ( + ++$seen_cols{$_}{$alias} + and + ! $colnames + and + push @auto_colnames, "$alias.$_" + ) for keys %{ $sources->{$alias}{colinfos} }; + } + + $colnames ||= [ + @auto_colnames, + ( grep { keys %{$seen_cols{$_}} == 1 } keys %seen_cols ), + ]; + + my %return; + for (@$colnames) { + my ($colname, $source_alias) = reverse split /\./, $_; + + my $assumed_alias = + $source_alias + || + # if the column was seen exactly once - we know which rsrc it came from + ( + $seen_cols{$colname} + and + keys %{$seen_cols{$colname}} == 1 + and + ( %{$seen_cols{$colname}} )[0] + ) + || + next + ; + + DBIx::Class::Exception->throw( + "No such column '$colname' on source " . $sources->{$assumed_alias}{rsrc}->source_name + ) unless $seen_cols{$colname}{$assumed_alias}; + + $return{$_} = { + %{ $sources->{$assumed_alias}{colinfos}{$colname} }, + -result_source => $sources->{$assumed_alias}{rsrc}, + -source_alias => $assumed_alias, + -fq_colname => "$assumed_alias.$colname", + -colname => $colname, + }; + + $return{"$assumed_alias.$colname"} = $return{$_} + unless $source_alias; + } + + \%return; +} + +sub find_join_path_to_alias { + my ($fromspec, $target_alias) = @_; + + # subqueries and other oddness are naturally not supported + return undef if ( + ref $fromspec ne 'ARRAY' + || + ref $fromspec->[0] ne 'HASH' + || + ! defined $fromspec->[0]{-alias} + ); + + # no path - the head *is* the alias + return [] if $fromspec->[0]{-alias} eq $target_alias; + + for my $i (1 .. $#$fromspec) { + return $fromspec->[$i][0]{-join_path} if ( ($fromspec->[$i][0]{-alias}||'') eq $target_alias ); + } + + # something else went quite wrong + return undef; +} + +1; diff --git a/lib/DBIx/Class/SQLMaker/Util.pm b/lib/DBIx/Class/SQLMaker/Util.pm index f029e24a9..430cc2b5b 100644 --- a/lib/DBIx/Class/SQLMaker/Util.pm +++ b/lib/DBIx/Class/SQLMaker/Util.pm @@ -346,7 +346,7 @@ sub _normalize_cond_unroll_pairs { if (ref $rhs eq 'HASH' and ! keys %$rhs) { # FIXME - SQLA seems to be doing... nothing...? } - # normalize top level -ident, for saner extract_fixed_condition_columns code + # normalize top level -ident, for saner extract_equality_conditions() code elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-ident}) { push @conds, { $lhs => { '=', $rhs } }; } diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 8d704bd82..7be4202a3 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -11,6 +11,7 @@ use DBIx::Class::Carp; use Scalar::Util qw/refaddr weaken reftype blessed/; use Context::Preserve 'preserve_context'; use SQL::Abstract qw(is_plain_value is_literal_value); +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; use DBIx::Class::_Util qw( quote_sub perlstring serialize dump_value dbic_internal_try dbic_internal_catch @@ -1775,7 +1776,8 @@ sub _resolve_bindattrs { my $resolve_bindinfo = sub { #my $infohash = shift; - $colinfos ||= { %{ $self->_resolve_column_info($ident) } }; + # shallow copy to preempt autoviv + $colinfos ||= { %{ fromspec_columns_info($ident) } }; my $ret; if (my $col = $_[0]->{dbic_colname}) { diff --git a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm index c7cb5c3fe..fbcd0eadc 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm @@ -2,12 +2,15 @@ package DBIx::Class::Storage::DBI::ADO::MS_Jet; use strict; use warnings; + use base qw/ DBIx::Class::Storage::DBI::ADO DBIx::Class::Storage::DBI::ACCESS /; use mro 'c3'; + use DBIx::Class::Storage::DBI::ADO::CursorUtils '_normalize_guids'; +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; use namespace::clean; __PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor'); @@ -104,7 +107,7 @@ sub select_single { return @row unless $self->cursor_class->isa('DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor'); - my $col_infos = $self->_resolve_column_info($ident); + my $col_infos = fromspec_columns_info($ident); _normalize_guids($select, $col_infos, \@row, $self); diff --git a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm index 8b1a78290..89ab579f4 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm @@ -4,7 +4,9 @@ use strict; use warnings; use base 'DBIx::Class::Storage::DBI::Cursor'; use mro 'c3'; + use DBIx::Class::Storage::DBI::ADO::CursorUtils '_normalize_guids'; +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; use namespace::clean; =head1 NAME @@ -41,7 +43,7 @@ sub next { _normalize_guids( $self->args->[1], - $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]), + $self->{_colinfos} ||= fromspec_columns_info($self->args->[0]), \@row, $self->storage ); @@ -56,7 +58,7 @@ sub all { _normalize_guids( $self->args->[1], - $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]), + $self->{_colinfos} ||= fromspec_columns_info($self->args->[0]), $_, $self->storage ) for @rows; diff --git a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm index ac42a1eeb..33a3e1306 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm @@ -8,8 +8,10 @@ use base qw/ DBIx::Class::Storage::DBI::MSSQL /; use mro 'c3'; + use DBIx::Class::Carp; use DBIx::Class::Storage::DBI::ADO::CursorUtils qw/_normalize_guids _strip_trailing_binary_nulls/; +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; use namespace::clean; __PACKAGE__->cursor_class( @@ -140,7 +142,7 @@ sub select_single { 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor' ); - my $col_infos = $self->_resolve_column_info($ident); + my $col_infos = fromspec_columns_info($ident); _normalize_guids($select, $col_infos, \@row, $self); diff --git a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm index 6253ee6a5..525526bea 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm @@ -2,9 +2,12 @@ package DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor; use strict; use warnings; + use base 'DBIx::Class::Storage::DBI::Cursor'; use mro 'c3'; + use DBIx::Class::Storage::DBI::ADO::CursorUtils qw/_normalize_guids _strip_trailing_binary_nulls/; +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; use namespace::clean; =head1 NAME @@ -42,7 +45,7 @@ sub next { my @row = $self->next::method(@_); - $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]); + $self->{_colinfos} ||= fromspec_columns_info($self->args->[0]); _normalize_guids( $self->args->[1], @@ -66,7 +69,7 @@ sub all { my @rows = $self->next::method(@_); - $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]); + $self->{_colinfos} ||= fromspec_columns_info($self->args->[0]); for (@rows) { _normalize_guids( diff --git a/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm b/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm index e9bc10220..9cb830663 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm @@ -4,6 +4,9 @@ use strict; use warnings; use base qw/DBIx::Class::Storage::DBI::UniqueIdentifier/; use mro 'c3'; +use DBIx::Class::_Util 'dbic_internal_try'; +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; +use namespace::clean; __PACKAGE__->mk_group_accessors(simple => qw/_identity/); __PACKAGE__->sql_limit_dialect ('RowNumberOver'); @@ -110,7 +113,7 @@ sub select_single { my ($ident, $select) = @_; - my $col_info = $self->_resolve_column_info($ident); + my $col_info = fromspec_columns_info($ident); for my $select_idx (0..$#$select) { my $selected = $select->[$select_idx]; diff --git a/lib/DBIx/Class/Storage/DBI/SQLAnywhere/Cursor.pm b/lib/DBIx/Class/Storage/DBI/SQLAnywhere/Cursor.pm index a341b20f4..8fb08a956 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLAnywhere/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLAnywhere/Cursor.pm @@ -5,6 +5,9 @@ use warnings; use base 'DBIx::Class::Storage::DBI::Cursor'; use mro 'c3'; +use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; +use namespace::clean; + =head1 NAME DBIx::Class::Storage::DBI::SQLAnywhere::Cursor - GUID Support for SQL Anywhere @@ -61,7 +64,7 @@ sub next { $unpack_guids->( $self->args->[1], - $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]), + $self->{_colinfos} ||= fromspec_columns_info($self->args->[0]), \@row, $self->storage ); @@ -76,7 +79,7 @@ sub all { $unpack_guids->( $self->args->[1], - $self->{_colinfos} ||= $self->storage->_resolve_column_info($self->args->[0]), + $self->{_colinfos} ||= fromspec_columns_info($self->args->[0]), $_, $self->storage ) for @rows; diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm index e9cbdd69a..b85fa78c3 100644 --- a/lib/DBIx/Class/Storage/DBIHacks.pm +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -33,6 +33,10 @@ use DBIx::Class::_Util qw( dump_value fail_on_internal_call ); use DBIx::Class::SQLMaker::Util 'extract_equality_conditions'; +use DBIx::Class::ResultSource::FromSpec::Util qw( + fromspec_columns_info + find_join_path_to_alias +); use DBIx::Class::Carp; use namespace::clean; @@ -167,7 +171,7 @@ sub _adjust_select_args_for_complex_prefetch { unless $root_node; # use the heavy duty resolver to take care of aliased/nonaliased naming - my $colinfo = $self->_resolve_column_info($inner_attrs->{from}); + my $colinfo = fromspec_columns_info($inner_attrs->{from}); my $selected_root_columns; for my $i (0 .. $#{$outer_attrs->{select}}) { @@ -444,7 +448,7 @@ sub _resolve_aliastypes_from_select_args { } # get a column to source/alias map (including unambiguous unqualified ones) - my $colinfo = $self->_resolve_column_info ($attrs->{from}); + my $colinfo = fromspec_columns_info($attrs->{from}); # set up a botched SQLA my $sql_maker = $self->sql_maker; @@ -633,7 +637,7 @@ sub _resolve_aliastypes_from_select_args { sub _group_over_selection { my ($self, $attrs) = @_; - my $colinfos = $self->_resolve_column_info ($attrs->{from}); + my $colinfos = fromspec_columns_info($attrs->{from}); my (@group_by, %group_index); @@ -769,130 +773,6 @@ sub _minmax_operator_for_datatype { $_[2] ? 'MAX' : 'MIN'; } -# Takes $ident, \@column_names -# -# returns { $column_name => \%column_info, ... } -# also note: this adds -result_source => $rsrc to the column info -# -# If no columns_names are supplied returns info about *all* columns -# for all sources -sub _resolve_column_info { - my ($self, $ident, $colnames) = @_; - - return {} if $colnames and ! @$colnames; - - my $sources = ( - # this is compat mode for insert/update/delete which do not deal with aliases - ( - blessed($ident) - and - $ident->isa('DBIx::Class::ResultSource') - ) ? +{ me => $ident } - - # not a known fromspec - no columns to resolve: return directly - : ref($ident) ne 'ARRAY' ? return +{} - - : +{ - # otherwise decompose into alias/rsrc pairs - map - { - ( $_->{-rsrc} and $_->{-alias} ) - ? ( @{$_}{qw( -alias -rsrc )} ) - : () - } - map - { - ( ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH' ) ? $_->[0] - : ( ref $_ eq 'HASH' ) ? $_ - : () - } - @$ident - } - ); - - $_ = { rsrc => $_, colinfos => $_->columns_info } - for values %$sources; - - my (%seen_cols, @auto_colnames); - - # compile a global list of column names, to be able to properly - # disambiguate unqualified column names (if at all possible) - for my $alias (keys %$sources) { - ( - ++$seen_cols{$_}{$alias} - and - ! $colnames - and - push @auto_colnames, "$alias.$_" - ) for keys %{ $sources->{$alias}{colinfos} }; - } - - $colnames ||= [ - @auto_colnames, - ( grep { keys %{$seen_cols{$_}} == 1 } keys %seen_cols ), - ]; - - my %return; - for (@$colnames) { - my ($colname, $source_alias) = reverse split /\./, $_; - - my $assumed_alias = - $source_alias - || - # if the column was seen exactly once - we know which rsrc it came from - ( - $seen_cols{$colname} - and - keys %{$seen_cols{$colname}} == 1 - and - ( %{$seen_cols{$colname}} )[0] - ) - || - next - ; - - $self->throw_exception( - "No such column '$colname' on source " . $sources->{$assumed_alias}{rsrc}->source_name - ) unless $seen_cols{$colname}{$assumed_alias}; - - $return{$_} = { - %{ $sources->{$assumed_alias}{colinfos}{$colname} }, - -result_source => $sources->{$assumed_alias}{rsrc}, - -source_alias => $assumed_alias, - -fq_colname => "$assumed_alias.$colname", - -colname => $colname, - }; - - $return{"$assumed_alias.$colname"} = $return{$_} - unless $source_alias; - } - - return \%return; -} - -sub _find_join_path_to_node { - my ($self, $from, $target_alias) = @_; - - # subqueries and other oddness are naturally not supported - return undef if ( - ref $from ne 'ARRAY' - || - ref $from->[0] ne 'HASH' - || - ! defined $from->[0]{-alias} - ); - - # no path - the head is the alias - return [] if $from->[0]{-alias} eq $target_alias; - - for my $i (1 .. $#$from) { - return $from->[$i][0]{-join_path} if ( ($from->[$i][0]{-alias}||'') eq $target_alias ); - } - - # something else went quite wrong - return undef; -} - sub _extract_order_criteria { my ($self, $order_by, $sql_maker) = @_; @@ -946,7 +826,7 @@ sub _order_by_is_stable { ( $where ? keys %{ extract_equality_conditions( $where ) } : () ), ) or return 0; - my $colinfo = $self->_resolve_column_info($ident, \@cols); + my $colinfo = fromspec_columns_info($ident, \@cols); return keys %$colinfo ? $self->_columns_comprise_identifying_set( $colinfo, \@cols ) @@ -976,7 +856,7 @@ sub _columns_comprise_identifying_set { sub _extract_colinfo_of_stable_main_source_order_by_portion { my ($self, $attrs) = @_; - my $nodes = $self->_find_join_path_to_node($attrs->{from}, $attrs->{alias}); + my $nodes = find_join_path_to_alias($attrs->{from}, $attrs->{alias}); return unless defined $nodes; @@ -991,7 +871,7 @@ sub _extract_colinfo_of_stable_main_source_order_by_portion { map { values %$_ } @$nodes, ) }; - my $colinfos = $self->_resolve_column_info($attrs->{from}); + my $colinfos = fromspec_columns_info($attrs->{from}); my ($colinfos_to_return, $seen_main_src_cols); @@ -1032,6 +912,20 @@ sub _extract_colinfo_of_stable_main_source_order_by_portion { ]) ? $colinfos_to_return : (); } +sub _resolve_column_info :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + carp_unique("_resolve_column_info() is deprecated, ask on IRC for a better alternative"); + + fromspec_columns_info( @_[1,2] ); +} + +sub _find_join_path_to_node :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + carp_unique("_find_join_path_to_node() is deprecated, ask on IRC for a better alternative"); + + find_join_path_to_alias( @_[1,2] ); +} + sub _collapse_cond :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; carp_unique("_collapse_cond() is deprecated, ask on IRC for a better alternative"); diff --git a/xt/extra/internals/namespaces_cleaned.t b/xt/extra/internals/namespaces_cleaned.t index 89e2b54d0..eb255307f 100644 --- a/xt/extra/internals/namespaces_cleaned.t +++ b/xt/extra/internals/namespaces_cleaned.t @@ -80,6 +80,7 @@ my $skip_idx = { map { $_ => 1 } ( # utility classes, not part of the inheritance chain 'DBIx::Class::Optional::Dependencies', 'DBIx::Class::ResultSource::RowParser::Util', + 'DBIx::Class::ResultSource::FromSpec::Util', 'DBIx::Class::SQLMaker::Util', 'DBIx::Class::_Util', ) }; From d8516e922b021c1aa8b0626694cb472b5407573b Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 10 Aug 2016 10:12:22 +0200 Subject: [PATCH 235/262] Tighten up value inferrence in relationship resolution Read under -w --- lib/DBIx/Class/ResultSource.pm | 36 ++++++++++++++++++++++------------ t/relationship/core.t | 6 +++++- t/relationship/custom.t | 2 +- 3 files changed, 30 insertions(+), 14 deletions(-) diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index ee5704fae..8b01a8828 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -2495,12 +2495,12 @@ sub _resolve_relationship_condition { $ret = $subconds[0]; } else { - # we are discarding inferred values here... likely incorrect... - # then again - the entire thing is an OR, so we *can't* use them anyway for my $subcond ( @subconds ) { $self->throw_exception('Either all or none of the OR-condition members must resolve to a join-free condition') if ( $ret and ( $ret->{join_free_condition} xor $subcond->{join_free_condition} ) ); + # we are discarding inferred_values from individual 'OR' branches here + # see @nonvalues checks below $subcond->{$_} and push @{$ret->{$_}}, $subcond->{$_} for (qw(condition join_free_condition)); } } @@ -2535,31 +2535,43 @@ sub _resolve_relationship_condition { my $jfc_eqs = extract_equality_conditions( $jfc, 'consider_nulls' ); - if (keys %$jfc_eqs) { - - for (keys %$jfc) { + for (keys %$jfc) { + if( $_ =~ /^-/ ) { + push @nonvalues, { $_ => $jfc->{$_} }; + } + else { # $jfc is fully qualified by definition - my ($col) = $_ =~ /\.(.+)/; + my ($col) = $_ =~ /\.(.+)/ or carp_unique( + 'Internal error - extract_equality_conditions() returned a ' + . "non-fully-qualified key '$_'. *Please* file a bugreport " + . "including your definition of $exception_rel_id" + ); if (exists $jfc_eqs->{$_} and ($jfc_eqs->{$_}||'') ne UNRESOLVABLE_CONDITION) { $ret->{inferred_values}{$col} = $jfc_eqs->{$_}; } elsif ( !$args->{infer_values_based_on} or ! exists $args->{infer_values_based_on}{$col} ) { - push @nonvalues, $col; + push @nonvalues, { $_ => $jfc->{$_} }; } } - - # all or nothing - delete $ret->{inferred_values} if @nonvalues; } + + # all or nothing + delete $ret->{inferred_values} if @nonvalues; } # did the user explicitly ask if ($args->{infer_values_based_on}) { $self->throw_exception(sprintf ( - "Unable to complete value inferrence - custom $exception_rel_id returns conditions instead of values for column(s): %s", - map { "'$_'" } @nonvalues + "Unable to complete value inferrence - $exception_rel_id results in expression(s) instead of definitive values: %s", + do { + # FIXME - used for diag only, but still icky + my $sqlm = $self->schema->storage->sql_maker; + local $sqlm->{quote_char}; + local $sqlm->{_dequalify_idents} = 1; + ($sqlm->_recurse_where({ -and => \@nonvalues }))[0] + } )) if @nonvalues; diff --git a/t/relationship/core.t b/t/relationship/core.t index de6afd7c7..6ebf94fa4 100644 --- a/t/relationship/core.t +++ b/t/relationship/core.t @@ -266,7 +266,11 @@ is($undir_maps->count, 1, 'found 1 undirected map for artist 2'); { my $artist_to_mangle = $schema->resultset('Artist')->find(2); - $artist_to_mangle->set_from_related( artist_undirected_maps => { id1 => 42 } ); + throws_ok { + $artist_to_mangle->set_from_related( artist_undirected_maps => { id1 => 42 } ) + } qr/\QUnable to complete value inferrence - relationship 'artist_undirected_maps' on source 'Artist' results in expression(s) instead of definitive values: ( artistid = ? OR artistid IS NULL )/, + 'Expected exception on unresovable set_from_related' + ; ok( ! $artist_to_mangle->is_changed, 'Unresolvable set_from_related did not alter object' ); diff --git a/t/relationship/custom.t b/t/relationship/custom.t index 32c8cf8f2..264650576 100644 --- a/t/relationship/custom.t +++ b/t/relationship/custom.t @@ -162,7 +162,7 @@ lives_ok { # try to create_related a 80s cd throws_ok { $artist->create_related('cds_80s', { title => 'related creation 1' }); -} qr/\QUnable to complete value inferrence - custom relationship 'cds_80s' on source 'Artist' returns conditions instead of values for column(s): 'year'/, +} qr/\QUnable to complete value inferrence - relationship 'cds_80s' on source 'Artist' results in expression(s) instead of definitive values: ( year < ? AND year > ? )/, 'Create failed - complex cond'; # now supply an explicit arg overwriting the ambiguous cond From cc10d685d277eb9399e15e0b342fd44aaa0d1a7e Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 7 Jul 2015 22:14:42 +0200 Subject: [PATCH 236/262] Remove last internal use of the legacy _resolve_condition (find) Also fixes the overly coarse 'is it a HASH' check added in 49ca473e/096f4212 --- lib/DBIx/Class/ResultSet.pm | 33 ++++++++++++------- t/sqlmaker/bind_transport.t | 11 +++++++ .../diagnostics/find_via_unsupported_rel.t | 31 +++++++++++++++++ 3 files changed, 64 insertions(+), 11 deletions(-) create mode 100644 xt/extra/diagnostics/find_via_unsupported_rel.t diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index a0305c8ca..cf6e12956 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -9,6 +9,7 @@ use DBIx::Class::Carp; use DBIx::Class::ResultSetColumn; use DBIx::Class::ResultClass::HashRefInflator; use Scalar::Util qw( blessed reftype ); +use SQL::Abstract 'is_literal_value'; use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch dump_value emit_loud_diag fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION @@ -777,7 +778,6 @@ sub find { my $self = shift; my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); - my $rsrc = $self->result_source; my $constraint_name; if (exists $attrs->{key}) { @@ -790,6 +790,8 @@ sub find { # Parse out the condition from input my $call_cond; + my $rsrc = $self->result_source; + if (ref $_[0] eq 'HASH') { $call_cond = { %{$_[0]} }; } @@ -812,25 +814,34 @@ sub find { } # process relationship data if any + my $rel_list; + for my $key (keys %$call_cond) { if ( length ref($call_cond->{$key}) and - my $relinfo = $rsrc->relationship_info($key) + ( $rel_list ||= { map { $_ => 1 } $rsrc->relationships } ) + ->{$key} and - # implicitly skip has_many's (likely MC) + ! is_literal_value( $call_cond->{$key} ) + and + # implicitly skip has_many's (likely MC), via the delete() ( ref( my $val = delete $call_cond->{$key} ) ne 'ARRAY' ) ) { - my ($rel_cond, $crosstable) = $rsrc->_resolve_condition( - $relinfo->{cond}, $val, $key, $key - ); - $self->throw_exception("Complex condition via relationship '$key' is unsupported in find()") - if $crosstable or ref($rel_cond) ne 'HASH'; + # FIXME: it seems wrong that relationship conditions take precedence...? + $call_cond = { + %$call_cond, - # supplement condition - # relationship conditions take precedence (?) - @{$call_cond}{keys %$rel_cond} = values %$rel_cond; + %{ $rsrc->_resolve_relationship_condition( + rel_name => $key, + foreign_values => $val, + infer_values_based_on => {}, + + self_alias => "\xFE", # irrelevant + foreign_alias => "\xFF", # irrelevant + )->{inferred_values} }, + }; } } diff --git a/t/sqlmaker/bind_transport.t b/t/sqlmaker/bind_transport.t index aacd59c79..93b3c1655 100644 --- a/t/sqlmaker/bind_transport.t +++ b/t/sqlmaker/bind_transport.t @@ -18,6 +18,17 @@ my ($ROWS, $OFFSET) = ( my $schema = DBICTest->init_schema(); +$schema->is_executed_sql_bind( + sub { $schema->resultset('Artist')->find( Math::BigInt->new(42) ) }, + [ + [ + 'SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE me.artistid = ?', + [ { dbic_colname => "me.artistid", sqlt_datatype => "integer" } + => Math::BigInt->new(42) ], + ] + ] +); + my $rs = $schema->resultset('CD')->search({ -and => [ 'me.artist' => { '!=', '666' }, 'me.artist' => { '!=', \[ '?', [ _ne => 'bar' ] ] }, diff --git a/xt/extra/diagnostics/find_via_unsupported_rel.t b/xt/extra/diagnostics/find_via_unsupported_rel.t new file mode 100644 index 000000000..10328e23d --- /dev/null +++ b/xt/extra/diagnostics/find_via_unsupported_rel.t @@ -0,0 +1,31 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +use DBICTest; + +my $schema = DBICTest->init_schema( no_deploy => 1 ); + +my $artist = $schema->resultset('Artist')->new_result({ artistid => 1 }); + +throws_ok { + $schema->resultset('ArtistUndirectedMap')->find({ + mapped_artists => $artist, + }); +} qr/\QUnable to complete value inferrence - relationship 'mapped_artists' on source 'ArtistUndirectedMap' results in expression(s) instead of definitive values: ( id1 = ? OR id2 = ? )/, + 'proper exception on OR relationship inferrence' +; + +throws_ok { + $schema->resultset('Artwork_to_Artist')->find({ + artist_limited_rank_opaque => $artist + }) +} qr/\QRelationship 'artist_limited_rank_opaque' on source 'Artwork_to_Artist' does not resolve to a 'foreign_values'-based reversed-join-free condition fragment/, + 'proper exception on ipaque custom cond' +; + +done_testing; From 3aac91f35f319b3bf6bad743d956f037ba857012 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 10 Aug 2016 18:07:50 +0200 Subject: [PATCH 237/262] Explicitly normalize results of relationship resolution Done as a separate commit to aid bisecting (in case it turns out problematic) --- lib/DBIx/Class/ResultSource.pm | 39 ++++++++++++++++++++++++++-------- 1 file changed, 30 insertions(+), 9 deletions(-) diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 8b01a8828..c7c741cde 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -2510,6 +2510,19 @@ sub _resolve_relationship_condition { $self->throw_exception ("Can't handle condition $rel_info->{cond} for $exception_rel_id yet :("); } + + # Explicit normalization pass + # ( nobody really knows what a CODE can return ) + # Explicitly leave U_C alone - it would be normalized + # to an { -and => [ U_C ] } + defined $ret->{$_} + and + $ret->{$_} ne UNRESOLVABLE_CONDITION + and + $ret->{$_} = normalize_sqla_condition($ret->{$_}) + for qw(condition join_free_condition); + + if ( $args->{require_join_free_condition} and @@ -2529,18 +2542,19 @@ sub _resolve_relationship_condition { $ret->{join_free_condition} and $ret->{join_free_condition} ne UNRESOLVABLE_CONDITION - and - my $jfc = normalize_sqla_condition( $ret->{join_free_condition} ) ) { - my $jfc_eqs = extract_equality_conditions( $jfc, 'consider_nulls' ); + my $jfc_eqs = extract_equality_conditions( + $ret->{join_free_condition}, + 'consider_nulls' + ); - for (keys %$jfc) { + for( keys %{ $ret->{join_free_condition} } ) { if( $_ =~ /^-/ ) { - push @nonvalues, { $_ => $jfc->{$_} }; + push @nonvalues, { $_ => $ret->{join_free_condition}{$_} }; } else { - # $jfc is fully qualified by definition + # a join_free_condoition is fully qualified by definition my ($col) = $_ =~ /\.(.+)/ or carp_unique( 'Internal error - extract_equality_conditions() returned a ' . "non-fully-qualified key '$_'. *Please* file a bugreport " @@ -2551,7 +2565,7 @@ sub _resolve_relationship_condition { $ret->{inferred_values}{$col} = $jfc_eqs->{$_}; } elsif ( !$args->{infer_values_based_on} or ! exists $args->{infer_values_based_on}{$col} ) { - push @nonvalues, { $_ => $jfc->{$_} }; + push @nonvalues, { $_ => $ret->{join_free_condition}{$_} }; } } } @@ -2633,8 +2647,15 @@ sub _resolve_relationship_condition { } # FIXME - temporary, to fool the idiotic check in SQLMaker::_join_condition - $ret->{condition} = { -and => [ $ret->{condition} ] } - unless $ret->{condition} eq UNRESOLVABLE_CONDITION; + $ret->{condition} = { -and => [ $ret->{condition} ] } unless ( + $ret->{condition} eq UNRESOLVABLE_CONDITION + or + ( + ref $ret->{condition} eq 'HASH' + and + grep { $_ =~ /^-/ } keys %{$ret->{condition}} + ) + ); $ret; } From 786c1cddede6675b9fc5fc46ae4e1e136ef2c392 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 10 Aug 2016 16:16:33 +0200 Subject: [PATCH 238/262] Stop accepting foreign_values => undef/rowobj in the resolver There are just a few spots that need this, things are complex enough as it is Introduces a subtle change in behavior - now results of $foreign->get_columns are scrutinized just as a plain hashref, and as a result the sanity checks are somewhat relaxed. There should not be any fallout due to this - tested on a wide range of downstreams Adjust some tested-for exceptions added in 7e5a0e7c as a result of the above Read under -w --- lib/DBIx/Class/Relationship/Base.pm | 30 ++++- lib/DBIx/Class/ResultSet.pm | 28 +++- lib/DBIx/Class/ResultSource.pm | 127 ++++++++++-------- t/cdbi/06-hasa.t | 2 +- t/cdbi/18-has_a.t | 2 +- .../resolve_relationship_condition.t | 4 +- 6 files changed, 131 insertions(+), 62 deletions(-) diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index 8e4b28015..f82d2ec5d 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -7,6 +7,7 @@ use base qw/DBIx::Class/; use Scalar::Util qw/weaken blessed/; use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION fail_on_internal_call ); +use DBIx::Class::Carp; use namespace::clean; =head1 NAME @@ -822,7 +823,34 @@ sub set_from_related { $self->set_columns( $self->result_source->_resolve_relationship_condition ( infer_values_based_on => {}, rel_name => $rel, - foreign_values => $f_obj, + foreign_values => ( + # maintain crazy set_from_related interface + # + ( ! defined $f_obj ) ? +{} + : ( ! defined blessed $f_obj ) ? $f_obj + : do { + + my $f_result_class = $self->result_source->related_source($rel)->result_class; + + unless( $f_obj->isa($f_result_class) ) { + + $self->throw_exception( + 'Object supplied to set_from_related() must inherit from ' + . "'$DBIx::Class::ResultSource::__expected_result_class_isa'" + ) unless $f_obj->isa( + $DBIx::Class::ResultSource::__expected_result_class_isa + ); + + carp_unique( + 'Object supplied to set_from_related() usually should inherit from ' + . "the related ResultClass ('$f_result_class'), perhaps you've made " + . 'a mistake?' + ); + } + + +{ $f_obj->get_columns }; + } + ), foreign_alias => $rel, self_alias => 'me', )->{inferred_values} ); diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index cf6e12956..7915e0759 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -818,6 +818,7 @@ sub find { for my $key (keys %$call_cond) { if ( + # either a structure or a result-ish object length ref($call_cond->{$key}) and ( $rel_list ||= { map { $_ => 1 } $rsrc->relationships } ) @@ -826,7 +827,7 @@ sub find { ! is_literal_value( $call_cond->{$key} ) and # implicitly skip has_many's (likely MC), via the delete() - ( ref( my $val = delete $call_cond->{$key} ) ne 'ARRAY' ) + ( ref( my $foreign_val = delete $call_cond->{$key} ) ne 'ARRAY' ) ) { # FIXME: it seems wrong that relationship conditions take precedence...? @@ -835,7 +836,30 @@ sub find { %{ $rsrc->_resolve_relationship_condition( rel_name => $key, - foreign_values => $val, + foreign_values => ( + (! defined blessed $foreign_val) ? $foreign_val : do { + + my $f_result_class = $rsrc->related_source($key)->result_class; + + unless( $foreign_val->isa($f_result_class) ) { + + $self->throw_exception( + 'Objects supplied to find() must inherit from ' + . "'$DBIx::Class::ResultSource::__expected_result_class_isa'" + ) unless $foreign_val->isa( + $DBIx::Class::ResultSource::__expected_result_class_isa + ); + + carp_unique( + "Objects supplied to find() via '$key' usually should inherit from " + . "the related ResultClass ('$f_result_class'), perhaps you've made " + . 'a mistake?' + ); + } + + +{ $foreign_val->get_columns }; + } + ), infer_values_based_on => {}, self_alias => "\xFE", # irrelevant diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index c7c741cde..bb5d92619 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -2160,6 +2160,10 @@ sub _resolve_condition { $is_objlike[$_] = 0; $res_args[$_] = '__gremlins__'; } + # more compat + elsif( $_ == 0 and $res_args[0]->isa( $__expected_result_class_isa ) ) { + $res_args[0] = { $res_args[0]->get_columns }; + } } else { $res_args[$_] ||= {}; @@ -2225,7 +2229,7 @@ Internals::SvREADONLY($UNRESOLVABLE_CONDITION => 1); ## self-explanatory API, modeled on the custom cond coderef: # rel_name => (scalar) # foreign_alias => (scalar) -# foreign_values => (either not supplied, or a hashref, or a foreign ResultObject (to be ->get_columns()ed), or plain undef ) +# foreign_values => (either not supplied or a hashref ) # self_alias => (scalar) # self_result_object => (either not supplied or a result object) # require_join_free_condition => (boolean, throws on failure to construct a JF-cond) @@ -2287,67 +2291,78 @@ sub _resolve_relationship_condition { my $rel_rsrc = $self->related_source($args->{rel_name}); - if (exists $args->{foreign_values}) { - - if (! defined $args->{foreign_values} ) { - # fallback: undef => {} - $args->{foreign_values} = {}; - } - elsif (defined blessed $args->{foreign_values}) { - - $self->throw_exception( "Objects supplied as 'foreign_values' ($args->{foreign_values}) must inherit from '$__expected_result_class_isa'" ) - unless $args->{foreign_values}->isa( $__expected_result_class_isa ); - - carp_unique( - "Objects supplied as 'foreign_values' ($args->{foreign_values}) " - . "usually should inherit from the related ResultClass ('@{[ $rel_rsrc->result_class ]}'), " - . "perhaps you've made a mistake invoking the condition resolver?" - ) unless $args->{foreign_values}->isa($rel_rsrc->result_class); - - $args->{foreign_values} = { $args->{foreign_values}->get_columns }; - } - elsif ( ref $args->{foreign_values} eq 'HASH' ) { - - # re-build {foreign_values} excluding identically named rels - if( keys %{$args->{foreign_values}} ) { + if ( + exists $args->{foreign_values} + and + ( + ref $args->{foreign_values} eq 'HASH' + or + $self->throw_exception( + "Argument 'foreign_values' must be a hash reference" + ) + ) + and + keys %{$args->{foreign_values}} + ) { - my ($col_idx, $rel_idx) = map - { { map { $_ => 1 } $rel_rsrc->$_ } } - qw( columns relationships ) - ; + my ($col_idx, $rel_idx) = map + { { map { $_ => 1 } $rel_rsrc->$_ } } + qw( columns relationships ) + ; - my $equivalencies = extract_equality_conditions( - $args->{foreign_values}, - 'consider nulls', - ); + my $equivalencies; - $args->{foreign_values} = { map { - # skip if relationship *and* a non-literal ref - # this means a multicreate stub was passed in + # re-build {foreign_values} excluding refs as follows + # ( hot codepath: intentionally convoluted ) + # + $args->{foreign_values} = { map { + ( + $_ !~ /^-/ + or + $self->throw_exception( + "The key '$_' supplied as part of 'foreign_values' during " + . 'relationship resolution must be a column name, not a function' + ) + ) + and + ( + # skip if relationship ( means a multicreate stub was passed in ) + # skip if literal ( can't infer anything about it ) + # or plain throw if nonequiv yet not literal + ( + length ref $args->{foreign_values}{$_} + and ( $rel_idx->{$_} - and - length ref $args->{foreign_values}{$_} - and - ! is_literal_value($args->{foreign_values}{$_}) + or + is_literal_value($args->{foreign_values}{$_}) + or + ( + ( + ! exists( + ( $equivalencies ||= extract_equality_conditions( $args->{foreign_values}, 'consider nulls' ) ) + ->{$_} + ) + or + ($equivalencies->{$_}||'') eq UNRESOLVABLE_CONDITION + ) + and + $self->throw_exception( + "Resolution of relationship '$args->{rel_name}' failed: " + . "supplied value for foreign column '$_' is not a direct " + . 'equivalence expression' + ) + ) ) - ? () - : ( $_ => ( - ! $col_idx->{$_} - ? $self->throw_exception( "Key '$_' supplied as 'foreign_values' is not a column on related source '@{[ $rel_rsrc->source_name ]}'" ) - : ( !exists $equivalencies->{$_} or ($equivalencies->{$_}||'') eq UNRESOLVABLE_CONDITION ) - ? $self->throw_exception( "Value supplied for '...{foreign_values}{$_}' is not a direct equivalence expression" ) - : $args->{foreign_values}{$_} - )) - } keys %{$args->{foreign_values}} }; - } - } - else { - $self->throw_exception( - "Argument 'foreign_values' must be either an object inheriting from '@{[ $rel_rsrc->result_class ]}', " - . "or a hash reference, or undef" - ); - } + ) ? () + : $col_idx->{$_} ? ( $_ => $args->{foreign_values}{$_} ) + : $self->throw_exception( + "The key '$_' supplied as part of 'foreign_values' during " + . 'relationship resolution is not a column on related source ' + . "'@{[ $rel_rsrc->source_name ]}'" + ) + ) + } keys %{$args->{foreign_values}} }; } my $ret; diff --git a/t/cdbi/06-hasa.t b/t/cdbi/06-hasa.t index 6d47c1232..abad17023 100644 --- a/t/cdbi/06-hasa.t +++ b/t/cdbi/06-hasa.t @@ -118,7 +118,7 @@ sub fail_with_bad_object { NumExplodingSheep => 23 } ); - } qr/isn't a Director/; + } qr/is not a column on related source 'Director'/; } package Foo; diff --git a/t/cdbi/18-has_a.t b/t/cdbi/18-has_a.t index a7b069c06..6304b2c93 100644 --- a/t/cdbi/18-has_a.t +++ b/t/cdbi/18-has_a.t @@ -110,7 +110,7 @@ is( Rating => 'R', NumExplodingSheep => 23 }); - } qr/isn't a Director/, "Can't have film as codirector"; + } qr/is not a column on related source 'Director'/, "Can't have film as codirector"; is $fail, undef, "We didn't get anything"; my $tastes_bad = YA::Film->create({ diff --git a/t/relationship/resolve_relationship_condition.t b/t/relationship/resolve_relationship_condition.t index a999dc6c2..801b1ea4f 100644 --- a/t/relationship/resolve_relationship_condition.t +++ b/t/relationship/resolve_relationship_condition.t @@ -27,7 +27,9 @@ for ( } qr/ \Qis not a column on related source 'CD'\E | - \QValue supplied for '...{foreign_values}{year}' is not a direct equivalence expression\E + \Qsupplied value for foreign column 'year' is not a direct equivalence expression\E + | + \QThe key '-\E \w+ \Q' supplied as part of 'foreign_values' during relationship resolution must be a column name, not a function\E /x; } From 09d2e66a5d5558ef9a19dc2ec510d5dafd2fb7d8 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 11 Aug 2016 11:06:59 +0200 Subject: [PATCH 239/262] Some cleanup of the resolve_relationship_condition callsites Zero functional changes Read under -w --- lib/DBIx/Class/Relationship/Accessor.pm | 27 ++-- lib/DBIx/Class/Relationship/Base.pm | 163 +++++++++++++---------- lib/DBIx/Class/ResultSet.pm | 14 +- lib/DBIx/Class/ResultSource.pm | 8 +- lib/DBIx/Class/ResultSource/RowParser.pm | 7 +- lib/DBIx/Class/Row.pm | 10 +- lib/DBIx/Class/_Util.pm | 7 +- lib/SQL/Translator/Parser/DBIx/Class.pm | 5 + 8 files changed, 142 insertions(+), 99 deletions(-) diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index 8fdeab2d0..9d4d378ce 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -46,21 +46,28 @@ sub add_relationship_accessor { else { my $rsrc = $self->result_source; - my $relcond = $rsrc->_resolve_relationship_condition( - rel_name => %1$s, - foreign_alias => %1$s, - self_alias => 'me', - self_result_object => $self, - ); + my $jfc; return undef if ( - $relcond->{join_free_condition} + + $rsrc->relationship_info(%1$s)->{attrs}{undef_on_null_fk} + and - $relcond->{join_free_condition} ne DBIx::Class::_Util::UNRESOLVABLE_CONDITION + + $jfc = ( $rsrc->_resolve_relationship_condition( + rel_name => %1$s, + foreign_alias => %1$s, + self_alias => 'me', + self_result_object => $self, + )->{join_free_condition} || {} ) + and - scalar grep { not defined $_ } values %%{ $relcond->{join_free_condition} || {} } + + $jfc ne DBIx::Class::_Util::UNRESOLVABLE_CONDITION + and - $rsrc->relationship_info(%1$s)->{attrs}{undef_on_null_fk} + + grep { not defined $_ } values %%$jfc ); my $val = $self->related_resultset( %1$s )->single; diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index f82d2ec5d..64536797c 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -6,7 +6,10 @@ use warnings; use base qw/DBIx::Class/; use Scalar::Util qw/weaken blessed/; -use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION fail_on_internal_call ); +use DBIx::Class::_Util qw( + UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR + fail_on_internal_call +); use DBIx::Class::Carp; use namespace::clean; @@ -514,83 +517,89 @@ sub related_resultset { my ($self, $rel) = @_; - return $self->{related_resultsets}{$rel} = do { + my $rsrc = $self->result_source; - my $rsrc = $self->result_source; + my $rel_info = $rsrc->relationship_info($rel) + or $self->throw_exception( "No such relationship '$rel'" ); - my $rel_info = $rsrc->relationship_info($rel) - or $self->throw_exception( "No such relationship '$rel'" ); + my $relcond_is_freeform = ref $rel_info->{cond} eq 'CODE'; - my $cond_res = $rsrc->_resolve_relationship_condition( - rel_name => $rel, - self_result_object => $self, + my $jfc = $rsrc->_resolve_relationship_condition( - # this may look weird, but remember that we are making a resultset - # out of an existing object, with the new source being at the head - # of the FROM chain. Having a 'me' alias is nothing but expected there - foreign_alias => 'me', - - self_alias => "!!!\xFF()!!!_SHOULD_NEVER_BE_SEEN_IN_USE_!!!()\xFF!!!", - - # not strictly necessary, but shouldn't hurt either - require_join_free_condition => !!(ref $rel_info->{cond} ne 'CODE'), - ); - - # keep in mind that the following if() block is part of a do{} - no return()s!!! - if ( - ! $cond_res->{join_free_condition} - and - ref $rel_info->{cond} eq 'CODE' - ) { - - # A WHOREIFFIC hack to reinvoke the entire condition resolution - # with the correct alias. Another way of doing this involves a - # lot of state passing around, and the @_ positions are already - # mapped out, making this crap a less icky option. - # - # The point of this exercise is to retain the spirit of the original - # $obj->search_related($rel) where the resulting rset will have the - # root alias as 'me', instead of $rel (as opposed to invoking - # $rs->search_related) - - # make the fake 'me' rel - local $rsrc->{_relationships}{me} = { - %{ $rsrc->{_relationships}{$rel} }, - _original_name => $rel, - }; - - my $obj_table_alias = lc($rsrc->source_name) . '__row'; - $obj_table_alias =~ s/\W+/_/g; + rel_name => $rel, + self_result_object => $self, - $rsrc->resultset->search( - $self->ident_condition($obj_table_alias), - { alias => $obj_table_alias }, - )->related_resultset('me')->search(undef, $rel_info->{attrs}) - } - else { - - # FIXME - this conditional doesn't seem correct - got to figure out - # at some point what it does. Also the entire UNRESOLVABLE_CONDITION - # business seems shady - we could simply not query *at all* - my $attrs; - if ( $cond_res->{join_free_condition} eq UNRESOLVABLE_CONDITION ) { - $attrs = { %{$rel_info->{attrs}} }; - my $reverse = $rsrc->reverse_relationship_info($rel); - foreach my $rev_rel (keys %$reverse) { - if ($reverse->{$rev_rel}{attrs}{accessor} && $reverse->{$rev_rel}{attrs}{accessor} eq 'multi') { - weaken($attrs->{related_objects}{$rev_rel}[0] = $self); - } else { - weaken($attrs->{related_objects}{$rev_rel} = $self); - } + # an extra sanity check guard + require_join_free_condition => ! $relcond_is_freeform, + + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, + + # this may look weird, but remember that we are making a resultset + # out of an existing object, with the new source being at the head + # of the FROM chain. Having a 'me' alias is nothing but expected there + foreign_alias => 'me', + + )->{join_free_condition}; + + my $rel_rset; + + if ( + ! $jfc + and + $relcond_is_freeform + ) { + + # A WHOREIFFIC hack to reinvoke the entire condition resolution + # with the correct alias. Another way of doing this involves a + # lot of state passing around, and the @_ positions are already + # mapped out, making this crap a less icky option. + # + # The point of this exercise is to retain the spirit of the original + # $obj->search_related($rel) where the resulting rset will have the + # root alias as 'me', instead of $rel (as opposed to invoking + # $rs->search_related) + + # make the fake 'me' rel + local $rsrc->{_relationships}{me} = { + %{ $rsrc->{_relationships}{$rel} }, + _original_name => $rel, + }; + + my $obj_table_alias = lc($rsrc->source_name) . '__row'; + $obj_table_alias =~ s/\W+/_/g; + + $rel_rset = $rsrc->resultset->search( + $self->ident_condition($obj_table_alias), + { alias => $obj_table_alias }, + )->related_resultset('me')->search(undef, $rel_info->{attrs}) + } + else { + + # FIXME - this conditional doesn't seem correct - got to figure out + # at some point what it does. Also the entire UNRESOLVABLE_CONDITION + # business seems shady - we could simply not query *at all* + my $attrs; + if ( $jfc eq UNRESOLVABLE_CONDITION ) { + $attrs = { %{$rel_info->{attrs}} }; + my $reverse = $rsrc->reverse_relationship_info($rel); + foreach my $rev_rel (keys %$reverse) { + if ($reverse->{$rev_rel}{attrs}{accessor} && $reverse->{$rev_rel}{attrs}{accessor} eq 'multi') { + weaken($attrs->{related_objects}{$rev_rel}[0] = $self); + } else { + weaken($attrs->{related_objects}{$rev_rel} = $self); } } - - $rsrc->related_source($rel)->resultset->search( - $cond_res->{join_free_condition}, - $attrs || $rel_info->{attrs}, - ); } - }; + + $rel_rset = $rsrc->related_source($rel)->resultset->search( + $jfc, + $attrs || $rel_info->{attrs}, + ); + } + + $self->{related_resultsets}{$rel} = $rel_rset; } =head2 search_related @@ -672,8 +681,11 @@ sub new_related { infer_values_based_on => $data, rel_name => $rel, self_result_object => $self, - foreign_alias => $rel, - self_alias => 'me', + + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, + )->{inferred_values} ); } @@ -851,8 +863,11 @@ sub set_from_related { +{ $f_obj->get_columns }; } ), - foreign_alias => $rel, - self_alias => 'me', + + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, + )->{inferred_values} ); return 1; diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 7915e0759..128b5546e 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -12,7 +12,8 @@ use Scalar::Util qw( blessed reftype ); use SQL::Abstract 'is_literal_value'; use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch dump_value emit_loud_diag - fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION + fail_on_internal_wantarray fail_on_internal_call + UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR ); use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); use DBIx::Class::ResultSource::FromSpec::Util 'find_join_path_to_alias'; @@ -862,8 +863,9 @@ sub find { ), infer_values_based_on => {}, - self_alias => "\xFE", # irrelevant - foreign_alias => "\xFF", # irrelevant + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, )->{inferred_values} }, }; } @@ -2531,8 +2533,10 @@ sub populate { $colinfo->{$rel}{fk_map} = { reverse %{ $rsrc->_resolve_relationship_condition( rel_name => $rel, - self_alias => "\xFE", # irrelevant - foreign_alias => "\xFF", # irrelevant + + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, )->{identity_map} || {} } }; } diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index bb5d92619..c8c8f2e4b 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -2392,11 +2392,11 @@ sub _resolve_relationship_condition { $self->throw_exception("A custom condition coderef can return at most 2 conditions, but $exception_rel_id returned extra values: @extra") if @extra; - if (my $jfc = $ret->{join_free_condition}) { + if( $ret->{join_free_condition} ) { $self->throw_exception ( "The join-free condition returned for $exception_rel_id must be a hash reference" - ) unless ref $jfc eq 'HASH'; + ) unless ref $ret->{join_free_condition} eq 'HASH'; my ($joinfree_alias, $joinfree_source); if (defined $args->{self_result_object}) { @@ -2422,7 +2422,7 @@ sub _resolve_relationship_condition { "The join-free condition returned for $exception_rel_id may only " . 'contain keys that are fully qualified column names of the corresponding source ' . "'$joinfree_alias' (instead it returned '$_')" - ) for keys %$jfc; + ) for keys %{$ret->{join_free_condition}}; ( defined blessed($_) @@ -2434,7 +2434,7 @@ sub _resolve_relationship_condition { . 'contain result objects as values - perhaps instead of invoking ' . '->$something you meant to return ->get_column($something)' ) - ) for values %$jfc; + ) for values %{$ret->{join_free_condition}}; } } diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index 6fe946f38..32fcf3172 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -10,6 +10,7 @@ use DBIx::Class::ResultSource::RowParser::Util qw( assemble_simple_parser assemble_collapsing_parser ); +use DBIx::Class::_Util 'DUMMY_ALIASPAIR'; use DBIx::Class::Carp; @@ -188,8 +189,10 @@ sub _resolve_collapse { rsrc => $self->related_source($rel), fk_map => $self->_resolve_relationship_condition( rel_name => $rel, - self_alias => "\xFE", # irrelevant - foreign_alias => "\xFF", # irrelevant + + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, )->{identity_map}, }; } diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 4188d1073..5adf4eaf3 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -6,7 +6,10 @@ use warnings; use base qw/DBIx::Class/; use Scalar::Util 'blessed'; -use DBIx::Class::_Util qw( dbic_internal_try fail_on_internal_call ); +use DBIx::Class::_Util qw( + dbic_internal_try fail_on_internal_call + DUMMY_ALIASPAIR +); use DBIx::Class::Carp; use SQL::Abstract qw( is_literal_value is_plain_value ); @@ -1195,8 +1198,9 @@ sub copy { rel_name => $rel_name, self_result_object => $new, - self_alias => "\xFE", # irrelevant - foreign_alias => "\xFF", # irrelevant, + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, )->{inferred_values} ) for $self->related_resultset($rel_name)->all; diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index b8f0b0668..6b71ceb1f 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -205,11 +205,16 @@ our @EXPORT_OK = qw( is_exception dbic_internal_try dbic_internal_catch visit_namespaces quote_sub qsub perlstring serialize deep_clone dump_value uniq parent_dir mkdir_p - UNRESOLVABLE_CONDITION + UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR ); use constant UNRESOLVABLE_CONDITION => \ '1 = 0'; +use constant DUMMY_ALIASPAIR => ( + foreign_alias => "!!!\xFF()!!!_DUMMY_FOREIGN_ALIAS_SHOULD_NEVER_BE_SEEN_IN_USE_!!!()\xFF!!!", + self_alias => "!!!\xFE()!!!_DUMMY_SELF_ALIAS_SHOULD_NEVER_BE_SEEN_IN_USE_!!!()\xFE!!!", +); + # Override forcing no_defer, and adding naming consistency checks our %refs_closed_over_by_quote_sub_installed_crefs; sub quote_sub { diff --git a/lib/SQL/Translator/Parser/DBIx/Class.pm b/lib/SQL/Translator/Parser/DBIx/Class.pm index 623171e49..2535783c8 100644 --- a/lib/SQL/Translator/Parser/DBIx/Class.pm +++ b/lib/SQL/Translator/Parser/DBIx/Class.pm @@ -177,6 +177,11 @@ sub parse { my $rel_info = $source->relationship_info($rel); # Ignore any rel cond that isn't a straight hash + # + # FIXME - this can be done *WAY* better via the recolcond resolver + # but no time to think through the implications for deploy() at + # the moment. Grep for {identity_map_matches_condition} for ideas + # how to improve this, and the /^\w+\.(\w+)$/ crap below next unless ref $rel_info->{cond} eq 'HASH'; my $relsource = dbic_internal_try { $source->related_source($rel) }; From ea3ee77d2d9e137b07ca4b2db14986e8310f4bec Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sun, 18 Sep 2016 12:28:18 +0200 Subject: [PATCH 240/262] Standardize indication of lack of join_free_condition after resolution There should be zero functional changes as a result --- lib/DBIx/Class/Relationship/Accessor.pm | 4 --- lib/DBIx/Class/Relationship/Base.pm | 41 ++++++++++++------------- lib/DBIx/Class/ResultSource.pm | 13 +++----- 3 files changed, 23 insertions(+), 35 deletions(-) diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index 9d4d378ce..42d7e3857 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -63,10 +63,6 @@ sub add_relationship_accessor { and - $jfc ne DBIx::Class::_Util::UNRESOLVABLE_CONDITION - - and - grep { not defined $_ } values %%$jfc ); diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index 64536797c..c4d4df592 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -545,11 +545,14 @@ sub related_resultset { my $rel_rset; - if ( - ! $jfc - and - $relcond_is_freeform - ) { + if( defined $jfc ) { + + $rel_rset = $rsrc->related_source($rel)->resultset->search( + $jfc, + $rel_info->{attrs}, + ); + } + elsif( $relcond_is_freeform ) { # A WHOREIFFIC hack to reinvoke the entire condition resolution # with the correct alias. Another way of doing this involves a @@ -577,25 +580,19 @@ sub related_resultset { } else { - # FIXME - this conditional doesn't seem correct - got to figure out - # at some point what it does. Also the entire UNRESOLVABLE_CONDITION - # business seems shady - we could simply not query *at all* - my $attrs; - if ( $jfc eq UNRESOLVABLE_CONDITION ) { - $attrs = { %{$rel_info->{attrs}} }; - my $reverse = $rsrc->reverse_relationship_info($rel); - foreach my $rev_rel (keys %$reverse) { - if ($reverse->{$rev_rel}{attrs}{accessor} && $reverse->{$rev_rel}{attrs}{accessor} eq 'multi') { - weaken($attrs->{related_objects}{$rev_rel}[0] = $self); - } else { - weaken($attrs->{related_objects}{$rev_rel} = $self); - } - } - } + my $attrs = { %{$rel_info->{attrs}} }; + my $reverse = $rsrc->reverse_relationship_info($rel); + + # FIXME - this loop doesn't seem correct - got to figure out + # at some point what exactly it does. + ( ( $reverse->{$_}{attrs}{accessor}||'') eq 'multi' ) + ? weaken( $attrs->{related_objects}{$_}[0] = $self ) + : weaken( $attrs->{related_objects}{$_} = $self ) + for keys %$reverse; $rel_rset = $rsrc->related_source($rel)->resultset->search( - $jfc, - $attrs || $rel_info->{attrs}, + UNRESOLVABLE_CONDITION, # guards potential use of the $rs in the future + $attrs, ); } diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index c8c8f2e4b..0d3bc344f 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -2487,7 +2487,7 @@ sub _resolve_relationship_condition { # FIXME - temporarly force-override delete $args->{require_join_free_condition}; - $ret->{join_free_condition} = UNRESOLVABLE_CONDITION; + delete $ret->{join_free_condition}; last; } } @@ -2497,7 +2497,6 @@ sub _resolve_relationship_condition { if (@{ $rel_info->{cond} } == 0) { $ret = { condition => UNRESOLVABLE_CONDITION, - join_free_condition => UNRESOLVABLE_CONDITION, }; } else { @@ -2541,7 +2540,7 @@ sub _resolve_relationship_condition { if ( $args->{require_join_free_condition} and - ( ! $ret->{join_free_condition} or $ret->{join_free_condition} eq UNRESOLVABLE_CONDITION ) + ! defined $ret->{join_free_condition} ) { $self->throw_exception( ucfirst sprintf "$exception_rel_id does not resolve to a %sjoin-free condition fragment", @@ -2553,11 +2552,7 @@ sub _resolve_relationship_condition { # we got something back - sanity check and infer values if we can my @nonvalues; - if ( - $ret->{join_free_condition} - and - $ret->{join_free_condition} ne UNRESOLVABLE_CONDITION - ) { + if( $ret->{join_free_condition} ) { my $jfc_eqs = extract_equality_conditions( $ret->{join_free_condition}, @@ -2569,7 +2564,7 @@ sub _resolve_relationship_condition { push @nonvalues, { $_ => $ret->{join_free_condition}{$_} }; } else { - # a join_free_condoition is fully qualified by definition + # a join_free_condition is fully qualified by definition my ($col) = $_ =~ /\.(.+)/ or carp_unique( 'Internal error - extract_equality_conditions() returned a ' . "non-fully-qualified key '$_'. *Please* file a bugreport " From a3ae79ed1009ae4679909f4ec7dc0327c1adaae8 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 10 Aug 2016 16:19:54 +0200 Subject: [PATCH 241/262] Add an extra RV to the relationship resolver A certain spot in the codebase check whether a relationship is "simple". This additional flag allows to consider coderef conditions as well, instead of simply punting with "not a HASH? - no can do" See next commit for the actual switchover While at it fix a subtle bug introduced in b5ce6748 - originally the helper is_literal_value recognized -ident as a valid literal. Later on during the migration into SQLA this logic was lost (I do not exactly recall the details), yet the DBIC side was never adjusted. All callsites were audited to make sure nothing else was missed. --- lib/DBIx/Class/ResultSource.pm | 93 ++++++++++++++++++++++++++++++++-- lib/DBIx/Class/SQLMaker.pm | 2 +- lib/DBIx/Class/_Util.pm | 1 + 3 files changed, 90 insertions(+), 6 deletions(-) diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 0d3bc344f..24403e69f 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -19,7 +19,7 @@ use DBIx::Class::Carp; use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try fail_on_internal_call - refdesc emit_loud_diag + refdesc emit_loud_diag dump_value ); use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; @@ -2238,6 +2238,7 @@ Internals::SvREADONLY($UNRESOLVABLE_CONDITION => 1); ## returns a hash # condition => (a valid *likely fully qualified* sqla cond structure) # identity_map => (a hashref of foreign-to-self *unqualified* column equality names) +# identity_map_matches_condition => (boolean, indicates whether the entire condition is expressed in the identity-map) # join_free_condition => (a valid *fully qualified* sqla cond structure, maybe unset) # inferred_values => (in case of an available join_free condition, this is a hashref of # *unqualified* column/value *EQUALITY* pairs, representing an amalgamation @@ -2591,29 +2592,51 @@ sub _resolve_relationship_condition { "Unable to complete value inferrence - $exception_rel_id results in expression(s) instead of definitive values: %s", do { # FIXME - used for diag only, but still icky - my $sqlm = $self->schema->storage->sql_maker; + my $sqlm = + dbic_internal_try { $self->schema->storage->sql_maker } + || + ( + require DBIx::Class::SQLMaker + and + DBIx::Class::SQLMaker->new + ) + ; local $sqlm->{quote_char}; local $sqlm->{_dequalify_idents} = 1; ($sqlm->_recurse_where({ -and => \@nonvalues }))[0] } )) if @nonvalues; - $ret->{inferred_values} ||= {}; $ret->{inferred_values}{$_} = $args->{infer_values_based_on}{$_} for keys %{$args->{infer_values_based_on}}; } + my $identity_map_incomplete; + # add the identities based on the main condition # (may already be there, since easy to calculate on the fly in the HASH case) if ( ! $ret->{identity_map} ) { my $col_eqs = extract_equality_conditions($ret->{condition}); + $identity_map_incomplete++ if ( + $ret->{condition} eq UNRESOLVABLE_CONDITION + or + ( + keys %{$ret->{condition}} + != + keys %$col_eqs + ) + ); + my $colinfos; for my $lhs (keys %$col_eqs) { + # start with the assumption it won't work + $identity_map_incomplete++; + next if $col_eqs->{$lhs} eq UNRESOLVABLE_CONDITION; # there is no way to know who is right and who is left in a cref @@ -2626,8 +2649,17 @@ sub _resolve_relationship_condition { next unless $colinfos->{$lhs}; # someone is engaging in witchcraft - if ( my $rhs_ref = is_literal_value( $col_eqs->{$lhs} ) ) { - + if( my $rhs_ref = + ( + ref $col_eqs->{$lhs} eq 'HASH' + and + keys %{$col_eqs->{$lhs}} == 1 + and + exists $col_eqs->{$lhs}{-ident} + ) + ? [ $col_eqs->{$lhs}{-ident} ] # repack to match the RV of is_literal_value + : is_literal_value( $col_eqs->{$lhs} ) + ) { if ( $colinfos->{$rhs_ref->[0]} and @@ -2637,6 +2669,9 @@ sub _resolve_relationship_condition { ? ( $ret->{identity_map}{$colinfos->{$lhs}{-colname}} = $colinfos->{$rhs_ref->[0]}{-colname} ) : ( $ret->{identity_map}{$colinfos->{$rhs_ref->[0]}{-colname}} = $colinfos->{$lhs}{-colname} ) ; + + # well, what do you know! + $identity_map_incomplete--; } } elsif ( @@ -2656,6 +2691,10 @@ sub _resolve_relationship_condition { } } + $ret->{identity_map_matches_condition} = ($identity_map_incomplete ? 0 : 1) + if $ret->{identity_map}; + + # FIXME - temporary, to fool the idiotic check in SQLMaker::_join_condition $ret->{condition} = { -and => [ $ret->{condition} ] } unless ( $ret->{condition} eq UNRESOLVABLE_CONDITION @@ -2667,6 +2706,50 @@ sub _resolve_relationship_condition { ) ); + + if( DBIx::Class::_ENV_::ASSERT_NO_INCONSISTENT_RELATIONSHIP_RESOLUTION ) { + + my $sqlm = + dbic_internal_try { $self->schema->storage->sql_maker } + || + ( + require DBIx::Class::SQLMaker + and + DBIx::Class::SQLMaker->new + ) + ; + + local $sqlm->{_dequalify_idents} = 1; + + my ($cond_as_sql, $identmap_as_sql) = map + { join ' : ', map { defined $_ ? $_ : '{UNDEF}' } $sqlm->_recurse_where($_) } + ( + $ret->{condition}, + + { map { + # inverse because of how the idmap is declared + $ret->{identity_map}{$_} => { -ident => $_ } + } keys %{$ret->{identity_map}} }, + ) + ; + + emit_loud_diag( + confess => 1, + msg => sprintf ( + "Resolution of %s produced inconsistent metadata:\n\n" + . "returned value of 'identity_map_matches_condition': %s\n" + . "returned 'condition' rendered as de-qualified SQL: %s\n" + . "returned 'identity_map' rendered as de-qualified SQL: %s\n\n" + . "The condition declared on the misclassified relationship is: %s ", + $exception_rel_id, + ( $ret->{identity_map_matches_condition} || 0 ), + $cond_as_sql, + $identmap_as_sql, + dump_value( $rel_info->{cond} ), + ), + ) if ( $ret->{identity_map_matches_condition} xor ( $cond_as_sql eq $identmap_as_sql ) ); + } + $ret; } diff --git a/lib/DBIx/Class/SQLMaker.pm b/lib/DBIx/Class/SQLMaker.pm index ea69e076a..6557f2e07 100644 --- a/lib/DBIx/Class/SQLMaker.pm +++ b/lib/DBIx/Class/SQLMaker.pm @@ -191,7 +191,7 @@ sub _assert_bindval_matches_bindtype () { 1 }; # poor man's de-qualifier sub _quote { - $_[0]->next::method( ( $_[0]{_dequalify_idents} and ! ref $_[1] ) + $_[0]->next::method( ( $_[0]{_dequalify_idents} and defined $_[1] and ! ref $_[1] ) ? $_[1] =~ / ([^\.]+) $ /x : $_[1] ); diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 6b71ceb1f..08f3b6901 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -52,6 +52,7 @@ BEGIN { DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE DBIC_ASSERT_NO_FAILING_SANITY_CHECKS + DBIC_ASSERT_NO_INCONSISTENT_RELATIONSHIP_RESOLUTION DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE ) From 86be9bcb90213db633791fcce074b7268765f615 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 11 Aug 2016 11:06:59 +0200 Subject: [PATCH 242/262] Switch reverse_relationship_info() to the relcond resolver Prompted by a PR from @mzealey, a code audit showed the entire implementation to be severely lacking. Switched to proper relationship resolution, with the added benefit of support for custom conds whenever possible. As of this commit every single relationship introspection now goes through a central point: _resolve_relationship_condition(). No more random ... eq 'HASH' checks all over the place. There should be zero functional changes as a result (aside from better custom cond introspection) --- .mailmap | 1 + AUTHORS | 1 + lib/DBIx/Class/ResultSource.pm | 167 +++++++++++++++-------- lib/DBIx/Class/ResultSource/RowParser.pm | 13 +- lib/DBIx/Class/_Util.pm | 30 +++- lib/SQL/Translator/Parser/DBIx/Class.pm | 16 +-- 6 files changed, 155 insertions(+), 73 deletions(-) diff --git a/.mailmap b/.mailmap index 3a450400c..031804bb6 100644 --- a/.mailmap +++ b/.mailmap @@ -37,6 +37,7 @@ Jason M. Mills Jonathan Chu Jose Luis Martinez Kent Fredric +Mark Zealey Matt Phillips Matt Phillips Michael Reddick diff --git a/AUTHORS b/AUTHORS index 36e39912f..9e4a9626b 100644 --- a/AUTHORS +++ b/AUTHORS @@ -97,6 +97,7 @@ ilmari: Dagfinn Ilmari Mannsåker ingy: Ingy döt Net initself: Mike Baas ironcamel: Naveed Massjouni +jalh: Mark Zealey jasonmay: Jason May jawnsy: Jonathan Yu jegade: Jens Gassmann diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 24403e69f..2dec41688 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -17,9 +17,9 @@ use base 'DBIx::Class::ResultSource::RowParser'; use DBIx::Class::Carp; use DBIx::Class::_Util qw( - UNRESOLVABLE_CONDITION + UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR dbic_internal_try fail_on_internal_call - refdesc emit_loud_diag dump_value + refdesc emit_loud_diag dump_value serialize bag_eq ); use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); use DBIx::Class::ResultSource::FromSpec::Util 'fromspec_columns_info'; @@ -1824,85 +1824,111 @@ L. sub reverse_relationship_info { my ($self, $rel) = @_; - my $rel_info = $self->relationship_info($rel) - or $self->throw_exception("No such relationship '$rel'"); + # This may be a partial schema or something else equally esoteric + # in which case this will throw + # + my $other_rsrc = $self->related_source($rel); - my $ret = {}; + # Some custom rels may not resolve without a $schema + # + my $our_resolved_relcond = dbic_internal_try { + $self->_resolve_relationship_condition( + rel_name => $rel, - return $ret unless ((ref $rel_info->{cond}) eq 'HASH'); + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, + ) + }; - my $stripped_cond = $self->__strip_relcond ($rel_info->{cond}); + # only straight-equality is compared + return {} + unless $our_resolved_relcond->{identity_map_matches_condition}; - my $registered_source_name = $self->source_name; + my( $our_registered_source_name, $our_result_class) = + ( $self->source_name, $self->result_class ); - # this may be a partial schema or something else equally esoteric - my $other_rsrc = $self->related_source($rel); + my $ret = {}; # Get all the relationships for that source that related to this source # whose foreign column set are our self columns on $rel and whose self # columns are our foreign columns on $rel foreach my $other_rel ($other_rsrc->relationships) { + # this will happen when we have a self-referential class + next if ( + $other_rel eq $rel + and + $self == $other_rsrc + ); + # only consider stuff that points back to us # "us" here is tricky - if we are in a schema registration, we want # to use the source_names, otherwise we will use the actual classes - # the schema may be partial - my $roundtrip_rsrc = dbic_internal_try { $other_rsrc->related_source($other_rel) } - or next; + my $roundtripped_rsrc; + next unless ( - if ($registered_source_name) { - next if $registered_source_name ne ($roundtrip_rsrc->source_name || '') - } - else { - next if $self->result_class ne $roundtrip_rsrc->result_class; - } + # the schema may be partially loaded + $roundtripped_rsrc = dbic_internal_try { $other_rsrc->related_source($other_rel) } + + and - my $other_rel_info = $other_rsrc->relationship_info($other_rel); + ( - # this can happen when we have a self-referential class - next if $other_rel_info eq $rel_info; + ( + $our_registered_source_name + and + ( + $our_registered_source_name + eq + $roundtripped_rsrc->source_name||'' + ) + ) - next unless ref $other_rel_info->{cond} eq 'HASH'; - my $other_stripped_cond = $self->__strip_relcond($other_rel_info->{cond}); + or - $ret->{$other_rel} = $other_rel_info if ( - $self->_compare_relationship_keys ( - [ keys %$stripped_cond ], [ values %$other_stripped_cond ] + ( + $our_result_class + eq + $roundtripped_rsrc->result_class + ) ) + and - $self->_compare_relationship_keys ( - [ values %$stripped_cond ], [ keys %$other_stripped_cond ] - ) + + my $their_resolved_relcond = dbic_internal_try { + $other_rsrc->_resolve_relationship_condition( + rel_name => $other_rel, + + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, + ) + } ); - } - return $ret; -} -# all this does is removes the foreign/self prefix from a condition -sub __strip_relcond { - +{ - map - { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) } - keys %{$_[1]} - } -} + $ret->{$other_rel} = $other_rsrc->relationship_info($other_rel) if ( -sub compare_relationship_keys { - carp 'compare_relationship_keys is a private method, stop calling it'; - my $self = shift; - $self->_compare_relationship_keys (@_); -} + $their_resolved_relcond->{identity_map_matches_condition} -# Returns true if both sets of keynames are the same, false otherwise. -sub _compare_relationship_keys { -# my ($self, $keys1, $keys2) = @_; - return - join ("\x00", sort @{$_[1]}) - eq - join ("\x00", sort @{$_[2]}) - ; + and + + keys %{ $our_resolved_relcond->{identity_map} } + == + keys %{ $their_resolved_relcond->{identity_map} } + + and + + serialize( $our_resolved_relcond->{identity_map} ) + eq + serialize( { reverse %{ $their_resolved_relcond->{identity_map} } } ) + + ); + } + + return $ret; } # optionally takes either an arrayref of column names, or a hashref of already @@ -2124,6 +2150,25 @@ sub _pk_depends_on { return 1; } +sub __strip_relcond :DBIC_method_is_indirect_sugar { + DBIx::Class::Exception->throw( + '__strip_relcond() has been removed with no replacement, ' + . 'ask for advice on IRC if this affected you' + ); +} + +sub compare_relationship_keys :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + carp_unique( 'compare_relationship_keys() is deprecated, ask on IRC for a better alternative' ); + bag_eq( $_[1], $_[2] ); +} + +sub _compare_relationship_keys :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + carp_unique( '_compare_relationship_keys() is deprecated, ask on IRC for a better alternative' ); + bag_eq( $_[1], $_[2] ); +} + sub resolve_condition { carp 'resolve_condition is a private method, stop calling it'; shift->_resolve_condition (@_); @@ -2259,7 +2304,7 @@ sub _resolve_relationship_condition { if $args->{self_alias} eq $args->{foreign_alias}; # TEMP - my $exception_rel_id = "relationship '$args->{rel_name}' on source '@{[ $self->source_name ]}'"; + my $exception_rel_id = "relationship '$args->{rel_name}' on source '@{[ $self->source_name || $self->result_class ]}'"; my $rel_info = $self->relationship_info($args->{rel_name}) # TEMP @@ -2462,7 +2507,10 @@ sub _resolve_relationship_condition { # construct the crosstable condition and the identity map for (0..$#f_cols) { $ret->{condition}{"$args->{foreign_alias}.$f_cols[$_]"} = { -ident => "$args->{self_alias}.$l_cols[$_]" }; - $ret->{identity_map}{$l_cols[$_]} = $f_cols[$_]; + + # explicit value stringification is deliberate - leave no room for + # interpretation when comparing sets of keys + $ret->{identity_map}{$l_cols[$_]} = "$f_cols[$_]"; }; if ($args->{foreign_values}) { @@ -2666,8 +2714,11 @@ sub _resolve_relationship_condition { $colinfos->{$lhs}{-source_alias} ne $colinfos->{$rhs_ref->[0]}{-source_alias} ) { ( $colinfos->{$lhs}{-source_alias} eq $args->{self_alias} ) - ? ( $ret->{identity_map}{$colinfos->{$lhs}{-colname}} = $colinfos->{$rhs_ref->[0]}{-colname} ) - : ( $ret->{identity_map}{$colinfos->{$rhs_ref->[0]}{-colname}} = $colinfos->{$lhs}{-colname} ) + + # explicit value stringification is deliberate - leave no room for + # interpretation when comparing sets of keys + ? ( $ret->{identity_map}{$colinfos->{$lhs}{-colname}} = "$colinfos->{$rhs_ref->[0]}{-colname}" ) + : ( $ret->{identity_map}{$colinfos->{$rhs_ref->[0]}{-colname}} = "$colinfos->{$lhs}{-colname}" ) ; # well, what do you know! diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index 32fcf3172..069d3318c 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -457,12 +457,15 @@ sub _resolve_collapse { is_single => $relinfo->{$rel}{is_single}, - # if there is at least one *inner* reverse relationship which is HASH-based (equality only) + # if there is at least one *inner* reverse relationship ( meaning identity-only ) # we can safely assume that the child can not exist without us - rev_rel_is_optional => ( grep - { ref $_->{cond} eq 'HASH' and ($_->{attrs}{join_type}||'') !~ /^left/i } - values %{ $self->reverse_relationship_info($rel) }, - ) ? 0 : 1, + rev_rel_is_optional => ( + ( grep { + ($_->{attrs}{join_type}||'') !~ /^left/i + } values %{ $self->reverse_relationship_info($rel) } ) + ? 0 + : 1 + ), # if this is a 1:1 our own collapser can be used as a collapse-map # (regardless of left or not) diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 08f3b6901..29b196dce 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -204,7 +204,7 @@ our @EXPORT_OK = qw( scope_guard detected_reinvoked_destructor emit_loud_diag true false is_exception dbic_internal_try dbic_internal_catch visit_namespaces - quote_sub qsub perlstring serialize deep_clone dump_value uniq + quote_sub qsub perlstring serialize deep_clone dump_value uniq bag_eq parent_dir mkdir_p UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR ); @@ -387,6 +387,34 @@ sub uniq { ) } @_; } +sub bag_eq ($$) { + croak "bag_eq() requiress two arrayrefs as arguments" if ( + ref($_[0]) ne 'ARRAY' + or + ref($_[1]) ne 'ARRAY' + ); + + return '' unless @{$_[0]} == @{$_[1]}; + + my( %seen, $numeric_preserving_copy ); + + ( defined $_ + ? $seen{'value' . ( $numeric_preserving_copy = $_ )}++ + : $seen{'undef'}++ + ) for @{$_[0]}; + + ( defined $_ + ? $seen{'value' . ( $numeric_preserving_copy = $_ )}-- + : $seen{'undef'}-- + ) for @{$_[1]}; + + return ( + (grep { $_ } values %seen) + ? '' + : 1 + ); +} + my $dd_obj; sub dump_value ($) { local $Data::Dumper::Indent = 1 diff --git a/lib/SQL/Translator/Parser/DBIx/Class.pm b/lib/SQL/Translator/Parser/DBIx/Class.pm index 2535783c8..14812ac93 100644 --- a/lib/SQL/Translator/Parser/DBIx/Class.pm +++ b/lib/SQL/Translator/Parser/DBIx/Class.pm @@ -15,7 +15,7 @@ $DEBUG = 0 unless defined $DEBUG; use Exporter; use SQL::Translator::Utils qw(debug normalize_name); use DBIx::Class::Carp qw/^SQL::Translator|^DBIx::Class|^Try::Tiny/; -use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch ); +use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch bag_eq ); use Class::C3::Componentised; use Scalar::Util 'blessed'; use namespace::clean; @@ -155,13 +155,11 @@ sub parse { my %unique_constraints = $source->unique_constraints; foreach my $uniq (sort keys %unique_constraints) { - if (!$source->_compare_relationship_keys($unique_constraints{$uniq}, \@primary)) { - $table->add_constraint( - type => 'unique', - name => $uniq, - fields => $unique_constraints{$uniq} - ); - } + $table->add_constraint( + type => 'unique', + name => $uniq, + fields => $unique_constraints{$uniq} + ) unless bag_eq( \@primary, $unique_constraints{$uniq} ); } my @rels = $source->relationships(); @@ -232,7 +230,7 @@ sub parse { # this is supposed to indicate a has_one/might_have... # where's the introspection!!?? :) else { - $fk_constraint = not $source->_compare_relationship_keys(\@keys, \@primary); + $fk_constraint = ! bag_eq( \@keys, \@primary ); } From 1bd54f3d4bc8428d602d2e28cb410b303bb242b7 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 24 Sep 2016 15:08:53 +0200 Subject: [PATCH 243/262] Switch infer_values_based_on to require_join_free_values in cond resolver This further simplifies the cognitive surface of the condition resolver API just like 786c1cdd and a3ae79ed. During the sprint to add at least *some* sanity to the codepath infer_values_based_on was introduced as a stopgap to allow 83a6b244 to somehow proceed forward. Since then the amount of spots where this logic is necessary steadily went down, bringing us to the current place: there is just a single spot in the entire codebase that passes a non-empty inferrence structure. Given the entire codepath is rather baroque, the entire idea of inferrence is pushed to new_related instead, leaving the API of the resolver itself even simpler. There are no known issues as a result, verified by re-running the entire test plan for downstreams as described in 12e7015a. --- lib/DBIx/Class/Relationship/Base.pm | 104 ++++++++++++++-- lib/DBIx/Class/ResultSet.pm | 4 +- lib/DBIx/Class/ResultSource.pm | 181 ++++++++++++++++++---------- lib/DBIx/Class/Row.pm | 4 +- 4 files changed, 213 insertions(+), 80 deletions(-) diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index c4d4df592..cfd23f27f 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -8,8 +8,9 @@ use base qw/DBIx::Class/; use Scalar::Util qw/weaken blessed/; use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR - fail_on_internal_call + dbic_internal_try fail_on_internal_call ); +use DBIx::Class::SQLMaker::Util 'extract_equality_conditions'; use DBIx::Class::Carp; use namespace::clean; @@ -530,7 +531,11 @@ sub related_resultset { self_result_object => $self, # an extra sanity check guard - require_join_free_condition => ! $relcond_is_freeform, + require_join_free_condition => !!( + ! $relcond_is_freeform + and + $self->in_storage + ), # an API where these are optional would be too cumbersome, # instead always pass in some dummy values @@ -585,6 +590,7 @@ sub related_resultset { # FIXME - this loop doesn't seem correct - got to figure out # at some point what exactly it does. + # See also the FIXME at the end of new_related() ( ( $reverse->{$_}{attrs}{accessor}||'') eq 'multi' ) ? weaken( $attrs->{related_objects}{$_}[0] = $self ) : weaken( $attrs->{related_objects}{$_} = $self ) @@ -674,16 +680,94 @@ your storage until you call L on it. sub new_related { my ($self, $rel, $data) = @_; - $self->related_resultset($rel)->new_result( $self->result_source->_resolve_relationship_condition ( - infer_values_based_on => $data, + $self->throw_exception( + "Result object instantiation requires a hashref as argument" + ) unless ref $data eq 'HASH'; + + my $rsrc = $self->result_source; + my $rel_rsrc = $rsrc->related_source($rel); + +### +### This section deliberately does not rely on require_join_free_values, +### as quite often the resulting related object is useless without the +### contents of $data mixed in. Originally this code was part of +### resolve_relationship_condition() but given it has a single, very +### context-specific call-site it made no sense to expose it to end users. +### + + my $rel_resolution = $rsrc->_resolve_relationship_condition ( rel_name => $rel, self_result_object => $self, - # an API where these are optional would be too cumbersome, - # instead always pass in some dummy values - DUMMY_ALIASPAIR, + # In case we are *not* in_storage it is ok to treat failed resolution as an empty hash + # This happens e.g. as a result of various in-memory related graph of objects + require_join_free_condition => !! $self->in_storage, + + # dummy aliases with deliberately known lengths, so that we can + # quickly strip them below if needed + foreign_alias => 'F', + self_alias => 'S', + ); + + my $rel_values = + $rel_resolution->{join_free_values} + || + { map { substr( $_, 2 ) => $rel_resolution->{join_free_condition}{$_} } keys %{ $rel_resolution->{join_free_condition} } } + ; + + # mix everything together + my $amalgamated_values = { + %{ + # in case we got back join_free_values - they already have passed the extractor + $rel_resolution->{join_free_values} + ? $rel_values + : extract_equality_conditions( + $rel_values, + 'consider_nulls' + ) + }, + %$data, + }; + + # cleanup possible rogue { somecolumn => [ -and => 1,2 ] } + ($amalgamated_values->{$_}||'') eq UNRESOLVABLE_CONDITION + and + delete $amalgamated_values->{$_} + for keys %$amalgamated_values; + + if( my @nonvalues = grep { ! exists $amalgamated_values->{$_} } keys %$rel_values ) { + + $self->throw_exception( + "Unable to complete value inferrence - relationship '$rel' " + . "on source '@{[ $rsrc->source_name ]}' results " + . 'in expression(s) instead of definitive values: ' + . do { + # FIXME - used for diag only, but still icky + my $sqlm = + dbic_internal_try { $rsrc->schema->storage->sql_maker } + || + ( + require DBIx::Class::SQLMaker + and + DBIx::Class::SQLMaker->new + ) + ; + local $sqlm->{quote_char}; + local $sqlm->{_dequalify_idents} = 1; + ($sqlm->_recurse_where({ map { $_ => $rel_values->{$_} } @nonvalues }))[0] + } + ); + } - )->{inferred_values} ); + # And more complications - in case the relationship did not resolve + # we *have* to loop things through search_related ( essentially re-resolving + # everything we did so far, but with different type of handholding ) + # FIXME - this is still a mess, just a *little* better than it was + # See also the FIXME at the end of related_resultset() + exists $rel_resolution->{join_free_values} + ? $rel_rsrc->result_class->new({ -result_source => $rel_rsrc, %$amalgamated_values }) + : $self->related_resultset($rel)->new_result( $amalgamated_values ) + ; } =head2 create_related @@ -830,7 +914,7 @@ sub set_from_related { my ($self, $rel, $f_obj) = @_; $self->set_columns( $self->result_source->_resolve_relationship_condition ( - infer_values_based_on => {}, + require_join_free_values => 1, rel_name => $rel, foreign_values => ( # maintain crazy set_from_related interface @@ -865,7 +949,7 @@ sub set_from_related { # instead always pass in some dummy values DUMMY_ALIASPAIR, - )->{inferred_values} ); + )->{join_free_values} ); return 1; } diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 128b5546e..39af76b26 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -836,6 +836,7 @@ sub find { %$call_cond, %{ $rsrc->_resolve_relationship_condition( + require_join_free_values => 1, rel_name => $key, foreign_values => ( (! defined blessed $foreign_val) ? $foreign_val : do { @@ -861,12 +862,11 @@ sub find { +{ $foreign_val->get_columns }; } ), - infer_values_based_on => {}, # an API where these are optional would be too cumbersome, # instead always pass in some dummy values DUMMY_ALIASPAIR, - )->{inferred_values} }, + )->{join_free_values} }, }; } } diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 2dec41688..eba794f29 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -2278,17 +2278,16 @@ Internals::SvREADONLY($UNRESOLVABLE_CONDITION => 1); # self_alias => (scalar) # self_result_object => (either not supplied or a result object) # require_join_free_condition => (boolean, throws on failure to construct a JF-cond) -# infer_values_based_on => (either not supplied or a hashref, implies require_join_free_condition) +# require_join_free_values => (boolean, throws on failure to return an equality-only JF-cond, implies require_join_free_condition) # ## returns a hash # condition => (a valid *likely fully qualified* sqla cond structure) # identity_map => (a hashref of foreign-to-self *unqualified* column equality names) # identity_map_matches_condition => (boolean, indicates whether the entire condition is expressed in the identity-map) # join_free_condition => (a valid *fully qualified* sqla cond structure, maybe unset) -# inferred_values => (in case of an available join_free condition, this is a hashref of -# *unqualified* column/value *EQUALITY* pairs, representing an amalgamation -# of the JF-cond parse and infer_values_based_on -# always either complete or unset) +# join_free_values => (IFF the returned join_free_condition contains only exact values (no expressions) +# this would be a hashref of identical join_free_condition, except with all column +# names *unqualified* ) # sub _resolve_relationship_condition { my $self = shift; @@ -2318,10 +2317,7 @@ sub _resolve_relationship_condition { $self->throw_exception("No practical way to resolve $exception_rel_id between two data structures") if exists $args->{self_result_object} and exists $args->{foreign_values}; - $self->throw_exception( "Argument to infer_values_based_on must be a hash" ) - if exists $args->{infer_values_based_on} and ref $args->{infer_values_based_on} ne 'HASH'; - - $args->{require_join_free_condition} ||= !!$args->{infer_values_based_on}; + $args->{require_join_free_condition} ||= !!$args->{require_join_free_values}; $self->throw_exception( "Argument 'self_result_object' must be an object inheriting from '$__expected_result_class_isa'" ) if ( @@ -2514,32 +2510,45 @@ sub _resolve_relationship_condition { }; if ($args->{foreign_values}) { - $ret->{join_free_condition}{"$args->{self_alias}.$l_cols[$_]"} = $args->{foreign_values}{$f_cols[$_]} + $ret->{join_free_condition}{"$args->{self_alias}.$l_cols[$_]"} + = $ret->{join_free_values}{$l_cols[$_]} + = $args->{foreign_values}{$f_cols[$_]} for 0..$#f_cols; } elsif (defined $args->{self_result_object}) { - for my $i (0..$#l_cols) { - if ( $args->{self_result_object}->has_column_loaded($l_cols[$i]) ) { - $ret->{join_free_condition}{"$args->{foreign_alias}.$f_cols[$i]"} = $args->{self_result_object}->get_column($l_cols[$i]); - } - else { - $self->throw_exception(sprintf - "Unable to resolve relationship '%s' from object '%s': column '%s' not " - . 'loaded from storage (or not passed to new() prior to insert()). You ' - . 'probably need to call ->discard_changes to get the server-side defaults ' - . 'from the database.', - $args->{rel_name}, - $args->{self_result_object}, - $l_cols[$i], - ) if $args->{self_result_object}->in_storage; - - # FIXME - temporarly force-override - delete $args->{require_join_free_condition}; - delete $ret->{join_free_condition}; - last; - } - } + # FIXME - compat block due to inconsistency of get_columns() vs has_column_loaded() + # The former returns cached-in related single rels, while the latter is doing what + # it says on the tin. Thus the more logical "get all columns and barf if something + # is missing" is a non-starter, and we move through each column one by one :/ + + $args->{self_result_object}->has_column_loaded( $l_cols[$_] ) + + ? $ret->{join_free_condition}{"$args->{foreign_alias}.$f_cols[$_]"} + = $ret->{join_free_values}{$f_cols[$_]} + = $args->{self_result_object}->get_column( $l_cols[$_] ) + + : $args->{self_result_object}->in_storage + + ? $self->throw_exception(sprintf + "Unable to resolve relationship '%s' from object '%s': column '%s' not " + . 'loaded from storage (or not passed to new() prior to insert()). You ' + . 'probably need to call ->discard_changes to get the server-side defaults ' + . 'from the database', + $args->{rel_name}, + $args->{self_result_object}, + $l_cols[$_], + ) + + # non-resolvable yet not in storage - give it a pass + # FIXME - while this is what the code has done for ages, it doesn't seem right :( + : ( + delete $ret->{join_free_condition}, + delete $ret->{join_free_values}, + last + ) + + for 0 .. $#l_cols; } } elsif (ref $rel_info->{cond} eq 'ARRAY') { @@ -2562,7 +2571,7 @@ sub _resolve_relationship_condition { $self->throw_exception('Either all or none of the OR-condition members must resolve to a join-free condition') if ( $ret and ( $ret->{join_free_condition} xor $subcond->{join_free_condition} ) ); - # we are discarding inferred_values from individual 'OR' branches here + # we are discarding join_free_values from individual 'OR' branches here # see @nonvalues checks below $subcond->{$_} and push @{$ret->{$_}}, $subcond->{$_} for (qw(condition join_free_condition)); } @@ -2599,9 +2608,14 @@ sub _resolve_relationship_condition { ); } - # we got something back - sanity check and infer values if we can + # we got something back (not from a static cond) - sanity check and infer values if we can + # ( in case of a static cond join_free_values is already pre-populated for us ) my @nonvalues; - if( $ret->{join_free_condition} ) { + if( + $ret->{join_free_condition} + and + ! $ret->{join_free_values} + ) { my $jfc_eqs = extract_equality_conditions( $ret->{join_free_condition}, @@ -2621,45 +2635,43 @@ sub _resolve_relationship_condition { ); if (exists $jfc_eqs->{$_} and ($jfc_eqs->{$_}||'') ne UNRESOLVABLE_CONDITION) { - $ret->{inferred_values}{$col} = $jfc_eqs->{$_}; + $ret->{join_free_values}{$col} = $jfc_eqs->{$_}; } - elsif ( !$args->{infer_values_based_on} or ! exists $args->{infer_values_based_on}{$col} ) { + else { push @nonvalues, { $_ => $ret->{join_free_condition}{$_} }; } } } # all or nothing - delete $ret->{inferred_values} if @nonvalues; + delete $ret->{join_free_values} if @nonvalues; } - # did the user explicitly ask - if ($args->{infer_values_based_on}) { - $self->throw_exception(sprintf ( - "Unable to complete value inferrence - $exception_rel_id results in expression(s) instead of definitive values: %s", - do { - # FIXME - used for diag only, but still icky - my $sqlm = - dbic_internal_try { $self->schema->storage->sql_maker } - || - ( - require DBIx::Class::SQLMaker - and - DBIx::Class::SQLMaker->new - ) - ; - local $sqlm->{quote_char}; - local $sqlm->{_dequalify_idents} = 1; - ($sqlm->_recurse_where({ -and => \@nonvalues }))[0] - } - )) if @nonvalues; - - $ret->{inferred_values} ||= {}; + # throw only if the user explicitly asked + $args->{require_join_free_values} + and + @nonvalues + and + $self->throw_exception( + "Unable to complete value inferrence - $exception_rel_id results in expression(s) instead of definitive values: " + . do { + # FIXME - used for diag only, but still icky + my $sqlm = + dbic_internal_try { $self->schema->storage->sql_maker } + || + ( + require DBIx::Class::SQLMaker + and + DBIx::Class::SQLMaker->new + ) + ; + local $sqlm->{quote_char}; + local $sqlm->{_dequalify_idents} = 1; + ($sqlm->_recurse_where({ -and => \@nonvalues }))[0] + } + ); - $ret->{inferred_values}{$_} = $args->{infer_values_based_on}{$_} - for keys %{$args->{infer_values_based_on}}; - } my $identity_map_incomplete; @@ -2746,6 +2758,11 @@ sub _resolve_relationship_condition { if $ret->{identity_map}; + # cleanup before final return, easier to eyeball + ! defined $ret->{$_} and delete $ret->{$_} + for keys %$ret; + + # FIXME - temporary, to fool the idiotic check in SQLMaker::_join_condition $ret->{condition} = { -and => [ $ret->{condition} ] } unless ( $ret->{condition} eq UNRESOLVABLE_CONDITION @@ -2772,10 +2789,14 @@ sub _resolve_relationship_condition { local $sqlm->{_dequalify_idents} = 1; - my ($cond_as_sql, $identmap_as_sql) = map - { join ' : ', map { defined $_ ? $_ : '{UNDEF}' } $sqlm->_recurse_where($_) } + my ( $cond_as_sql, $jf_cond_as_sql, $jf_vals_as_sql, $identmap_as_sql ) = map + { join ' : ', map { + ref $_ eq 'ARRAY' ? $_->[1] + : defined $_ ? $_ + : '{UNDEF}' + } $sqlm->_recurse_where($_) } ( - $ret->{condition}, + ( map { $ret->{$_} } qw( condition join_free_condition join_free_values ) ), { map { # inverse because of how the idmap is declared @@ -2784,6 +2805,7 @@ sub _resolve_relationship_condition { ) ; + emit_loud_diag( confess => 1, msg => sprintf ( @@ -2798,7 +2820,34 @@ sub _resolve_relationship_condition { $identmap_as_sql, dump_value( $rel_info->{cond} ), ), - ) if ( $ret->{identity_map_matches_condition} xor ( $cond_as_sql eq $identmap_as_sql ) ); + ) if ( + $ret->{identity_map_matches_condition} + xor + ( $cond_as_sql eq $identmap_as_sql ) + ); + + + emit_loud_diag( + confess => 1, + msg => sprintf ( + "Resolution of %s produced inconsistent metadata:\n\n" + . "returned 'join_free_condition' rendered as de-qualified SQL: %s\n" + . "returned 'join_free_values' rendered as de-qualified SQL: %s\n\n" + . "The condition declared on the misclassified relationship is: %s ", + $exception_rel_id, + $jf_cond_as_sql, + $jf_vals_as_sql, + dump_value( $rel_info->{cond} ), + ), + ) if ( + exists $ret->{join_free_condition} + and + ( + exists $ret->{join_free_values} + xor + ( $jf_cond_as_sql eq $jf_vals_as_sql ) + ) + ); } $ret; diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 5adf4eaf3..ae89b78a2 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -1194,14 +1194,14 @@ sub copy { $copied->{$_->ID}++ or $_->copy( $foreign_vals ||= $rsrc->_resolve_relationship_condition( - infer_values_based_on => {}, + require_join_free_values => 1, rel_name => $rel_name, self_result_object => $new, # an API where these are optional would be too cumbersome, # instead always pass in some dummy values DUMMY_ALIASPAIR, - )->{inferred_values} + )->{join_free_values} ) for $self->related_resultset($rel_name)->all; } From e5c6382908ee65577e53c0771629384d70959a3d Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 1 Sep 2016 20:22:55 +0200 Subject: [PATCH 244/262] Protect several resolve_relationship_condition() callsites Some external use of DBIx::Class::ParameterizedJoinHack revealed a couple sites where the relationship resolution may unexpectedly, yet non-fatally fail. This protects all the reasonable places (partially reverting b47fb9c0), downgrading the exceptions to once-per-callsite warnings. I did not have time to dig to find the underlying problem, there may very well be a real bug lurking around :/ For reproduction of the (now) warnings: see https://github.com/ctrlo/lenio --- lib/DBIx/Class/Relationship/Base.pm | 42 ++++++++++++++++++++--- lib/DBIx/Class/Relationship/ManyToMany.pm | 9 ++--- lib/DBIx/Class/ResultSource/RowParser.pm | 34 ++++++++++++++---- 3 files changed, 70 insertions(+), 15 deletions(-) diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index cfd23f27f..ab18bed2a 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -8,10 +8,16 @@ use base qw/DBIx::Class/; use Scalar::Util qw/weaken blessed/; use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR - dbic_internal_try fail_on_internal_call + dbic_internal_try dbic_internal_catch fail_on_internal_call ); use DBIx::Class::SQLMaker::Util 'extract_equality_conditions'; use DBIx::Class::Carp; + +# FIXME - this should go away +# instead Carp::Skip should export usable keywords or something like that +my $unique_carper; +BEGIN { $unique_carper = \&carp_unique } + use namespace::clean; =head1 NAME @@ -525,8 +531,7 @@ sub related_resultset { my $relcond_is_freeform = ref $rel_info->{cond} eq 'CODE'; - my $jfc = $rsrc->_resolve_relationship_condition( - + my $rrc_args = { rel_name => $rel, self_result_object => $self, @@ -545,8 +550,37 @@ sub related_resultset { # out of an existing object, with the new source being at the head # of the FROM chain. Having a 'me' alias is nothing but expected there foreign_alias => 'me', + }; - )->{join_free_condition}; + my $jfc = ( + # In certain extraordinary circumstances the relationship resolution may + # throw (e.g. when walking through elaborate custom conds) + # In case the object is "real" (i.e. in_storage) we just go ahead and + # let the exception surface. Otherwise we carp and move on. + # + # The elaborate code-duplicating ternary is there because the xsified + # ->in_storage() is orders of magnitude faster than the Try::Tiny-like + # construct below ( perl's low level tooling is truly shit :/ ) + ( $self->in_storage or DBIx::Class::_Util::in_internal_try ) + ? $rsrc->_resolve_relationship_condition($rrc_args)->{join_free_condition} + : dbic_internal_try { + $rsrc->_resolve_relationship_condition($rrc_args)->{join_free_condition} + } + dbic_internal_catch { + $unique_carper->( + "Resolution of relationship '$rel' failed unexpectedly, " + . 'please relay the following error and seek assistance via ' + . DBIx::Class::_ENV_::HELP_URL . ". Encountered error: $_" + ); + + # FIXME - this is questionable + # force skipping re-resolution, and instead just return an UC rset + $relcond_is_freeform = 0; + + # RV + undef; + } + ); my $rel_rset; diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm index e715f10e4..2812b6bf0 100644 --- a/lib/DBIx/Class/Relationship/ManyToMany.pm +++ b/lib/DBIx/Class/Relationship/ManyToMany.pm @@ -7,9 +7,10 @@ use warnings; use DBIx::Class::Carp; use DBIx::Class::_Util qw( quote_sub perlstring ); -# FIXME - this souldn't be needed -my $cu; -BEGIN { $cu = \&carp_unique } +# FIXME - this should go away +# instead Carp::Skip should export usable keywords or something like that +my $unique_carper; +BEGIN { $unique_carper = \&carp_unique } use namespace::clean; @@ -82,7 +83,7 @@ EOC my @extra_meth_qsub_args = ( { '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } }, - '$carp_unique' => \$cu, + '$carp_unique' => \$unique_carper, }, { attributes => [ 'DBIC_method_is_indirect_sugar', diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index 069d3318c..6540dc70b 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -10,10 +10,15 @@ use DBIx::Class::ResultSource::RowParser::Util qw( assemble_simple_parser assemble_collapsing_parser ); -use DBIx::Class::_Util 'DUMMY_ALIASPAIR'; +use DBIx::Class::_Util qw( DUMMY_ALIASPAIR dbic_internal_try dbic_internal_catch ); use DBIx::Class::Carp; +# FIXME - this should go away +# instead Carp::Skip should export usable keywords or something like that +my $unique_carper; +BEGIN { $unique_carper = \&carp_unique } + use namespace::clean; # Accepts a prefetch map (one or more relationships for the current source), @@ -187,13 +192,28 @@ sub _resolve_collapse { is_single => ( $inf->{attrs}{accessor} && $inf->{attrs}{accessor} ne 'multi' ), is_inner => ( ( $inf->{attrs}{join_type} || '' ) !~ /^left/i), rsrc => $self->related_source($rel), - fk_map => $self->_resolve_relationship_condition( - rel_name => $rel, + fk_map => ( + dbic_internal_try { + $self->_resolve_relationship_condition( + rel_name => $rel, + + # an API where these are optional would be too cumbersome, + # instead always pass in some dummy values + DUMMY_ALIASPAIR, + )->{identity_map}, + } + dbic_internal_catch { + + $unique_carper->( + "Resolution of relationship '$rel' failed unexpectedly, " + . 'please relay the following error and seek assistance via ' + . DBIx::Class::_ENV_::HELP_URL . ". Encountered error: $_" + ); - # an API where these are optional would be too cumbersome, - # instead always pass in some dummy values - DUMMY_ALIASPAIR, - )->{identity_map}, + # RV + +{} + } + ), }; } From 7293955e14a24ad5abecc41e0ec485ccdfb3d2f0 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Sat, 30 Jul 2016 16:03:12 +0200 Subject: [PATCH 245/262] Promote resolve_relationship_condition to a 1st-class API method The encapsulated logic is just too complex to try to replicate externally, especially now that everything within DBIC itself uses this method underneath. Patches to the only widely known user (::Resultset::RecursiveUpdate) will follow shortly --- lib/DBIx/Class/Relationship/Accessor.pm | 2 +- lib/DBIx/Class/Relationship/Base.pm | 8 +- lib/DBIx/Class/ResultSet.pm | 4 +- lib/DBIx/Class/ResultSource.pm | 130 ++++++++++++------ lib/DBIx/Class/ResultSource/RowParser.pm | 2 +- lib/DBIx/Class/Row.pm | 2 +- ...resolve_relationship_condition_arguments.t | 5 +- 7 files changed, 101 insertions(+), 52 deletions(-) rename t/relationship/resolve_relationship_condition.t => xt/extra/diagnostics/invalid_resolve_relationship_condition_arguments.t (86%) diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index 42d7e3857..e6d4fb4c7 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -54,7 +54,7 @@ sub add_relationship_accessor { and - $jfc = ( $rsrc->_resolve_relationship_condition( + $jfc = ( $rsrc->resolve_relationship_condition( rel_name => %1$s, foreign_alias => %1$s, self_alias => 'me', diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index ab18bed2a..5924db003 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -562,9 +562,9 @@ sub related_resultset { # ->in_storage() is orders of magnitude faster than the Try::Tiny-like # construct below ( perl's low level tooling is truly shit :/ ) ( $self->in_storage or DBIx::Class::_Util::in_internal_try ) - ? $rsrc->_resolve_relationship_condition($rrc_args)->{join_free_condition} + ? $rsrc->resolve_relationship_condition($rrc_args)->{join_free_condition} : dbic_internal_try { - $rsrc->_resolve_relationship_condition($rrc_args)->{join_free_condition} + $rsrc->resolve_relationship_condition($rrc_args)->{join_free_condition} } dbic_internal_catch { $unique_carper->( @@ -729,7 +729,7 @@ sub new_related { ### context-specific call-site it made no sense to expose it to end users. ### - my $rel_resolution = $rsrc->_resolve_relationship_condition ( + my $rel_resolution = $rsrc->resolve_relationship_condition ( rel_name => $rel, self_result_object => $self, @@ -947,7 +947,7 @@ L to update them in the storage. sub set_from_related { my ($self, $rel, $f_obj) = @_; - $self->set_columns( $self->result_source->_resolve_relationship_condition ( + $self->set_columns( $self->result_source->resolve_relationship_condition ( require_join_free_values => 1, rel_name => $rel, foreign_values => ( diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 39af76b26..1d6d177ed 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -835,7 +835,7 @@ sub find { $call_cond = { %$call_cond, - %{ $rsrc->_resolve_relationship_condition( + %{ $rsrc->resolve_relationship_condition( require_join_free_values => 1, rel_name => $key, foreign_values => ( @@ -2531,7 +2531,7 @@ sub populate { $colinfo->{$rel}{rs} = $rsrc->related_source($rel)->resultset; - $colinfo->{$rel}{fk_map} = { reverse %{ $rsrc->_resolve_relationship_condition( + $colinfo->{$rel}{fk_map} = { reverse %{ $rsrc->resolve_relationship_condition( rel_name => $rel, # an API where these are optional would be too cumbersome, diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index eba794f29..ddef5449c 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -1832,7 +1832,7 @@ sub reverse_relationship_info { # Some custom rels may not resolve without a $schema # my $our_resolved_relcond = dbic_internal_try { - $self->_resolve_relationship_condition( + $self->resolve_relationship_condition( rel_name => $rel, # an API where these are optional would be too cumbersome, @@ -1898,7 +1898,7 @@ sub reverse_relationship_info { and my $their_resolved_relcond = dbic_internal_try { - $other_rsrc->_resolve_relationship_condition( + $other_rsrc->resolve_relationship_condition( rel_name => $other_rel, # an API where these are optional would be too cumbersome, @@ -2096,7 +2096,7 @@ sub _resolve_join { -alias => $as, -relation_chain_depth => ( $seen->{-relation_chain_depth} || 0 ) + 1, }, - $self->_resolve_relationship_condition( + $self->resolve_relationship_condition( rel_name => $join, self_alias => $alias, foreign_alias => $as, @@ -2169,18 +2169,29 @@ sub _compare_relationship_keys :DBIC_method_is_indirect_sugar { bag_eq( $_[1], $_[2] ); } -sub resolve_condition { - carp 'resolve_condition is a private method, stop calling it'; +sub _resolve_relationship_condition :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + + # carp() - has been on CPAN for less than 2 years + carp '_resolve_relationship_condition() is deprecated - see resolve_relationship_condition() instead'; + + shift->resolve_relationship_condition(@_); +} + +sub resolve_condition :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + + # carp() - has been discouraged forever + carp 'resolve_condition() is deprecated - see resolve_relationship_condition() instead'; + shift->_resolve_condition (@_); } -sub _resolve_condition { -# carp_unique sprintf -# '_resolve_condition is a private method, and moreover is about to go ' -# . 'away. Please contact the development team at %s if you believe you ' -# . 'have a genuine use for this method, in order to discuss alternatives.', -# DBIx::Class::_ENV_::HELP_URL, -# ; +sub _resolve_condition :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + + # carp_unique() - the interface replacing it only became reality in Sep 2016 + carp_unique '_resolve_condition() is deprecated - see resolve_relationship_condition() instead'; ####################### ### API Design? What's that...? (a backwards compatible shim, kill me now) @@ -2232,21 +2243,21 @@ sub _resolve_condition { }; # Allowing passing relconds different than the relationshup itself is cute, - # but likely dangerous. Remove that from the (still unofficial) API of - # _resolve_relationship_condition, and instead make it "hard on purpose" + # but likely dangerous. Remove that from the API of resolve_relationship_condition, + # and instead make it "hard on purpose" local $self->relationship_info( $args->{rel_name} )->{cond} = $cond if defined $cond; ####################### # now it's fucking easy isn't it?! - my $rc = $self->_resolve_relationship_condition( $args ); + my $rc = $self->resolve_relationship_condition( $args ); my @res = ( ( $rc->{join_free_condition} || $rc->{condition} ), ! $rc->{join_free_condition}, ); - # _resolve_relationship_condition always returns qualified cols even in the + # resolve_relationship_condition always returns qualified cols even in the # case of join_free_condition, but nothing downstream expects this if ($rc->{join_free_condition} and ref $res[0] eq 'HASH') { $res[0] = { map @@ -2268,34 +2279,73 @@ our $UNRESOLVABLE_CONDITION = UNRESOLVABLE_CONDITION; # we are moving to a constant Internals::SvREADONLY($UNRESOLVABLE_CONDITION => 1); -# Resolves the passed condition to a concrete query fragment and extra -# metadata -# -## self-explanatory API, modeled on the custom cond coderef: -# rel_name => (scalar) -# foreign_alias => (scalar) -# foreign_values => (either not supplied or a hashref ) -# self_alias => (scalar) -# self_result_object => (either not supplied or a result object) -# require_join_free_condition => (boolean, throws on failure to construct a JF-cond) -# require_join_free_values => (boolean, throws on failure to return an equality-only JF-cond, implies require_join_free_condition) -# -## returns a hash -# condition => (a valid *likely fully qualified* sqla cond structure) -# identity_map => (a hashref of foreign-to-self *unqualified* column equality names) -# identity_map_matches_condition => (boolean, indicates whether the entire condition is expressed in the identity-map) -# join_free_condition => (a valid *fully qualified* sqla cond structure, maybe unset) -# join_free_values => (IFF the returned join_free_condition contains only exact values (no expressions) -# this would be a hashref of identical join_free_condition, except with all column -# names *unqualified* ) -# -sub _resolve_relationship_condition { +=head2 resolve_relationship_condition + +NOTE: You generally B need to use this functionality... until you +do. The API description is terse on purpose. If the text below doesn't make +sense right away (based on the context which prompted you to look here) it is +almost certain you are reaching for the wrong tool. Please consider asking for +advice in any of the support channels before proceeding. + +=over 4 + +=item Arguments: C<\%args> as shown below (C> denotes mandatory args): + + * rel_name => $string + + * foreign_alias => $string + + * self_alias => $string + + foreign_values => \%column_value_pairs + + self_result_object => $ResultObject + + require_join_free_condition => $bool ( results in exception on failure to construct a JF-cond ) + + require_join_free_values => $bool ( results in exception on failure to return an equality-only JF-cond ) + +=item Return Value: C<\%resolution_result> as shown below (C> denotes always-resent parts of the result): + + * condition => $sqla_condition ( always present, valid, *likely* fully qualified, SQL::Abstract-compatible structure ) + + identity_map => \%foreign_to_self_equailty_map ( list of declared-equal foreign/self *unqualified* column names ) + + identity_map_matches_condition => $bool ( indicates whether the entire condition is expressed within the identity_map ) + + join_free_condition => \%sqla_condition_fully_resolvable_via_foreign_table + ( always a hash, all keys guaranteed to be valid *fully qualified* columns ) + + join_free_values => \%unqalified_version_of_join_free_condition + ( IFF the returned join_free_condition contains only exact values (no expressions), this would be + a hashref identical to join_free_condition, except with all column names *unqualified* ) + +=back + +This is the low-level method used to convert a declared relationship into +various parameters consumed by higher level functions. It is provided as a +stable official API, as the logic it encapsulates grew incredibly complex with +time. While calling this method directly B, you +absolutely B in codepaths containing the moral equivalent +of: + + ... + if( ref $some_rsrc->relationship_info($somerel)->{cond} eq 'HASH' ) { + ... + } + ... + +=cut + +# TODO - expand the documentation above, too terse + +sub resolve_relationship_condition { my $self = shift; my $args = { ref $_[0] eq 'HASH' ? %{ $_[0] } : @_ }; for ( qw( rel_name self_alias foreign_alias ) ) { - $self->throw_exception("Mandatory argument '$_' to _resolve_relationship_condition() is not a plain string") + $self->throw_exception("Mandatory argument '$_' to resolve_relationship_condition() is not a plain string") if !defined $args->{$_} or length ref $args->{$_}; } @@ -2560,7 +2610,7 @@ sub _resolve_relationship_condition { else { my @subconds = map { local $rel_info->{cond} = $_; - $self->_resolve_relationship_condition( $args ); + $self->resolve_relationship_condition( $args ); } @{ $rel_info->{cond} }; if( @{ $rel_info->{cond} } == 1 ) { diff --git a/lib/DBIx/Class/ResultSource/RowParser.pm b/lib/DBIx/Class/ResultSource/RowParser.pm index 6540dc70b..df3627acd 100644 --- a/lib/DBIx/Class/ResultSource/RowParser.pm +++ b/lib/DBIx/Class/ResultSource/RowParser.pm @@ -194,7 +194,7 @@ sub _resolve_collapse { rsrc => $self->related_source($rel), fk_map => ( dbic_internal_try { - $self->_resolve_relationship_condition( + $self->resolve_relationship_condition( rel_name => $rel, # an API where these are optional would be too cumbersome, diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index ae89b78a2..cc66d744b 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -1193,7 +1193,7 @@ sub copy { $copied->{$_->ID}++ or $_->copy( - $foreign_vals ||= $rsrc->_resolve_relationship_condition( + $foreign_vals ||= $rsrc->resolve_relationship_condition( require_join_free_values => 1, rel_name => $rel_name, self_result_object => $new, diff --git a/t/relationship/resolve_relationship_condition.t b/xt/extra/diagnostics/invalid_resolve_relationship_condition_arguments.t similarity index 86% rename from t/relationship/resolve_relationship_condition.t rename to xt/extra/diagnostics/invalid_resolve_relationship_condition_arguments.t index 801b1ea4f..050b5cade 100644 --- a/t/relationship/resolve_relationship_condition.t +++ b/xt/extra/diagnostics/invalid_resolve_relationship_condition_arguments.t @@ -6,10 +6,9 @@ use warnings; use Test::More; use Test::Exception; - use DBICTest; -my $schema = DBICTest->init_schema(); +my $schema = DBICTest->init_schema( no_deploy => 1 ); for ( { year => [1,2] }, @@ -18,7 +17,7 @@ for ( { -and => [ year => 1, year => 2 ] }, ) { throws_ok { - $schema->source('Track')->_resolve_relationship_condition( + $schema->source('Track')->resolve_relationship_condition( rel_name => 'cd_cref_cond', self_alias => 'me', foreign_alias => 'cd', From 84bf5d8caa798edfa99e79d36d34c27604b28f18 Mon Sep 17 00:00:00 2001 From: Henry Van Styn Date: Tue, 27 Sep 2016 13:46:14 +0100 Subject: [PATCH 246/262] Improve exception text during write operations on uninserted objects --- lib/DBIx/Class/Row.pm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index cc66d744b..7596f4a90 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -556,7 +556,9 @@ sub update { my %to_update = $self->get_dirty_columns or return $self; - $self->throw_exception( "Not in database" ) unless $self->in_storage; + $self->throw_exception( + 'Result object not marked in_storage: an update() operation is not possible' + ) unless $self->in_storage; my $rows = $self->result_source->schema->storage->update( $self->result_source, \%to_update, $self->_storage_ident_condition @@ -618,7 +620,9 @@ See also L. sub delete { my $self = shift; if (ref $self) { - $self->throw_exception( "Not in database" ) unless $self->in_storage; + $self->throw_exception( + 'Result object not marked in_storage: a delete() operation is not possible' + ) unless $self->in_storage; $self->result_source->schema->storage->delete( $self->result_source, $self->_storage_ident_condition From d2308dde5718dc0f828584c3fa24d7417c484040 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 27 Sep 2016 15:17:00 +0200 Subject: [PATCH 247/262] Remove the only use of the CAG 'inherited_ro_instance' group Introduced for reasons unknown back in 93405cf0, it is currently nothing but baggage - especially given the lack of name synchronization as described in one of the comments in 28ef9468 grep.cpan.me indicates no use in the wild, so just kill it with fire --- lib/DBIx/Class/AccessorGroup.pm | 5 ++++ lib/DBIx/Class/ResultSourceProxy.pm | 28 +++++++++++++++-------- lib/DBIx/Class/ResultSourceProxy/Table.pm | 1 - 3 files changed, 24 insertions(+), 10 deletions(-) diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index d4493e218..31cdcb0e8 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -63,6 +63,11 @@ sub mk_group_accessors { } } } + elsif( $type eq 'inherited_ro_instance' ) { + DBIx::Class::Exception->throw( + "The 'inherted_ro_instance' CAG group has been retired - use 'inherited' instead" + ); + } } sub get_component_class { diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm index 7a6ab9d06..0032a0ae2 100644 --- a/lib/DBIx/Class/ResultSourceProxy.pm +++ b/lib/DBIx/Class/ResultSourceProxy.pm @@ -25,15 +25,25 @@ use namespace::clean; # instance, and there is *ZERO EFFORT* made to synchronize them... # FIXME: Due to the above marking this as a rsrc_proxy method is also out # of the question... -__PACKAGE__->mk_group_accessors('inherited_ro_instance' => 'source_name'); - -sub get_inherited_ro_instance { $_[0]->get_inherited($_[1]) } - -sub set_inherited_ro_instance { - $_[0]->throw_exception ("Cannot set '$_[1]' on an instance") - if length ref $_[0]; - - $_[0]->set_inherited( $_[1], $_[2] ); +# FIXME: this used to be a sub-type of inherited ( to see run: +# `git log -Sinherited_ro_instance lib/DBIx/Class/ResultSourceProxy.pm` ) +# however given the lack of any sync effort as described above *anyway*, +# it makes no sense to guard for erroneous use at a non-trivial cost in +# performance (and may end up in the way of future optimizations as per +# https://github.com/vovkasm/Class-Accessor-Inherited-XS/issues/2#issuecomment-243246924 ) +__PACKAGE__->mk_group_accessors( inherited => 'source_name'); + +# The marking with indirect_sugar will cause warnings to be issued in darkpan code +# (though extremely unlikely) +sub get_inherited_ro_instance :DBIC_method_is_indirect_sugar { + DBIx::Class::Exception->throw( + "The 'inherted_ro_instance' CAG group has been retired - use 'inherited' instead" + ); +} +sub set_inherited_ro_instance :DBIC_method_is_indirect_sugar { + DBIx::Class::Exception->throw( + "The 'inherted_ro_instance' CAG group has been retired - use 'inherited' instead" + ); } sub add_columns :DBIC_method_is_bypassable_resultsource_proxy { diff --git a/lib/DBIx/Class/ResultSourceProxy/Table.pm b/lib/DBIx/Class/ResultSourceProxy/Table.pm index b0c4343e1..4cb733fae 100644 --- a/lib/DBIx/Class/ResultSourceProxy/Table.pm +++ b/lib/DBIx/Class/ResultSourceProxy/Table.pm @@ -9,7 +9,6 @@ use DBIx::Class::ResultSource::Table; use Scalar::Util 'blessed'; use namespace::clean; -# FIXME - both of these *PROBABLY* need to be 'inherited_ro_instance' type __PACKAGE__->mk_classaccessor(table_class => 'DBIx::Class::ResultSource::Table'); # FIXME: Doesn't actually do anything yet! __PACKAGE__->mk_group_accessors( inherited => 'table_alias' ); From 89d5e36fd191c1e303f91f15cd8c7c3d55fe6715 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Mon, 26 Sep 2016 17:36:54 +0200 Subject: [PATCH 248/262] (travis) Work around RT#117959 A real fix for this ticket is pending, but had to be bumped a bit --- maint/travis-ci_scripts/30_before_script.bash | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 21df67fc4..1de6cfb65 100644 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -141,9 +141,16 @@ else parallel_installdeps_notest Test::Exception Encode::Locale Test::Fatal Module::Runtime parallel_installdeps_notest Test::Warn B::Hooks::EndOfScope Test::Differences HTTP::Status parallel_installdeps_notest Test::Pod::Coverage Test::EOL Devel::GlobalDestruction Sub::Name MRO::Compat Class::XSAccessor URI::Escape HTML::Entities - parallel_installdeps_notest YAML LWP Class::Trigger DateTime::Format::Builder Class::Accessor::Grouped Package::Variant + parallel_installdeps_notest YAML LWP Class::Trigger Class::Accessor::Grouped Package::Variant parallel_installdeps_notest SQL::Abstract Moose Module::Install@1.15 JSON SQL::Translator File::Which Class::DBI::Plugin git://github.com/dbsrgits/perl-pperl.git + # FIXME - temp workaround for RT#117959 + if ! perl -M5.008004 -e1 &>/dev/null ; then + parallel_installdeps_notest DateTime::Locale@1.06 + parallel_installdeps_notest DateTime::TimeZone@2.02 + parallel_installdeps_notest DateTime@1.38 + fi + # the official version is very much outdated and does not compile on 5.14+ # use this rather updated source tree (needs to go to PAUSE): # https://github.com/pilcrow/perl-dbd-interbase From 8aae794001ecccdb26c2bbd1b92c97bba9e65d79 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= Date: Wed, 28 Sep 2016 12:39:12 +0100 Subject: [PATCH 249/262] Fix building on perls with no . in @INC Perl 5.26 will be able to be built with no . in @INC, and Debian are already building their 5.24 without it. To cope with this, do -It/lib -MFoo instead of -Mt::lib::Foo. --- maint/Makefile.PL.inc/56_autogen_schema_files.pl | 2 +- t/lib/ANFANG.pm | 2 +- t/lib/DBICTest/Util.pm | 2 +- xt/extra/taint.t | 4 ++-- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/maint/Makefile.PL.inc/56_autogen_schema_files.pl b/maint/Makefile.PL.inc/56_autogen_schema_files.pl index 2e1efb92f..bbc9912ab 100644 --- a/maint/Makefile.PL.inc/56_autogen_schema_files.pl +++ b/maint/Makefile.PL.inc/56_autogen_schema_files.pl @@ -1,5 +1,5 @@ my $test_ddl_fn = 't/lib/sqlite.sql'; -my @test_ddl_cmd = qw( -I lib -Mt::lib::ANFANG -- maint/gen_sqlite_schema_files --schema-class DBICTest::Schema ); +my @test_ddl_cmd = qw( -I lib -I t/lib -MANFANG -- maint/gen_sqlite_schema_files --schema-class DBICTest::Schema ); my $example_ddl_fn = 'examples/Schema/db/example.sql'; my $example_db_fn = 'examples/Schema/db/example.db'; diff --git a/t/lib/ANFANG.pm b/t/lib/ANFANG.pm index e5e603548..c429d740d 100644 --- a/t/lib/ANFANG.pm +++ b/t/lib/ANFANG.pm @@ -16,7 +16,7 @@ our $anfang_loaded; # this allows the obscure but possible call case to behave correctly: # -# perl -Mt::lib::ANFANG -e 'do "./t/lib/ANFANG.pm" or die ( $@ || $! )' +# perl -It/lib -MANFANG -e 'do "./t/lib/ANFANG.pm" or die ( $@ || $! )' # return 1 if $anfang_loaded; diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 7aeb805a0..e268b3b21 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -376,7 +376,7 @@ sub can_alloc_MB ($) { local ( $!, $^E, $?, $@ ); - system( $perl, qw( -Mt::lib::ANFANG -e ), <<'EOS', $arg ); + system( $perl, qw( -It/lib -MANFANG -e ), <<'EOS', $arg ); $0 = 'malloc_canary'; my $tail_character_of_reified_megastring = substr( ( join '', map chr, 0..255 ) x (4 * 1024 * $ARGV[0]), -1 ); EOS diff --git a/xt/extra/taint.t b/xt/extra/taint.t index e8c6af19a..93190c32f 100644 --- a/xt/extra/taint.t +++ b/xt/extra/taint.t @@ -20,7 +20,7 @@ use warnings; # there is talk of possible perl compilations where -T is fatal or just # doesn't work. We don't want to have the user deal with that. -BEGIN { unless ($INC{'t/lib/DBICTest/WithTaint.pm'}) { +BEGIN { unless ($INC{'DBICTest/WithTaint.pm'}) { if ( $^O eq 'MSWin32' and $^X =~ /\x20/ ) { print "1..0 # SKIP Running this test on Windows with spaces within the perl executable path (\$^X) is not possible due to https://rt.perl.org/Ticket/Display.html?id=123907\n"; @@ -56,7 +56,7 @@ BEGIN { unless ($INC{'t/lib/DBICTest/WithTaint.pm'}) { exit 0; } - exec( $perl, qw( -I. -Mt::lib::DBICTest::WithTaint -T ), __FILE__ ); + exec( $perl, qw( -It/lib -MDBICTest::WithTaint -T ), __FILE__ ); }} # We need to specify 'lib' here as well because even if it was already in From 02562a2092543488bba4ccd98c39abca72560555 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 30 Sep 2016 12:25:15 +0200 Subject: [PATCH 250/262] Tighten up select list processing in ::SQLMaker Optimize some of the codepaths (do not recurse in spots where it makes no practical difference). Deprecate searches with no explicit select-list ( can't remove it outright due to downstream breakage :/ ) --- Changes | 3 + lib/DBIx/Class/SQLMaker.pm | 113 +++++++++++++++-------- lib/DBIx/Class/SQLMaker/LimitDialects.pm | 18 ++-- lib/DBIx/Class/Schema/Versioned.pm | 4 +- lib/DBIx/Class/Storage/DBI.pm | 6 +- lib/DBIx/Class/Storage/DBIHacks.pm | 6 +- t/sqlmaker/core_quoted.t | 13 ++- t/sqlmaker/nest_deprec.t | 2 +- 8 files changed, 115 insertions(+), 50 deletions(-) diff --git a/Changes b/Changes index abf26360b..6a63e5ba1 100644 --- a/Changes +++ b/Changes @@ -34,6 +34,9 @@ Revision history for DBIx::Class arrayref) now emits a deprecation warning - Calling the getter $rsrc->from("argument") now throws an exception instead of silently discarding the argument + - search() calls with an empty select list are deprecated. While DBIC + will still issue a SELECT * ..., it now warns given there is nothing + higher up in the stack prepared to interpret the result * New Features - DBIC now performs a range of sanity checks on the entire hierarchy diff --git a/lib/DBIx/Class/SQLMaker.pm b/lib/DBIx/Class/SQLMaker.pm index 6557f2e07..9b140c172 100644 --- a/lib/DBIx/Class/SQLMaker.pm +++ b/lib/DBIx/Class/SQLMaker.pm @@ -132,6 +132,7 @@ use mro 'c3'; use DBIx::Class::Carp; use DBIx::Class::_Util 'set_subname'; +use SQL::Abstract 'is_literal_value'; use namespace::clean; __PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/); @@ -209,8 +210,28 @@ sub _where_op_NEST { sub select { my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_; + ($fields, @{$self->{select_bind}}) = length ref $fields + ? $self->_recurse_fields( $fields ) + : $self->_quote( $fields ) + ; - ($fields, @{$self->{select_bind}}) = $self->_recurse_fields($fields); + # Override the default behavior of SQL::Abstract - SELECT * makes + # no sense in the context of DBIC (and has resulted in several + # tricky debugging sessions in the past) + not length $fields + and +# FIXME - some day we need to enable this, but too many things break +# ( notably S::L ) +# # Random value selected by a fair roll of dice +# # In seriousness - this has to be a number, as it is much more +# # palatable to random engines in a SELECT list +# $fields = 42 +# and + carp_unique ( + "ResultSets with an empty selection are deprecated (you almost certainly " + . "did not mean to do that): if this is indeed your intent you must " + . "explicitly supply \\'*' to your search()" + ); if (defined $offset) { $self->throw_exception('A supplied offset must be a non-negative integer') @@ -327,20 +348,31 @@ sub insert { sub _recurse_fields { my ($self, $fields) = @_; - my $ref = ref $fields; - return $self->_quote($fields) unless $ref; - return $$fields if $ref eq 'SCALAR'; - - if ($ref eq 'ARRAY') { - my (@select, @bind); - for my $field (@$fields) { - my ($select, @new_bind) = $self->_recurse_fields($field); - push @select, $select; - push @bind, @new_bind; - } + + if( not length ref $fields ) { + return $self->_quote( $fields ); + } + + elsif( my $lit = is_literal_value( $fields ) ) { + return @$lit + } + + elsif( ref $fields eq 'ARRAY' ) { + my (@select, @bind, @bind_fragment); + + ( + ( $select[ $#select + 1 ], @bind_fragment ) = length ref $_ + ? $self->_recurse_fields( $_ ) + : $self->_quote( $_ ) + ), + ( push @bind, @bind_fragment ) + for @$fields; + return (join(', ', @select), @bind); } - elsif ($ref eq 'HASH') { + + # FIXME - really crappy handling of functions + elsif ( ref $fields eq 'HASH') { my %hash = %$fields; # shallow copy my $as = delete $hash{-as}; # if supplied @@ -348,34 +380,41 @@ sub _recurse_fields { my ($func, $rhs, @toomany) = %hash; # there should be only one pair - if (@toomany) { - $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) ); - } - - if (lc ($func) eq 'distinct' && ref $rhs eq 'ARRAY' && @$rhs > 1) { - $self->throw_exception ( - 'The select => { distinct => ... } syntax is not supported for multiple columns.' - .' Instead please use { group_by => [ qw/' . (join ' ', @$rhs) . '/ ] }' - .' or { select => [ qw/' . (join ' ', @$rhs) . '/ ], distinct => 1 }' - ); - } - - my ($rhs_sql, @rhs_bind) = $self->_recurse_fields($rhs); - my $select = sprintf ('%s( %s )%s', - $self->_sqlcase($func), - $rhs_sql, - $as - ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) ) - : '' + $self->throw_exception( + "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) + ) if @toomany; + + $self->throw_exception ( + 'The select => { distinct => ... } syntax is not supported for multiple columns.' + .' Instead please use { group_by => [ qw/' . (join ' ', @$rhs) . '/ ] }' + .' or { select => [ qw/' . (join ' ', @$rhs) . '/ ], distinct => 1 }' + ) if ( + lc ($func) eq 'distinct' + and + ref $rhs eq 'ARRAY' + and + @$rhs > 1 ); - return ($select, @rhs_bind); - } - elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) { - return @{$$fields}; + my ($rhs_sql, @rhs_bind) = length ref $rhs + ? $self->_recurse_fields($rhs) + : $self->_quote($rhs) + ; + + return( + sprintf( '%s( %s )%s', + $self->_sqlcase($func), + $rhs_sql, + $as + ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) ) + : '' + ), + @rhs_bind + ); } + else { - $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} ); + $self->throw_exception( ref($fields) . ' unexpected in _recurse_fields()' ); } } diff --git a/lib/DBIx/Class/SQLMaker/LimitDialects.pm b/lib/DBIx/Class/SQLMaker/LimitDialects.pm index 89e63e092..0e6eb7e99 100644 --- a/lib/DBIx/Class/SQLMaker/LimitDialects.pm +++ b/lib/DBIx/Class/SQLMaker/LimitDialects.pm @@ -737,16 +737,22 @@ sub _subqueried_limit_attrs { my $s = $rs_attrs->{select}[$i]; my $sql_alias = (ref $s) eq 'HASH' ? $s->{-as} : undef; - # we throw away the @bind here deliberately - my ($sql_sel) = $self->_recurse_fields ($s); + my ($sql_sel) = length ref $s + # we throw away the @bind here deliberately + ? $self->_recurse_fields( $s ) + : $self->_quote( $s ) + ; push @sel, { arg => $s, sql => $sql_sel, - unquoted_sql => do { - local $self->{quote_char}; - ($self->_recurse_fields ($s))[0]; # ignore binds again - }, + unquoted_sql => ( length ref $s + ? do { + local $self->{quote_char}; + ($self->_recurse_fields ($s))[0]; # ignore binds again + } + : $s + ), as => $sql_alias || diff --git a/lib/DBIx/Class/Schema/Versioned.pm b/lib/DBIx/Class/Schema/Versioned.pm index f84bd0595..f6d598bad 100644 --- a/lib/DBIx/Class/Schema/Versioned.pm +++ b/lib/DBIx/Class/Schema/Versioned.pm @@ -216,7 +216,7 @@ use warnings; use base 'DBIx::Class::Schema'; use DBIx::Class::Carp; -use DBIx::Class::_Util 'dbic_internal_try'; +use DBIx::Class::_Util qw( dbic_internal_try UNRESOLVABLE_CONDITION ); use Scalar::Util 'weaken'; use namespace::clean; @@ -771,7 +771,7 @@ sub _source_exists my ($self, $rs) = @_; ( dbic_internal_try { - $rs->search(\'1=0')->cursor->next; + $rs->search( UNRESOLVABLE_CONDITION )->cursor->next; 1; } ) ? 1 diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 7be4202a3..16d68e52c 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -16,7 +16,7 @@ use DBIx::Class::_Util qw( quote_sub perlstring serialize dump_value dbic_internal_try dbic_internal_catch detected_reinvoked_destructor scope_guard - mkdir_p + mkdir_p UNRESOLVABLE_CONDITION ); use namespace::clean; @@ -2733,7 +2733,9 @@ sub _dbh_columns_info_for { return \%result if keys %result; } - my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0')); + my $sth = $dbh->prepare( + $self->sql_maker->select( $table, \'*', UNRESOLVABLE_CONDITION ) + ); $sth->execute; ### The acrobatics with lc names is necessary to support both the legacy diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm index b85fa78c3..75438d042 100644 --- a/lib/DBIx/Class/Storage/DBIHacks.pm +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -499,7 +499,11 @@ sub _resolve_aliastypes_from_select_args { grep { $_ !~ / \A \s* \( \s* SELECT \s+ .+? \s+ FROM \s+ .+? \) \s* \z /xsi } map - { ($sql_maker->_recurse_fields($_))[0] } + { + length ref $_ + ? ($sql_maker->_recurse_fields($_))[0] + : $sql_maker->_quote($_) + } @{$attrs->{select}} ], ordering => [ map diff --git a/t/sqlmaker/core_quoted.t b/t/sqlmaker/core_quoted.t index d483a4033..86820931d 100644 --- a/t/sqlmaker/core_quoted.t +++ b/t/sqlmaker/core_quoted.t @@ -4,7 +4,7 @@ use strict; use warnings; use Test::More; - +use Test::Warn; use DBICTest ':DiffSQL'; @@ -354,4 +354,15 @@ is_same_sql_bind( 'bracket quoted table names for UPDATE' ); + +# Warning and sane behavior on ... select => [] ... +warnings_exist { + local $TODO = "Some day we need to stop issuing implicit SELECT *"; + is_same_sql_bind( + $schema->resultset("Artist")->search({}, { columns => [] })->as_query, + '( SELECT 42 FROM [artist] [me] )', + [], + ); +} qr/\QResultSets with an empty selection are deprecated (you almost certainly did not mean to do that): if this is indeed your intent you must explicitly supply/; + done_testing; diff --git a/t/sqlmaker/nest_deprec.t b/t/sqlmaker/nest_deprec.t index 232274e54..6d430ca3f 100644 --- a/t/sqlmaker/nest_deprec.t +++ b/t/sqlmaker/nest_deprec.t @@ -17,7 +17,7 @@ my $sql_maker = $schema->storage->sql_maker; for my $expect_warn (1, 0) { warnings_like ( sub { - my ($sql, @bind) = $sql_maker->select ('foo', undef, { -nest => \ 'bar' } ); + my ($sql, @bind) = $sql_maker->select ('foo', '*', { -nest => \ 'bar' } ); is_same_sql_bind ( $sql, \@bind, 'SELECT * FROM foo WHERE ( bar )', [], From 6c5aa1fbffdc9e5679d2f68780b11a9569ec1993 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 27 Sep 2016 19:35:15 +0200 Subject: [PATCH 251/262] Fix func_rs() and as_subselect_rs() to start behaving as advertised No idea how it never got noticed, but both have been broken since the very first commits that introduced the methods ( 4fa7bc22 / e4bb6727 ). While changing them 7 years later is a rather serious modification of behavior, the old way never worked without users having to force-scalar each call site. If someone has been relying on e.g. [ func_rs(...) ] to return actual result objects instead of the resultset instance - things will blow up rather quickly and loudly (aside from the carp()-ed warning encouraging users to switch to scalar ctx explicitly) [ func( ... ) ] of course continues to behave like before (directly returning raw values off the cursor... sigh) --- Changes | 2 ++ lib/DBIx/Class/ResultSet.pm | 17 ++++++++++++++++- lib/DBIx/Class/ResultSetColumn.pm | 16 +++++++++++++++- t/88result_set_column.t | 7 +++++++ 4 files changed, 40 insertions(+), 2 deletions(-) diff --git a/Changes b/Changes index 6a63e5ba1..fabe41dc0 100644 --- a/Changes +++ b/Changes @@ -27,6 +27,8 @@ Revision history for DBIx::Class an underlying search_rs(), as by design these arguments would be used only on the first call to ->related_resultset(), and ignored afterwards. Instead an exception (detailing the fix) is thrown. + - Change func_rs() and as_subselect_rs() to properly ignore list + context (i.e. wantarray). Both were implemented broken from day 1 :/ - Increased checking for the correctness of the is_nullable attribute within the prefetch result parser may highlight previously unknown mismatches between your codebase and data source diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 2d6ea30d5..a274ee790 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -3504,6 +3504,21 @@ but because we isolated the group by into a subselect the above works. =cut sub as_subselect_rs { + + # FIXME - remove at some point in the future (2018-ish) + wantarray + and + carp_unique( + 'Starting with DBIC@0.082900 as_subselect_rs() always returns a ResultSet ' + . 'instance regardless of calling context. Please force scalar() context to ' + . 'silence this warning' + ) + and + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY + and + my $sog = fail_on_internal_wantarray + ; + my $self = shift; my $alias = $self->current_source_alias; @@ -3516,7 +3531,7 @@ sub as_subselect_rs { delete $fresh_rs->{cond}; delete @{$fresh_rs->{attrs}}{qw/where bind/}; - return $fresh_rs->search( {}, { + $fresh_rs->search_rs( {}, { from => [{ $alias => $self->as_query, -alias => $alias, diff --git a/lib/DBIx/Class/ResultSetColumn.pm b/lib/DBIx/Class/ResultSetColumn.pm index a5141390d..5b510de45 100644 --- a/lib/DBIx/Class/ResultSetColumn.pm +++ b/lib/DBIx/Class/ResultSetColumn.pm @@ -448,7 +448,21 @@ sub func_rs { $rs = $rs->as_subselect_rs; } - $rs->search( undef, { + # FIXME - remove at some point in the future (2018-ish) + wantarray + and + carp_unique( + 'Starting with DBIC@0.082900 func_rs() always returns a ResultSet ' + . 'instance regardless of calling context. Please force scalar() context to ' + . 'silence this warning' + ) + and + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY + and + my $sog = fail_on_internal_wantarray + ; + + $rs->search_rs( undef, { columns => { $self->{_as} => { $function => $select } } } ); } diff --git a/t/88result_set_column.t b/t/88result_set_column.t index f27c5dd86..7abf670c7 100644 --- a/t/88result_set_column.t +++ b/t/88result_set_column.t @@ -40,6 +40,13 @@ while (my $r = $rs_title->next) { is_deeply (\@all_titles, \@nexted_titles, 'next works'); +my @list_ctx; +warnings_exist { + @list_ctx = $rs_year->func_rs('DISTINCT'); +} [qr/\Qfunc_rs() always returns a ResultSet instance regardless of calling context/]; +is( scalar @list_ctx, 1, 'wantarray context does not affect func_rs'); +isa_ok( $list_ctx[0], 'DBIx::Class::ResultSet' ); +isa_ok( scalar( $rs_year->func_rs('DISTINCT') ), 'DBIx::Class::ResultSet' ); is_deeply( [ sort $rs_year->func('DISTINCT') ], [ 1997, 1998, 1999, 2001 ], "wantarray context okay"); ok ($max_year->next == $rs_year->max, q/get_column (\'FUNC') ok/); From c5340bfac7aff784999be6ab4fa803fd9440043f Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 30 Sep 2016 08:36:35 +0200 Subject: [PATCH 252/262] Tighten up code in ResultSetColumns, add INDIRECT annotations No functional changes (nothing else in lib/ and t/ had to change) --- lib/DBIx/Class/ResultSetColumn.pm | 48 +++++++++++++++---------------- lib/DBIx/Class/_Util.pm | 11 +++++++ 2 files changed, 35 insertions(+), 24 deletions(-) diff --git a/lib/DBIx/Class/ResultSetColumn.pm b/lib/DBIx/Class/ResultSetColumn.pm index 5b510de45..bde5f9a57 100644 --- a/lib/DBIx/Class/ResultSetColumn.pm +++ b/lib/DBIx/Class/ResultSetColumn.pm @@ -151,12 +151,10 @@ one value. =cut sub next { - my $self = shift; + #my $self = shift; # using cursor so we don't inflate anything - my ($row) = $self->_resultset->cursor->next; - - return $row; + ($_[0]->_resultset->cursor->next)[0]; } =head2 all @@ -178,10 +176,10 @@ than result objects. =cut sub all { - my $self = shift; + #my $self = shift; # using cursor so we don't inflate anything - return map { $_->[0] } $self->_resultset->cursor->all; + map { $_->[0] } $_[0]->_resultset->cursor->all; } =head2 reset @@ -202,9 +200,10 @@ Much like L. =cut sub reset { - my $self = shift; - $self->_resultset->cursor->reset; - return $self; + #my $self = shift; + + $_[0]->_resultset->reset; + $_[0]; } =head2 first @@ -224,14 +223,13 @@ Much like L but just returning the one value. =cut -sub first { - my $self = shift; +sub first :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; # using cursor so we don't inflate anything - $self->_resultset->cursor->reset; - my ($row) = $self->_resultset->cursor->next; - - return $row; + my $cursor = $_[0]->_resultset->cursor; + $cursor->reset; + ($cursor->next)[0]; } =head2 single @@ -251,14 +249,14 @@ is issued before discarding the cursor. =cut sub single { - my $self = shift; + #my $self = shift; - my $attrs = $self->_resultset->_resolved_attrs; - my ($row) = $self->_resultset->result_source->schema->storage->select_single( - $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs - ); + my $rs = $_[0]->_resultset; - return $row; + my $attrs = $rs->_resolved_attrs; + ($rs->result_source->schema->storage->select_single( + $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs + ))[0]; } =head2 min @@ -410,9 +408,11 @@ value. Produces the following SQL: =cut -sub func { - my ($self,$function) = @_; - my $cursor = $self->func_rs($function)->cursor; +sub func :DBIC_method_is_indirect_sugar{ + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + + #my ($self,$function) = @_; + my $cursor = $_[0]->func_rs($_[1])->cursor; if( wantarray ) { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray; diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 29b196dce..73f41e93b 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -1196,6 +1196,17 @@ sub fail_on_internal_call { $check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ and $check_fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there + and + # one step higher + @fr2 = CORE::caller(@fr2 ? 3 : 2) + and + # if the frame that called us is an indirect itself - nothing to see here + ! grep + { $_ eq 'DBIC_method_is_indirect_sugar' } + do { + no strict 'refs'; + attributes::get( \&{ $fr2[3] }) + } ) { DBIx::Class::Exception->throw( sprintf ( "Illegal internal call of indirect proxy-method %s() with argument '%s': examine the last lines of the proxy method deparse below to determine what to call directly instead at %s on line %d\n\n%s\n\n Stacktrace starts", From 97940e368df996e1fe6111fb14f560594dc4c0b2 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 29 Sep 2016 12:59:27 +0200 Subject: [PATCH 253/262] Mark forgotten ::Row::id() method as indirect_sugar Discouraged legacy sugar, which does not even work properly with multicolumn keys in scalar context. Mark properly as INDIRECT to ensure DBIC does not rely on it anywhere Also adjust the SanityChecker to not complain about shadowing of sugar methods with generated ones (i.e. column accessors) - while unfortunate, this kind of thing happens quite often (especially with such a generic name as 'id') and warning about it would make no sense (left alone that methods which are ..._generated_from_resultsource_metadata generally do not invoke next::method anyway) --- lib/DBIx/Class/PK.pm | 19 +++++++++++++------ lib/DBIx/Class/Schema/SanityChecker.pm | 6 +++++- lib/DBIx/Class/_Util.pm | 4 ++++ 3 files changed, 22 insertions(+), 7 deletions(-) diff --git a/lib/DBIx/Class/PK.pm b/lib/DBIx/Class/PK.pm index 9bda5cac4..0ef470b33 100644 --- a/lib/DBIx/Class/PK.pm +++ b/lib/DBIx/Class/PK.pm @@ -5,6 +5,9 @@ use warnings; use base qw/DBIx::Class::Row/; +use DBIx::Class::_Util 'fail_on_internal_call'; +use namespace::clean; + =head1 NAME DBIx::Class::PK - Primary Key class @@ -27,12 +30,16 @@ a class method. =cut -sub id { - my ($self) = @_; - $self->throw_exception( "Can't call id() as a class method" ) - unless ref $self; - my @id_vals = $self->_ident_values; - return (wantarray ? @id_vals : $id_vals[0]); +sub id :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + + $_[0]->throw_exception( "Can't call id() as a class method" ) + unless ref $_[0]; + + wantarray + ? $_[0]->_ident_values + : ($_[0]->_ident_values)[0] # FIXME - horrible horrible legacy crap + ; } sub _ident_values { diff --git a/lib/DBIx/Class/Schema/SanityChecker.pm b/lib/DBIx/Class/Schema/SanityChecker.pm index 4cc7958f6..ccfc0f3be 100644 --- a/lib/DBIx/Class/Schema/SanityChecker.pm +++ b/lib/DBIx/Class/Schema/SanityChecker.pm @@ -360,7 +360,11 @@ sub check_no_indirect_method_overrides { for (@$method_stack) { push @$nonsugar_methods, $_ and next - unless $_->{attributes}{DBIC_method_is_indirect_sugar}; + unless( + $_->{attributes}{DBIC_method_is_indirect_sugar} + or + $_->{attributes}{DBIC_method_is_generated_from_resultsource_metadata} + ); push @err, { overridden => { diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 73f41e93b..2d2caaafe 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -1130,6 +1130,10 @@ sub fail_on_internal_call { { package DB; $fr = [ CORE::caller(1) ]; + + # screwing with $DB::args is rather volatile - be extra careful + no warnings 'uninitialized'; + $argdesc = ( not defined $DB::args[0] ) ? 'UNAVAILABLE' : ( length ref $DB::args[0] ) ? DBIx::Class::_Util::refdesc($DB::args[0]) From 13fd7cde4bfdf09da40fedc02ade59bffb766925 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Wed, 28 Sep 2016 11:25:47 +0200 Subject: [PATCH 254/262] Restore the context sensitive m2m helper calling of ->search Subtly modified in 11e469d9, this prevents things like the ::IgnoreWantarray helper from taking effect in this case. An audit of all other wantarray() invoking sites did not reveal other issues --- lib/DBIx/Class/Relationship/ManyToMany.pm | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm index 2812b6bf0..7075fbdfe 100644 --- a/lib/DBIx/Class/Relationship/ManyToMany.pm +++ b/lib/DBIx/Class/Relationship/ManyToMany.pm @@ -70,13 +70,8 @@ EOW quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ), @main_meth_qsub_args; - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; - - my $rs = shift->%s( @_ ); - - wantarray ? $rs->all : $rs; + shift->%s( @_ )->search; EOC From 7474ed3b192693baa28d2f52de502f0ec3e8ac4e Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 30 Sep 2016 15:15:36 +0200 Subject: [PATCH 255/262] Audit and annotate all context-sensitive spots in ::Ordered Ensure an upcoming commit will not disturb the established (silly but still) API of the resultset-returning methods. Review, annotate and tighten up spots that have to do with wantarray-like behavior Not using the ASSERT_NO_INTERNAL_WANTARRAY macro as it is about to be retired in a subsequent commit. Instead adjust the INDIRECT guard to correctly interpret eval frames Zero functional changes --- lib/DBIx/Class/Ordered.pm | 131 +++++++++++++++++++++++++++++--------- lib/DBIx/Class/_Util.pm | 79 +++++++++++++---------- 2 files changed, 147 insertions(+), 63 deletions(-) diff --git a/lib/DBIx/Class/Ordered.pm b/lib/DBIx/Class/Ordered.pm index bf7f954ff..2ac0a0781 100644 --- a/lib/DBIx/Class/Ordered.pm +++ b/lib/DBIx/Class/Ordered.pm @@ -3,6 +3,9 @@ use strict; use warnings; use base qw( DBIx::Class ); +use DBIx::Class::_Util qw( bag_eq fail_on_internal_call ); +use namespace::clean; + =head1 NAME DBIx::Class::Ordered - Modify the position of objects in an ordered list. @@ -143,13 +146,28 @@ __PACKAGE__->mk_classaccessor( 'null_position_value' => 0 ); Returns an B resultset of all other objects in the same group excluding the one you called it on. +Underneath calls L, and therefore returns +objects by implicitly invoking Lall() >>|DBIx::Class::ResultSet/all> +in list context. + The ordering is a backwards-compatibility artifact - if you need a resultset with no ordering applied use C<_siblings> =cut + sub siblings { - my $self = shift; - return $self->_siblings->search ({}, { order_by => $self->position_column } ); + #my $self = shift; + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + wantarray + and + ! eval { fail_on_internal_call; 1 } + and + die "ILLEGAL LIST CONTEXT INVOCATION: $@"; + + # *MUST* be context sensitive due to legacy (DO NOT call search_rs) + $_[0]->_siblings->search ({}, { order_by => $_[0]->position_column } ); } =head2 previous_siblings @@ -160,15 +178,29 @@ sub siblings { Returns a resultset of all objects in the same group positioned before the object on which this method was called. +Underneath calls L, and therefore returns +objects by implicitly invoking Lall() >>|DBIx::Class::ResultSet/all> +in list context. + =cut sub previous_siblings { my $self = shift; my $position_column = $self->position_column; my $position = $self->get_column ($position_column); - return ( defined $position + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + wantarray + and + ! eval { fail_on_internal_call; 1 } + and + die "ILLEGAL LIST CONTEXT INVOCATION: $@"; + + # *MUST* be context sensitive due to legacy (DO NOT call search_rs) + defined( $position ) ? $self->_siblings->search ({ $position_column => { '<', $position } }) : $self->_siblings - ); + ; } =head2 next_siblings @@ -179,15 +211,29 @@ sub previous_siblings { Returns a resultset of all objects in the same group positioned after the object on which this method was called. +Underneath calls L, and therefore returns +objects by implicitly invoking Lall() >>|DBIx::Class::ResultSet/all> +in list context. + =cut sub next_siblings { my $self = shift; my $position_column = $self->position_column; my $position = $self->get_column ($position_column); - return ( defined $position + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + wantarray + and + ! eval { fail_on_internal_call; 1 } + and + die "ILLEGAL LIST CONTEXT INVOCATION: $@"; + + # *MUST* be context sensitive due to legacy (DO NOT call search_rs) + defined( $position ) ? $self->_siblings->search ({ $position_column => { '>', $position } }) : $self->_siblings - ); + ; } =head2 previous_sibling @@ -208,7 +254,7 @@ sub previous_sibling { { rows => 1, order_by => { '-desc' => $position_column } }, )->single; - return defined $psib ? $psib : 0; + return defined( $psib ) ? $psib : 0; } =head2 first_sibling @@ -229,7 +275,7 @@ sub first_sibling { { rows => 1, order_by => { '-asc' => $position_column } }, )->single; - return defined $fsib ? $fsib : 0; + return defined( $fsib ) ? $fsib : 0; } =head2 next_sibling @@ -249,7 +295,7 @@ sub next_sibling { { rows => 1, order_by => { '-asc' => $position_column } }, )->single; - return defined $nsib ? $nsib : 0; + return defined( $nsib ) ? $nsib : 0; } =head2 last_sibling @@ -269,7 +315,7 @@ sub last_sibling { { rows => 1, order_by => { '-desc' => $position_column } }, )->single; - return defined $lsib ? $lsib : 0; + return defined( $lsib ) ? $lsib : 0; } # an optimized method to get the last sibling position value without inflating a result object @@ -282,8 +328,7 @@ sub _last_sibling_posval { { rows => 1, order_by => { '-desc' => $position_column }, select => $position_column }, )->cursor; - my ($pos) = $cursor->next; - return $pos; + ($cursor->next)[0]; } =head2 move_previous @@ -762,8 +807,18 @@ sub _shift_siblings { # This method returns a resultset containing all members of the row # group (including the row itself). sub _group_rs { - my $self = shift; - return $self->result_source->resultset->search({$self->_grouping_clause()}); + #my $self = shift; + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + wantarray + and + ! eval { fail_on_internal_call; 1 } + and + die "ILLEGAL LIST CONTEXT INVOCATION: $@"; + + # *MUST* be context sensitive due to legacy (DO NOT call search_rs) + $_[0]->result_source->resultset->search({ $_[0]->_grouping_clause() }); } # Returns an unordered resultset of all objects in the same group @@ -772,7 +827,17 @@ sub _siblings { my $self = shift; my $position_column = $self->position_column; my $pos; - return defined ($pos = $self->get_column($position_column)) + + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + and + wantarray + and + ! eval { fail_on_internal_call; 1 } + and + die "ILLEGAL LIST CONTEXT INVOCATION: $@"; + + # *MUST* be context sensitive due to legacy (DO NOT call search_rs) + defined( $pos = $self->get_column($position_column) ) ? $self->_group_rs->search( { $position_column => { '!=' => $pos } }, ) @@ -815,17 +880,26 @@ sub _is_in_group { my ($self, $other) = @_; my $current = {$self->_grouping_clause}; - no warnings qw/uninitialized/; - - return 0 if ( - join ("\x00", sort keys %$current) - ne - join ("\x00", sort keys %$other) - ); - for my $key (keys %$current) { - return 0 if $current->{$key} ne $other->{$key}; - } - return 1; + ( + bag_eq( + [ keys %$current ], + [ keys %$other ], + ) + and + ! grep { + ( + defined( $current->{$_} ) + xor + defined( $other->{$_} ) + ) + or + ( + defined $current->{$_} + and + $current->{$_} ne $other->{$_} + ) + } keys %$other + ) ? 1 : 0; } # This is a short-circuited method, that is used internally by this @@ -841,9 +915,8 @@ sub _is_in_group { # you are doing use this method which bypasses any hooks introduced by # this module. sub _ordered_internal_update { - my $self = shift; - local $self->result_source->schema->{_ORDERED_INTERNAL_UPDATE} = 1; - return $self->update (@_); + local $_[0]->result_source->schema->{_ORDERED_INTERNAL_UPDATE} = 1; + shift->update (@_); } 1; diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 2d2caaafe..147614f3c 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -1126,38 +1126,7 @@ sub mkdir_p ($) { } sub fail_on_internal_call { - my ($fr, $argdesc); - { - package DB; - $fr = [ CORE::caller(1) ]; - - # screwing with $DB::args is rather volatile - be extra careful - no warnings 'uninitialized'; - - $argdesc = - ( not defined $DB::args[0] ) ? 'UNAVAILABLE' - : ( length ref $DB::args[0] ) ? DBIx::Class::_Util::refdesc($DB::args[0]) - : $DB::args[0] . '' - ; - }; - - my @fr2; - # need to make allowance for a proxy-yet-direct call - my $check_fr = ( - $fr->[0] eq 'DBIx::Class::ResultSourceProxy' - and - @fr2 = (CORE::caller(2)) - and - ( - ( $fr->[3] =~ /([^:])+$/ )[0] - eq - ( $fr2[3] =~ /([^:])+$/ )[0] - ) - ) - ? \@fr2 - : $fr - ; - + my $fr = [ CORE::caller(1) ]; die "\nMethod $fr->[3] is not marked with the 'DBIC_method_is_indirect_sugar' attribute\n\n" unless ( @@ -1194,12 +1163,36 @@ sub fail_on_internal_call { ); + my @fr2; + # need to make allowance for a proxy-yet-direct call + # or for an exception wrapper + $fr = \@fr2 if ( + ( + $fr->[3] eq '(eval)' + and + @fr2 = (CORE::caller(2)) + ) + or + ( + $fr->[0] eq 'DBIx::Class::ResultSourceProxy' + and + @fr2 = (CORE::caller(2)) + and + ( + ( $fr->[3] =~ /([^:])+$/ )[0] + eq + ( $fr2[3] =~ /([^:])+$/ )[0] + ) + ) + ); + + if ( defined $fr->[0] and - $check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ + $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ and - $check_fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there + $fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there and # one step higher @fr2 = CORE::caller(@fr2 ? 3 : 2) @@ -1212,6 +1205,24 @@ sub fail_on_internal_call { attributes::get( \&{ $fr2[3] }) } ) { + + my $argdesc; + + { + package DB; + + my @throwaway = caller( @fr2 ? 2 : 1 ); + + # screwing with $DB::args is rather volatile - be extra careful + no warnings 'uninitialized'; + + $argdesc = + ( not defined $DB::args[0] ) ? 'UNAVAILABLE' + : ( length ref $DB::args[0] ) ? DBIx::Class::_Util::refdesc($DB::args[0]) + : $DB::args[0] . '' + ; + }; + DBIx::Class::Exception->throw( sprintf ( "Illegal internal call of indirect proxy-method %s() with argument '%s': examine the last lines of the proxy method deparse below to determine what to call directly instead at %s on line %d\n\n%s\n\n Stacktrace starts", $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do { From a580a22749565b3b07f583bc04412e6dc0c84ab2 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Fri, 30 Sep 2016 09:08:55 +0200 Subject: [PATCH 256/262] Retire the ASSERT_NO_INTERNAL_WANTARRAY macro It was a good idea for its time, and helped clean up the codebase a lot, but ASSERT_NO_INTERNAL_INDIRECT_CALLS currently covers all its functionality and does so in a way less fragile (stateless) manner Mark several more methods as indirect_sugar, leaving only one forgotten spot for last (see next commit) No functional changes Read under -w --- lib/DBIx/Class/Relationship/Accessor.pm | 1 - lib/DBIx/Class/ResultSet.pm | 59 ++++++++++++------------- lib/DBIx/Class/ResultSetColumn.pm | 19 +++----- lib/DBIx/Class/_Util.pm | 56 +---------------------- 4 files changed, 35 insertions(+), 100 deletions(-) diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index e6d4fb4c7..d8a0d991f 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -160,7 +160,6 @@ EOC quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel ), @qsub_args; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; shift->related_resultset(%s)->search( @_ ) EOC diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index a274ee790..0a1cc5375 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -12,8 +12,7 @@ use Scalar::Util qw( blessed reftype ); use SQL::Abstract 'is_literal_value'; use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch dump_value emit_loud_diag - fail_on_internal_wantarray fail_on_internal_call - UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR + fail_on_internal_call UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR ); use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); use DBIx::Class::ResultSource::FromSpec::Util 'find_join_path_to_alias'; @@ -392,27 +391,24 @@ L. =cut sub search { - my $self = shift; - my $rs = $self->search_rs( @_ ); + my $rs = shift->search_rs( @_ ); - if (wantarray) { - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray; - return $rs->all; - } - elsif (defined wantarray) { - return $rs; - } - else { - # we can be called by a relationship helper, which in - # turn may be called in void context due to some braindead - # overload or whatever else the user decided to be clever - # at this particular day. Thus limit the exception to - # external code calls only - $self->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense') - if (caller)[0] !~ /^\QDBIx::Class::/; - - return (); - } + return $rs->all + if wantarray; + + return $rs + if defined wantarray; + + # we can be called by a relationship helper, which in + # turn may be called in void context due to some braindead + # overload or whatever else the user decided to be clever + # at this particular day. Thus limit the exception to + # external code calls only + $rs->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense') + if (caller)[0] !~ /^\QDBIx::Class::/; + + # we are in void ctx here, but just in case + return (); } =head2 search_rs @@ -699,7 +695,9 @@ Example of how to use C instead of C =cut -sub search_literal { +sub search_literal :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + my ($self, $sql, @bind) = @_; my $attr; if ( @bind && ref($bind[-1]) eq 'HASH' ) { @@ -1192,7 +1190,9 @@ instead. An example conversion is: =cut -sub search_like { +sub search_like :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + my $class = shift; carp_unique ( 'search_like() is deprecated and will be removed in DBIC version 0.09.' @@ -1223,7 +1223,9 @@ three records, call: =cut -sub slice { +sub slice :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + my ($self, $min, $max) = @_; my $attrs = {}; # = { %{ $self->{attrs} || {} } }; $attrs->{offset} = $self->{attrs}{offset} || 0; @@ -3512,12 +3514,7 @@ sub as_subselect_rs { 'Starting with DBIC@0.082900 as_subselect_rs() always returns a ResultSet ' . 'instance regardless of calling context. Please force scalar() context to ' . 'silence this warning' - ) - and - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY - and - my $sog = fail_on_internal_wantarray - ; + ); my $self = shift; diff --git a/lib/DBIx/Class/ResultSetColumn.pm b/lib/DBIx/Class/ResultSetColumn.pm index bde5f9a57..c3c80c945 100644 --- a/lib/DBIx/Class/ResultSetColumn.pm +++ b/lib/DBIx/Class/ResultSetColumn.pm @@ -5,7 +5,7 @@ use warnings; use base 'DBIx::Class'; use DBIx::Class::Carp; -use DBIx::Class::_Util qw( fail_on_internal_wantarray fail_on_internal_call ); +use DBIx::Class::_Util 'fail_on_internal_call'; use namespace::clean; =head1 NAME @@ -414,12 +414,10 @@ sub func :DBIC_method_is_indirect_sugar{ #my ($self,$function) = @_; my $cursor = $_[0]->func_rs($_[1])->cursor; - if( wantarray ) { - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray; - return map { $_->[ 0 ] } $cursor->all; - } - - return ( $cursor->next )[ 0 ]; + wantarray + ? map { $_->[ 0 ] } $cursor->all + : ( $cursor->next )[ 0 ] + ; } =head2 func_rs @@ -455,12 +453,7 @@ sub func_rs { 'Starting with DBIC@0.082900 func_rs() always returns a ResultSet ' . 'instance regardless of calling context. Please force scalar() context to ' . 'silence this warning' - ) - and - DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY - and - my $sog = fail_on_internal_wantarray - ; + ); $rs->search_rs( undef, { columns => { $self->{_as} => { $function => $select } } diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 147614f3c..6d9d75757 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -48,7 +48,6 @@ BEGIN { { substr($_, 5) => !!( $ENV{$_} ) } qw( DBIC_SHUFFLE_UNORDERED_RESULTSETS - DBIC_ASSERT_NO_INTERNAL_WANTARRAY DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE DBIC_ASSERT_NO_FAILING_SANITY_CHECKS @@ -198,8 +197,7 @@ BEGIN { *deep_clone = \&Storable::dclone } use base 'Exporter'; our @EXPORT_OK = qw( - sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt - fail_on_internal_wantarray fail_on_internal_call + sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt fail_on_internal_call refdesc refcount hrefaddr set_subname get_subname describe_class_methods scope_guard detected_reinvoked_destructor emit_loud_diag true false @@ -1073,58 +1071,6 @@ sub mkdir_p ($) { } -{ - my $list_ctx_ok_stack_marker; - - sub fail_on_internal_wantarray () { - return if $list_ctx_ok_stack_marker; - - if (! defined wantarray) { - croak('fail_on_internal_wantarray() needs a tempvar to save the stack marker guard'); - } - - my $cf = 1; - while ( ( (CORE::caller($cf+1))[3] || '' ) =~ / :: (?: - - # these are public API parts that alter behavior on wantarray - search | search_related | slice | search_literal - - | - - # these are explicitly prefixed, since we only recognize them as valid - # escapes when they come from the guts of CDBICompat - CDBICompat .*? :: (?: search_where | retrieve_from_sql | retrieve_all ) - - ) $/x ) { - $cf++; - } - - my ($fr, $want, $argdesc); - { - package DB; - $fr = [ CORE::caller($cf) ]; - $want = ( CORE::caller($cf-1) )[5]; - $argdesc = ref $DB::args[0] - ? DBIx::Class::_Util::refdesc($DB::args[0]) - : 'non ' - ; - }; - - if ( - $want and $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ - ) { - DBIx::Class::Exception->throw( sprintf ( - "Improper use of %s instance in list context at %s line %d\n\n Stacktrace starts", - $argdesc, @{$fr}[1,2] - ), 'with_stacktrace'); - } - - weaken( $list_ctx_ok_stack_marker = my $mark = [] ); - - $mark; - } -} - sub fail_on_internal_call { my $fr = [ CORE::caller(1) ]; From eab44f5277e5f7f479528b80beba4c306e75af54 Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 27 Sep 2016 19:49:19 +0200 Subject: [PATCH 257/262] Simplify guarded pass-through added to CDBI in ee333775 --- lib/DBIx/Class/CDBICompat/Relationships.pm | 5 ++++- t/cdbi/09-has_many.t | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm index f3c0c9c7a..7b08d07d9 100644 --- a/lib/DBIx/Class/CDBICompat/Relationships.pm +++ b/lib/DBIx/Class/CDBICompat/Relationships.pm @@ -218,7 +218,10 @@ sub search { } sub new_related { - return shift->search_related(shift)->new_result(@_); + $_[0]->throw_exception("Calling new_related() as a class method is not supported") + unless length ref $_[0]; + + shift->next::method(@_); } =head1 FURTHER QUESTIONS? diff --git a/t/cdbi/09-has_many.t b/t/cdbi/09-has_many.t index c06365728..bac11ed9b 100644 --- a/t/cdbi/09-has_many.t +++ b/t/cdbi/09-has_many.t @@ -50,7 +50,7 @@ eval { my $pj = Film->add_to_actors(\%pj_data) }; like $@, qr/class/, "add_to_actors must be object method"; eval { my $pj = $btaste->add_to_actors(%pj_data) }; -like $@, qr/Result object instantiation requires a single hashref argument/, "add_to_actors takes hash"; +like $@, qr/Result object instantiation requires a hashref as argument/, "add_to_actors takes hash"; ok( my $pj = $btaste->add_to_actors( From 367eaf50970dd3fd223ce5e1f0337703f2a6c70e Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Thu, 22 Sep 2016 11:46:18 +0200 Subject: [PATCH 258/262] Audit and minimize use of last major indirect method: search() I am not entirely sure how I missed it during 1b822bd3, but oh well. This should be the last highly volatile part ( as far as downstream is concerned ). As previously - zero functional changes apart from no longer calling search() at several spots (the SanityChecker ensures none of this results in silent breakage) All spots that *do* require wantarray()-specific behavior remained explicit wrappers for search(), instead of doing the wantarray() check themselves: this is a deliberate choice to allow DBIC::Helpers::ResultSet::IgnoreWantarray or similar libraries to continue operating by simply hooking the search() method --- lib/DBIx/Class/Admin.pm | 9 ++++++--- lib/DBIx/Class/CDBICompat/LazyLoading.pm | 5 ++--- lib/DBIx/Class/Ordered.pm | 16 ++++++++-------- lib/DBIx/Class/Relationship/Base.pm | 8 ++++---- lib/DBIx/Class/ResultSet.pm | 20 +++++++++++--------- lib/DBIx/Class/ResultSetColumn.pm | 2 +- lib/DBIx/Class/Row.pm | 17 +++++++++-------- lib/DBIx/Class/Schema/Versioned.pm | 4 ++-- lib/DBIx/Class/_Util.pm | 10 +++++++++- 9 files changed, 52 insertions(+), 39 deletions(-) diff --git a/lib/DBIx/Class/Admin.pm b/lib/DBIx/Class/Admin.pm index ed8ae7d3f..300c48540 100644 --- a/lib/DBIx/Class/Admin.pm +++ b/lib/DBIx/Class/Admin.pm @@ -480,7 +480,8 @@ sub update { $where ||= $self->where(); $set ||= $self->set(); my $resultset = $self->schema->resultset($rs); - $resultset = $resultset->search( ($where||{}) ); + $resultset = $resultset->search_rs( $where ) + if $where; my $count = $resultset->count(); print "This action will modify $count ".ref($resultset)." records.\n" if (!$self->quiet); @@ -511,7 +512,8 @@ sub delete { $where ||= $self->where(); $attrs ||= $self->attrs(); my $resultset = $self->schema->resultset($rs); - $resultset = $resultset->search( ($where||{}), ($attrs||()) ); + $resultset = $resultset->search_rs( ($where||{}), ($attrs||()) ) + if $where or $attrs; my $count = $resultset->count(); print "This action will delete $count ".ref($resultset)." records.\n" if (!$self->quiet); @@ -542,7 +544,8 @@ sub select { $where ||= $self->where(); $attrs ||= $self->attrs(); my $resultset = $self->schema->resultset($rs); - $resultset = $resultset->search( ($where||{}), ($attrs||()) ); + $resultset = $resultset->search_rs( ($where||{}), ($attrs||()) ) + if $where or $attrs; my @data; my @columns = $resultset->result_source->columns(); diff --git a/lib/DBIx/Class/CDBICompat/LazyLoading.pm b/lib/DBIx/Class/CDBICompat/LazyLoading.pm index b79a096a5..d14b4b748 100644 --- a/lib/DBIx/Class/CDBICompat/LazyLoading.pm +++ b/lib/DBIx/Class/CDBICompat/LazyLoading.pm @@ -8,9 +8,8 @@ use base 'DBIx::Class'; sub resultset_instance { my $self = shift; - my $rs = $self->next::method(@_); - $rs = $rs->search(undef, { columns => [ $self->columns('Essential') ] }); - return $rs; + $self->next::method(@_) + ->search_rs(undef, { columns => [ $self->columns('Essential') ] }); } diff --git a/lib/DBIx/Class/Ordered.pm b/lib/DBIx/Class/Ordered.pm index 2ac0a0781..cef565efd 100644 --- a/lib/DBIx/Class/Ordered.pm +++ b/lib/DBIx/Class/Ordered.pm @@ -249,7 +249,7 @@ sub previous_sibling { my $self = shift; my $position_column = $self->position_column; - my $psib = $self->previous_siblings->search( + my $psib = $self->previous_siblings->search_rs( {}, { rows => 1, order_by => { '-desc' => $position_column } }, )->single; @@ -270,7 +270,7 @@ sub first_sibling { my $self = shift; my $position_column = $self->position_column; - my $fsib = $self->previous_siblings->search( + my $fsib = $self->previous_siblings->search_rs( {}, { rows => 1, order_by => { '-asc' => $position_column } }, )->single; @@ -290,7 +290,7 @@ if the current object is the last one. sub next_sibling { my $self = shift; my $position_column = $self->position_column; - my $nsib = $self->next_siblings->search( + my $nsib = $self->next_siblings->search_rs( {}, { rows => 1, order_by => { '-asc' => $position_column } }, )->single; @@ -310,7 +310,7 @@ sibling. sub last_sibling { my $self = shift; my $position_column = $self->position_column; - my $lsib = $self->next_siblings->search( + my $lsib = $self->next_siblings->search_rs( {}, { rows => 1, order_by => { '-desc' => $position_column } }, )->single; @@ -323,7 +323,7 @@ sub _last_sibling_posval { my $self = shift; my $position_column = $self->position_column; - my $cursor = $self->next_siblings->search( + my $cursor = $self->next_siblings->search_rs( {}, { rows => 1, order_by => { '-desc' => $position_column }, select => $position_column }, )->cursor; @@ -423,7 +423,7 @@ sub move_to { $self->store_column( $position_column, ( $rsrc->resultset - ->search($self->_storage_ident_condition, { rows => 1, columns => $position_column }) + ->search_rs($self->_storage_ident_condition, { rows => 1, columns => $position_column }) ->cursor ->next )[0] || $self->throw_exception( @@ -775,7 +775,7 @@ sub _shift_siblings { $ord = 'desc'; } - my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } }); + my $shift_rs = $self->_group_rs-> search_rs ({ $position_column => { -between => \@between } }); # some databases (sqlite, pg, perhaps others) are dumb and can not do a # blanket increment/decrement without violating a unique constraint. @@ -791,7 +791,7 @@ sub _shift_siblings { ) { my $clean_rs = $rsrc->resultset; - for ( $shift_rs->search ( + for ( $shift_rs->search_rs ( {}, { order_by => { "-$ord", $position_column }, select => [$position_column, @pcols] } )->cursor->all ) { my $pos = shift @$_; diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index 5924db003..b7e74eb58 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -586,7 +586,7 @@ sub related_resultset { if( defined $jfc ) { - $rel_rset = $rsrc->related_source($rel)->resultset->search( + $rel_rset = $rsrc->related_source($rel)->resultset->search_rs( $jfc, $rel_info->{attrs}, ); @@ -612,10 +612,10 @@ sub related_resultset { my $obj_table_alias = lc($rsrc->source_name) . '__row'; $obj_table_alias =~ s/\W+/_/g; - $rel_rset = $rsrc->resultset->search( + $rel_rset = $rsrc->resultset->search_rs( $self->ident_condition($obj_table_alias), { alias => $obj_table_alias }, - )->related_resultset('me')->search(undef, $rel_info->{attrs}) + )->related_resultset('me')->search_rs(undef, $rel_info->{attrs}) } else { @@ -630,7 +630,7 @@ sub related_resultset { : weaken( $attrs->{related_objects}{$_} = $self ) for keys %$reverse; - $rel_rset = $rsrc->related_source($rel)->resultset->search( + $rel_rset = $rsrc->related_source($rel)->resultset->search_rs( UNRESOLVABLE_CONDITION, # guards potential use of the $rs in the future $attrs, ); diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 0a1cc5375..030f2924b 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -390,7 +390,9 @@ L. =cut -sub search { +sub search :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + my $rs = shift->search_rs( @_ ); return $rs->all @@ -932,7 +934,7 @@ sub find { } # Run the query, passing the result_class since it should propagate for find - my $rs = $self->search ($final_cond, {result_class => $self->result_class, %$attrs}); + my $rs = $self->search_rs( $final_cond, {result_class => $self->result_class, %$attrs} ); if ($rs->_resolved_attrs->{collapse}) { my $row = $rs->next; carp "Query returned more than one row" if $rs->next; @@ -1609,7 +1611,7 @@ C<< $rs->search ($cond, \%attrs)->count >> sub count { my $self = shift; - return $self->search(@_)->count if @_ and defined $_[0]; + return $self->search_rs(@_)->count if @_ and defined $_[0]; return scalar @{ $self->get_cache } if $self->get_cache; my $attrs = { %{ $self->_resolved_attrs } }; @@ -1657,7 +1659,7 @@ the same single value obtainable via L. sub count_rs { my $self = shift; - return $self->search(@_)->count_rs if @_; + return $self->search_rs(@_)->count_rs if @_; # this may look like a lack of abstraction (count() does about the same) # but in fact an _rs *must* use a subquery for the limits, as the @@ -1784,7 +1786,7 @@ sub _count_subq_rs { return $rsrc->resultset_class ->new ($rsrc, $sub_attrs) ->as_subselect_rs - ->search ({}, { columns => { count => $rsrc->schema->storage->_count_select ($rsrc, $attrs) } }) + ->search_rs ({}, { columns => { count => $rsrc->schema->storage->_count_select ($rsrc, $attrs) } }) ->get_column ('count'); } @@ -2015,7 +2017,7 @@ sub _rs_update_delete { } } - $subrs = $subrs->search({}, { group_by => $attrs->{columns} }); + $subrs = $subrs->search_rs({}, { group_by => $attrs->{columns} }); } $guard = $storage->txn_scope_guard; @@ -2543,10 +2545,10 @@ sub populate { } - $colinfo->{$rel}{rs}->search({ map # only so that we inherit them values properly, no actual search + $colinfo->{$rel}{rs}->search_rs({ map # only so that we inherit them values properly, no actual search { $_ => { '=' => - ( $main_proto_rs ||= $rsrc->resultset->search($main_proto) ) + ( $main_proto_rs ||= $rsrc->resultset->search_rs($main_proto) ) ->get_column( $colinfo->{$rel}{fk_map}{$_} ) ->as_query } @@ -3575,7 +3577,7 @@ sub _chain_relationship { # Nuke the prefetch (if any) before the new $rs attrs # are resolved (prefetch is useless - we are wrapping # a subquery anyway). - my $rs_copy = $self->search; + my $rs_copy = $self->search_rs; $rs_copy->{attrs}{join} = $self->_merge_joinpref_attr ( $rs_copy->{attrs}{join}, delete $rs_copy->{attrs}{prefetch}, diff --git a/lib/DBIx/Class/ResultSetColumn.pm b/lib/DBIx/Class/ResultSetColumn.pm index c3c80c945..1efdc35ee 100644 --- a/lib/DBIx/Class/ResultSetColumn.pm +++ b/lib/DBIx/Class/ResultSetColumn.pm @@ -514,7 +514,7 @@ sub _resultset { } } - $self->{_parent_resultset}->search(undef, { + $self->{_parent_resultset}->search_rs(undef, { columns => { $self->{_as} => $select } }); }; diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 7596f4a90..8b8f5fb08 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -1521,15 +1521,16 @@ L. =cut sub get_from_storage { - my $self = shift @_; - my $attrs = shift @_; - my $resultset = $self->result_source->resultset; + my $self = shift; - if(defined $attrs) { - $resultset = $resultset->search(undef, $attrs); - } - - return $resultset->find($self->_storage_ident_condition); + # with or without attrs? + ( + defined( $_[0] ) + ? $self->result_source->resultset->search_rs( undef, $_[0] ) + : $self->result_source->resultset + )->find( + $self->_storage_ident_condition + ); } =head2 discard_changes diff --git a/lib/DBIx/Class/Schema/Versioned.pm b/lib/DBIx/Class/Schema/Versioned.pm index f6d598bad..b75288eea 100644 --- a/lib/DBIx/Class/Schema/Versioned.pm +++ b/lib/DBIx/Class/Schema/Versioned.pm @@ -543,7 +543,7 @@ sub get_db_version my $vtable = $self->{vschema}->resultset('Table'); my $version = dbic_internal_try { - $vtable->search({}, { order_by => { -desc => 'installed' }, rows => 1 } ) + $vtable->search_rs({}, { order_by => { -desc => 'installed' }, rows => 1 } ) ->get_column ('version') ->next; }; @@ -771,7 +771,7 @@ sub _source_exists my ($self, $rs) = @_; ( dbic_internal_try { - $rs->search( UNRESOLVABLE_CONDITION )->cursor->next; + $rs->search_rs( UNRESOLVABLE_CONDITION )->cursor->next; 1; } ) ? 1 diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 6d9d75757..7e0520b23 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -1144,12 +1144,20 @@ sub fail_on_internal_call { @fr2 = CORE::caller(@fr2 ? 3 : 2) and # if the frame that called us is an indirect itself - nothing to see here - ! grep + (! grep { $_ eq 'DBIC_method_is_indirect_sugar' } do { no strict 'refs'; attributes::get( \&{ $fr2[3] }) } + ) + and + ( + $fr->[3] ne 'DBIx::Class::ResultSet::search' + or + # these are explicit wantarray-passthrough callsites for search() due to old silly API choice + $fr2[3] !~ /^DBIx::Class::Ordered::(?: _group_rs | (?: _ | next_ | previous_ )? siblings )/x + ) ) { my $argdesc; From 9ab0364d36a4357b766f6dfccfb1df5ef69b079b Mon Sep 17 00:00:00 2001 From: Peter Rabbitson Date: Tue, 27 Sep 2016 20:20:13 +0200 Subject: [PATCH 259/262] Simplify internal implementation of as_subselect_rs Zero functional changes --- lib/DBIx/Class/ResultSet.pm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 1d6d177ed..2d6ea30d5 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -3506,7 +3506,7 @@ but because we isolated the group by into a subselect the above works. sub as_subselect_rs { my $self = shift; - my $attrs = $self->_resolved_attrs; + my $alias = $self->current_source_alias; my $fresh_rs = (ref $self)->new ( $self->result_source @@ -3518,11 +3518,11 @@ sub as_subselect_rs { return $fresh_rs->search( {}, { from => [{ - $attrs->{alias} => $self->as_query, - -alias => $attrs->{alias}, + $alias => $self->as_query, + -alias => $alias, -rsrc => $self->result_source, }], - alias => $attrs->{alias}, + alias => $alias, }); } From d8cf3aa31fb3d6ff7813f021fcc002663725fc41 Mon Sep 17 00:00:00 2001 From: Matt S Trout Date: Thu, 8 Dec 2016 18:38:46 +0000 Subject: [PATCH 260/262] Introduce GOVERNANCE document and empty RESOLUTIONS file. To understand the process that lead to this commit, you'll probably need to read all of: http://lists.scsys.co.uk/pipermail/dbix-class/2016-October/date.html http://lists.scsys.co.uk/pipermail/dbix-class/2016-November/date.html http://lists.scsys.co.uk/pipermail/dbix-class/2016-December/date.html Any attempt on my part to summarise it would likely seem insufficiently accurate to me and biased to at least some readers, so I'm not even going to pretend to try. If you're trying to achieve a tl;dr, I suggest checking the December archive in the hopes that somebody posts a summary there some time after I push this commit. --- GOVERNANCE | 125 ++++++++++++++++++++++++++++++++++++++++++++++++++++ RESOLUTIONS | 0 2 files changed, 125 insertions(+) create mode 100644 GOVERNANCE create mode 100644 RESOLUTIONS diff --git a/GOVERNANCE b/GOVERNANCE new file mode 100644 index 000000000..1ddce3c49 --- /dev/null +++ b/GOVERNANCE @@ -0,0 +1,125 @@ +DBIx::Class Core Team and Voting System + +Non normative section: + +DBIx::Class originally operated under a BDFL system, but one where it was +expected that an informal core team would be maintained, and that where +consensus could not be pre-assumed, the core team and/or the user base +would be consulted publically such that measured decisions could be made. + +This document is intended to formalise a form of this system, while still +providing room for the system to adapt later as required. + +It is intended that this system provides confidence to the user base that +decisions will be made in the open and that their wishes will be taken into +account. + +It is also intended that this system allows business as usual to happen +without unnecessary red tape. + +It is not intended that this system becomes the primary decision making +process in and of itself; instead, it is intended that this system is used +to ratify consensus as formed by discussion, and only sparingly as a tie +breaking system when consensus cannot be reached. + +Normative section: + +Terms: VM - Voting Member - part of the benevolent dictatorship + LS - List Subscriber - a subscriber to the mailing list + LAV - List Aggregate Vote - the aggregate vote of the non-VM LSes + +Voting Members are: + + Matt S Trout (mst) cpan:MSTROUT + Dagfinn Ilmari Mansaker (ilmari) cpan:ILMARI + Frew Schmidt (frew) cpan:FREW + Jess Robinson (castaway) cpan:JROBINSON + +PAUSE release perms are to be held by: + + Matt S Trout (mst) cpan:MSTROUT + Dagfinn Ilmari Mansaker (ilmari) cpan:ILMARI + Frew Schmidt (frew) cpan:FREW + Jess Robinson (castaway) cpan:JROBINSON + +First come permissions are to be held by FREW. + +(the above two lists may or may not be identical at any given time) + +A resolution must be proposed and then successfully voted upon to: + + - Make a PAUSE-indexed (i.e. non-dev) release of DBIx::Class + - Make changes to the master and blead branches of the repository + - Amend this document + +This document is currently in bootstrap phase, and as such no merges will be +made to master or blead until this sentence is removed. + +A resolution that amends the 'PAUSE release perms' list is to be assumed to +also intend the permission within PAUSE itself to be updated accordingly. + +Adding or removing entries from the list of situations requiring resolutions +is absolutely a valid topic for resolutions. + +A resolution may be proposed for reasons including, but not limited to: + + - Force/revert/block a branch merge + - Add/remove a commit bit + - Resolve a design discussion + - Anything you like, under the assumption frivolous proposals will be + voted down naturally anyway + +Merges to topic branches and similar actions that do not have a resolution +attached may be made at the discretion of those with ability to do so, but +a developer unsure if the merge will be uncontroversial is expected to ping +the list first so a vote can be called if people believe it to be required. + +Rules that restrict this "ask unless you're sure" trust-by-default position +are also absolutely a valid topic for resolutions. + +Resolution proposal: + +A resolution is proposed by starting a new thread entitled 'PROPOSAL: ...' + +A resolution must be seconded before it is voted upon. + +If a VM makes or seconds a proposal, they are required to abstain from +voting upon it. + +If a non-VM LS makes or seconds a proposal, no such restriction applies. + +Resolution voting: + +Once a proposal is seconded, the initial proposer may start a new thread +entitled 'VOTE: ...' (voting does not automatically begin after seconding +in case other feedback leads the proposer to wish to alter and re-present +their proposal). + +Each VM may cast one vote, either +1, -1 or abstain. + +Each non-VM LS may post +1 or -1, and the aggregate of those form the LAV. + +Voting closes after 72h from when the proposal was first posted. + +A resolution passes if the VM total is at least +1 and the LAV is +non-negative, to avoid requiring the list members to expend time to vote on +business as usual while still providing them a veto. + +Resolution forcing: + +If a resolution gains a positive LAV, but is voted down by the VMs, a force +vote may be proposed. This requires two list members who did not propose or +second the initial resolution to propose and second the force vote. + +A force vote also lasts 72h, and is LAV-only. If it receives at least 25% +more +1s than -1s, the resolution passes no matter the VM vote. + +This mechanism is not intended to be needed on a regular basis, but exists +to permit the list to forcibly recall a VM if they believe it to be necessary. + +Once a resolution has passed, the resolution will be carried out by those with +the power to do so. It will not be reverted without a new resolution +amending or reversing the decision of the previous once. + +Passed resolutions will be recorded in a RESOLUTIONS file maintained next +to this document. diff --git a/RESOLUTIONS b/RESOLUTIONS new file mode 100644 index 000000000..e69de29bb From 9f29d1b0c1e73dd64f112439f5d0866e50755fc3 Mon Sep 17 00:00:00 2001 From: Alastair McGowan-Douglas Date: Tue, 3 Nov 2015 13:20:49 +0000 Subject: [PATCH 261/262] Allow SQLT options to be passed to unique constraints --- lib/DBIx/Class/ResultSource.pm | 123 +++++++++++++++++++----- lib/SQL/Translator/Parser/DBIx/Class.pm | 9 +- 2 files changed, 103 insertions(+), 29 deletions(-) diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index ddef5449c..aa8338b2b 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -1063,7 +1063,7 @@ sub sequence { =over 4 -=item Arguments: $name?, \@colnames +=item Arguments: $name?, \%uq_info | \@colnames =item Return Value: not defined @@ -1072,14 +1072,45 @@ sub sequence { Declare a unique constraint on this source. Call once for each unique constraint. +The C key to the C<\%uq_info> hashref will be an arrayref +containing the columns to affect. + # For UNIQUE (column1, column2) + __PACKAGE__->add_unique_constraint( + constraint_name => { + columns => [ qw/column1 column2/ ], + } + ); + +Currently, the key C is also supported, which will be +passed to L. + + __PACKAGE__->add_unique_constraint( + constraint_name => { + columns => [ qw/column1 column2/ ], + sqlt_extra => { deferrable => 1 }, + } + ); + +Alternatively, you can use the columns arrayref directly, although +this form is discouraged. + __PACKAGE__->add_unique_constraint( constraint_name => [ qw/column1 column2/ ], ); -Alternatively, you can specify only the columns: +Finally, you can also omit the constraint name; but this is also discouraged. - __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]); + __PACKAGE__->add_unique_constraint( + [ qw/column1 column2/ ], + ); + + __PACKAGE__->add_unique_constraint( + { + columns => [ qw/column1 column2/ ], + sqlt_extra => { deferrable => 1 }, + } + ); This will result in a unique constraint named C, where C is replaced with the table @@ -1092,6 +1123,10 @@ only columns in the constraint are searched. Throws an error if any of the given column names do not yet exist on the result source. +Note also that the keys C
, C, and C in +C will be ignored. See +L for other valid keys. + =cut sub add_unique_constraint { @@ -1107,25 +1142,37 @@ sub add_unique_constraint { ); } - my $cols = pop @_; - if (ref $cols ne 'ARRAY') { + my $constraint = pop @_; + + if (ref $constraint eq 'ARRAY') { + $constraint = { + columns => $constraint + }; + } + elsif (ref $constraint ne 'HASH') { + $self->throw_exception ( + 'Expecting a hashref of constraint info, got ' . ($constraint||'NOTHING') + ); + } + + if (! $constraint->{columns}) { $self->throw_exception ( - 'Expecting an arrayref of constraint columns, got ' . ($cols||'NOTHING') + 'Expecting "columns" key in hashref, but it was not present' ); } my $name = shift @_; - $name ||= $self->name_unique_constraint($cols); + $name ||= $self->name_unique_constraint($constraint->{columns}); - foreach my $col (@$cols) { + foreach my $col (@{$constraint->{columns}}) { $self->throw_exception("No such column $col on table " . $self->name) unless $self->has_column($col); } - my %unique_constraints = $self->unique_constraints; - $unique_constraints{$name} = $cols; - $self->_unique_constraints(\%unique_constraints); + my $unique_constraints = $self->_unique_constraints; + $unique_constraints->{$name} = $constraint; + $self->_unique_constraints($unique_constraints); } =head2 add_unique_constraints @@ -1141,25 +1188,21 @@ sub add_unique_constraint { Declare multiple unique constraints on this source. __PACKAGE__->add_unique_constraints( - constraint_name1 => [ qw/column1 column2/ ], - constraint_name2 => [ qw/column2 column3/ ], - ); - -Alternatively, you can specify only the columns: - - __PACKAGE__->add_unique_constraints( - [ qw/column1 column2/ ], - [ qw/column3 column4/ ] + constraint_name1 => { + columns => [ qw/column1 column2/ ] + }, + constraint_name2 => { + columns => [ qw/column2 column3/ ] + }, ); -This will result in unique constraints named C and -C, where C
is replaced with the table name. +Works exactly like L, inasmuch as you can +omit the column names, or use just the arrayrefs; but the form shown +above is preferred. Throws an error if any of the given column names do not yet exist on the result source. -See also L. - =cut sub add_unique_constraints :DBIC_method_is_indirect_sugar { @@ -1240,7 +1283,37 @@ column names as values. =cut sub unique_constraints { - return %{shift->_unique_constraints||{}}; + my $uniques = shift->_unique_constraints || {}; + + return map { $_ => $uniques->{$_}->{columns} } keys %$uniques; +} + +=head2 unique_constraints_info + +=over 4 + +=item Arguments: none + +=item Return Value: Hashref of unique constraint data + +=back + + my $unique_info = $source->unique_constraints_info(); + +Read-only accessor returning all information about unique constraints. + +The hashref is keyed by the constraint name, and the values are the +hashrefs originally provided to L (or +L). See L for the +structure of these hashrefs. + +B that while similar functions return flattened hashes as a +list, this one returns a single hashref; just like L. + +=cut + +sub unique_constraints_info { + return shift->_unique_constraints; } =head2 unique_constraint_names diff --git a/lib/SQL/Translator/Parser/DBIx/Class.pm b/lib/SQL/Translator/Parser/DBIx/Class.pm index 14812ac93..3c7c2004f 100644 --- a/lib/SQL/Translator/Parser/DBIx/Class.pm +++ b/lib/SQL/Translator/Parser/DBIx/Class.pm @@ -153,13 +153,14 @@ sub parse { $table->primary_key(@primary) if @primary; - my %unique_constraints = $source->unique_constraints; - foreach my $uniq (sort keys %unique_constraints) { + my $unique_constraints = $source->unique_constraints_info; + foreach my $uniq (sort keys %$unique_constraints) { $table->add_constraint( + %{ $unique_constraints->{$uniq}->{sqlt_extra} || {} }, type => 'unique', name => $uniq, - fields => $unique_constraints{$uniq} - ) unless bag_eq( \@primary, $unique_constraints{$uniq} ); + fields => $unique_constraints->{$uniq}->{columns} + ) unless bag_eq( \@primary, $unique_constraints->{$uniq}->{columns} ); } my @rels = $source->relationships(); From fc0b714c4a4165e4926992591bff4472560c05d8 Mon Sep 17 00:00:00 2001 From: Alastair McGowan-Douglas Date: Tue, 3 Nov 2015 15:11:56 +0000 Subject: [PATCH 262/262] Test SQLT gets told about deferrable unique --- t/99dbic_sqlt_parser.t | 9 +++++++++ t/lib/DBICTest/Schema/Track.pm | 5 ++++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/t/99dbic_sqlt_parser.t b/t/99dbic_sqlt_parser.t index 2ab43a33e..f2ac4ca72 100644 --- a/t/99dbic_sqlt_parser.t +++ b/t/99dbic_sqlt_parser.t @@ -125,6 +125,15 @@ my $idx_exceptions = { my $idx_test = join("\x00", $index->fields); isnt ( $pk_test, $idx_test, "no additional index for the primary columns exists in $source_name"); } + + my $deferrables = grep { + $_->name eq 'track_cd_position' + and $_->type eq 'UNIQUE' + and $_->deferrable == 1 + } + get_table($sqlt_schema, $schema, 'Track')->get_constraints; + + is ($deferrables, 1, "a deferrable unique constraint called track_cd_position exists on Track"); } } diff --git a/t/lib/DBICTest/Schema/Track.pm b/t/lib/DBICTest/Schema/Track.pm index ef3b14de4..2787a7e9c 100644 --- a/t/lib/DBICTest/Schema/Track.pm +++ b/t/lib/DBICTest/Schema/Track.pm @@ -44,7 +44,10 @@ __PACKAGE__->add_columns( ); __PACKAGE__->set_primary_key('trackid'); -__PACKAGE__->add_unique_constraint([ qw/cd position/ ]); +__PACKAGE__->add_unique_constraint({ + columns => [ qw/cd position/ ], + sqlt_extra => { deferrable => 1 } +}); __PACKAGE__->add_unique_constraint([ qw/cd title/ ]); __PACKAGE__->position_column ('position');