From: Peter Rabbitson Date: Wed, 17 Apr 2013 07:34:50 +0000 (+0200) Subject: Merge branch 'master' into topic/constructor_rewrite X-Git-Tag: v0.08250~31^2~21 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=723f25e0;hp=894108b6db72b567cb54c2cf5d0accc1854f76ac;p=dbsrgits%2FDBIx-Class.git Merge branch 'master' into topic/constructor_rewrite Add some extra code to enforce the assumption that any bind type constant is accessible in _dbi_attrs_for_bind, or in other words that all necessary DBDs are already loaded (concept originally introduced in ad7c50fc) Without this the combination of 9930caaf7e (do not recalculate bind attrs on dbh_do retry) and a2f228547 (do not wrap iterators in dbh_do) can result in _dbi_attrs_for_bind being called before DBI/DBD::* has been loaded at all --- diff --git a/.travis.yml b/.travis.yml index f51eeac..5db8be1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -82,6 +82,7 @@ matrix: - CLEANTEST=false - BREWOPTS="-Duseithreads" - BREWVER=5.8.5 + - DBIC_TRACE_PROFILE=console # minimum supported without threads - perl: 5.8.3_nt @@ -89,6 +90,7 @@ matrix: - CLEANTEST=false - BREWOPTS="" - BREWVER=5.8.3 + - DBIC_TRACE_PROFILE=console_monochrome # check CLEANTEST of minimum supported - perl: 5.8.3_nt_mb @@ -111,6 +113,26 @@ matrix: - BREWOPTS="-Duseithreads -Dusemorebits" - BREWVER=5.8.8 + # some permutations of tracing and envvar poisoning + - perl: 5.16 + env: + - CLEANTEST=false + - POISON_ENV=true + + - perl: 5.16 + env: + - CLEANTEST=true + - POISON_ENV=true + - DBIC_TRACE=1 + - DBIC_TRACE_PROFILE=console + + - perl: 5.16 + env: + - CLEANTEST=false + - POISON_ENV=true + - DBIC_TRACE=1 + - DBIC_TRACE_PROFILE=console_monochrome + # sourcing the files is *EXTREMELY* important - otherwise # no envvars will survive diff --git a/Changes b/Changes index fc2b3a1..6b9a3b4 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,28 @@ Revision history for DBIx::Class + * Fixes + - Fix _dbi_attrs_for_bind() being called befor DBI has been loaded + (regression in 0.08210) + - Fix update/delete operations on resultsets *joining* the updated + table failing on MySQL. Resolves oversights in the fixes for + RT#81378 and RT#81897 + - Stop Sybase ASE storage from generating invalid SQL in subselects + when a limit without offset is encountered + +0.08210 2013-04-04 15:30 (UTC) + * New Features / Changes + - Officially deprecate the 'cols' and 'include_columns' resultset + attributes + - Remove ::Storage::DBI::sth() deprecated in 0.08191 + + * Fixes + - Work around a *critical* bug with potential for data loss in + DBD::SQLite - RT#79576 + - Audit and correct potential bugs associated with braindead reuse + of $1 on unsuccessful matches + - Fix incorrect warning/exception originator reported by carp*() and + throw_exception() + 0.08242-TRIAL (EXPERIMENTAL BETA RELEASE) 2013-03-10 14:44 (UTC) * New Features / Changes - Prefetch with limit on right-side ordered resultsets now works diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index 630230b..ca0d03b 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -95,6 +95,10 @@ sub _attr_cache { 1; +__END__ + +=encoding UTF-8 + =head1 NAME DBIx::Class - Extensible and flexible object <-> relational mapper. @@ -131,41 +135,11 @@ list below is sorted by "fastest response time": =back -=head1 HOW TO CONTRIBUTE - -Contributions are always welcome, in all usable forms (we especially -welcome documentation improvements). The delivery methods include git- -or unified-diff formatted patches, GitHub pull requests, or plain bug -reports either via RT or the Mailing list. Contributors are generally -granted full access to the official repository after their first patch -passes successful review. - -=for comment -FIXME: Getty, frew and jnap need to get off their asses and finish the contrib section so we can link it here ;) - -This project is maintained in a git repository. The code and related tools are -accessible at the following locations: - -=over - -=item * Official repo: L - -=item * Official gitweb: L - -=item * GitHub mirror: L - -=item * Authorized committers: L - -=item * Travis-CI log: L - -=for html -
↪ Stable branch CI status: - -=back - =head1 SYNOPSIS -Create a schema class called MyApp/Schema.pm: +=head2 Schema classes preparation + +Create a schema class called F: package MyApp::Schema; use base qw/DBIx::Class::Schema/; @@ -175,7 +149,7 @@ Create a schema class called MyApp/Schema.pm: 1; Create a result class to represent artists, who have many CDs, in -MyApp/Schema/Result/Artist.pm: +F: See L for docs on defining result classes. @@ -190,7 +164,7 @@ See L for docs on defining result classes. 1; A result class to represent a CD, which belongs to an artist, in -MyApp/Schema/Result/CD.pm: +F: package MyApp::Schema::Result::CD; use base qw/DBIx::Class::Core/; @@ -203,6 +177,8 @@ MyApp/Schema/Result/CD.pm: 1; +=head2 API usage + Then you can use these classes in your application's code: # Connect to your database. @@ -271,7 +247,8 @@ that allows abstract encapsulation of database operations. It aims to make representing queries in your code as perl-ish as possible while still providing access to as many of the capabilities of the database as possible, including retrieving related records from multiple tables in a single query, -JOIN, LEFT JOIN, COUNT, DISTINCT, GROUP BY, ORDER BY and HAVING support. +C, C, C, C, C, C and +C support. DBIx::Class can handle multi-column primary and foreign keys, complex queries and database-level paging, and does its best to only query the @@ -284,8 +261,8 @@ and thread-safe out of the box (although L). This project is still under rapid development, so large new features may be -marked EXPERIMENTAL - such APIs are still usable but may have edge bugs. -Failing test cases are *always* welcome and point releases are put out rapidly +marked B - such APIs are still usable but may have edge bugs. +Failing test cases are I welcome and point releases are put out rapidly as bugs are found and fixed. We do our best to maintain full backwards compatibility for published @@ -297,6 +274,38 @@ The test suite is quite substantial, and several developer releases are generally made to CPAN before the branch for the next release is merged back to trunk for a major release. +=head1 HOW TO CONTRIBUTE + +Contributions are always welcome, in all usable forms (we especially +welcome documentation improvements). The delivery methods include git- +or unified-diff formatted patches, GitHub pull requests, or plain bug +reports either via RT or the Mailing list. Contributors are generally +granted full access to the official repository after their first patch +passes successful review. + +=for comment +FIXME: Getty, frew and jnap need to get off their asses and finish the contrib section so we can link it here ;) + +This project is maintained in a git repository. The code and related tools are +accessible at the following locations: + +=over + +=item * Official repo: L + +=item * Official gitweb: L + +=item * GitHub mirror: L + +=item * Authorized committers: L + +=item * Travis-CI log: L + +=for html +↪ Stable branch CI status: + +=back + =head1 AUTHOR mst: Matt S. Trout @@ -362,8 +371,12 @@ clkao: CL Kao da5id: David Jack Olrik +dariusj: Darius Jokilehto + davewood: David Schmidt +daxim: Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯 + debolaz: Anders Nor Berle dew: Dan Thomas @@ -563,5 +576,3 @@ as listed above. This library is free software and may be distributed under the same terms as perl itself. - -=cut diff --git a/lib/DBIx/Class/CDBICompat/Constraints.pm b/lib/DBIx/Class/CDBICompat/Constraints.pm index bc44462..1014886 100644 --- a/lib/DBIx/Class/CDBICompat/Constraints.pm +++ b/lib/DBIx/Class/CDBICompat/Constraints.pm @@ -16,7 +16,7 @@ sub constrain_column { } elsif (ref $how eq "Regexp") { $class->add_constraint(regexp => $col => sub { shift =~ $how }); } else { - $how =~ m/([^:]+)$/; + $how =~ m/([^:]+)$/; # match is safe - we throw above on empty $how my $try_method = sprintf '_constrain_by_%s', lc $1; # $how->moniker; if (my $dispatch = $class->can($try_method)) { $class->$dispatch($col => ($how, @_)); diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm index 85aced2..aaa19a0 100644 --- a/lib/DBIx/Class/CDBICompat/ImaDBI.pm +++ b/lib/DBIx/Class/CDBICompat/ImaDBI.pm @@ -88,7 +88,9 @@ sub set_sql { sub { my $sql = $sql; my $class = shift; - return $class->storage->_sth($class->transform_sql($sql, @_)); + return $class->storage->dbh_do( + _prepare_sth => $class->transform_sql($sql, @_) + ); }; if ($sql =~ /select/i) { my $search_name = "search_${name}"; diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm index d27df5d..24ddd13 100644 --- a/lib/DBIx/Class/Carp.pm +++ b/lib/DBIx/Class/Carp.pm @@ -18,6 +18,8 @@ BEGIN { use Carp (); use namespace::clean (); +$Carp::Internal{ (__PACKAGE__) }++; + sub __find_caller { my ($skip_pattern, $class) = @_; @@ -28,8 +30,21 @@ sub __find_caller { if $skip_class_data; my $fr_num = 1; # skip us and the calling carp* - my @f; + + my (@f, $origin); while (@f = caller($fr_num++)) { + + next if + ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ ); + + $origin ||= ( + $f[3] =~ /^ (.+) :: ([^\:]+) $/x + and + ! $Carp::Internal{$1} + and + $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once )$/x + ) ? $f[3] : undef; + if ( $f[0]->can('_skip_namespace_frames') and @@ -41,14 +56,15 @@ sub __find_caller { last if $f[0] !~ $skip_pattern; } - my ($ln, $calling) = @f # if empty - nothing matched - full stack - ? ( "at $f[1] line $f[2]", $f[3] ) - : ( Carp::longmess(), '{UNKNOWN}' ) + my $site = @f # if empty - nothing matched - full stack + ? "at $f[1] line $f[2]" + : Carp::longmess() ; + $origin ||= '{UNKNOWN}'; return ( - $ln, - $calling =~ /::/ ? "$calling(): " : "$calling: ", # cargo-cult from Carp::Clan + $site, + $origin =~ /::/ ? "$origin(): " : "$origin: ", # cargo-cult from Carp::Clan ); }; diff --git a/lib/DBIx/Class/Exception.pm b/lib/DBIx/Class/Exception.pm index 1f56cb5..58319d9 100644 --- a/lib/DBIx/Class/Exception.pm +++ b/lib/DBIx/Class/Exception.pm @@ -4,6 +4,7 @@ use strict; use warnings; use DBIx::Class::Carp (); +$Carp::Internal{ (__PACKAGE__) }++; use overload '""' => sub { shift->{msg} }, diff --git a/lib/DBIx/Class/Manual/Cookbook.pod b/lib/DBIx/Class/Manual/Cookbook.pod index 21d720e..70b8b82 100644 --- a/lib/DBIx/Class/Manual/Cookbook.pod +++ b/lib/DBIx/Class/Manual/Cookbook.pod @@ -1357,9 +1357,9 @@ row. }); } catch { $exception = $_; - } + }; - if ($caught) { + if ($exception) { # There was an error while handling the $job. Rollback all changes # since the transaction started, including the already committed # ('released') savepoints. There will be neither a new $job nor any diff --git a/lib/DBIx/Class/Relationship/HasMany.pm b/lib/DBIx/Class/Relationship/HasMany.pm index 16fa0ba..c9d1777 100644 --- a/lib/DBIx/Class/Relationship/HasMany.pm +++ b/lib/DBIx/Class/Relationship/HasMany.pm @@ -36,7 +36,7 @@ sub has_many { $f_key = $cond; $guess = "caller specified foreign key '$f_key'"; } else { - $class =~ /([^\:]+)$/; + $class =~ /([^\:]+)$/; # match is safe - $class can't be '' $f_key = lc $1; # go ahead and guess; best we can do $guess = "using our class name '$class' as foreign key"; } diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index a2e3a4c..955a3c3 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -443,6 +443,7 @@ sub search_rs { # older deprecated name, use only if {columns} is not there if (my $c = delete $new_attrs->{cols}) { + carp_unique( "Resultset attribute 'cols' is deprecated, use 'columns' instead" ); if ($new_attrs->{columns}) { carp "Resultset specifies both the 'columns' and the legacy 'cols' attributes - ignoring 'cols'"; } @@ -489,8 +490,12 @@ sub _normalize_selection { my ($self, $attrs) = @_; # legacy syntax - $attrs->{'+columns'} = $self->_merge_attr($attrs->{'+columns'}, delete $attrs->{include_columns}) - if exists $attrs->{include_columns}; + if ( exists $attrs->{include_columns} ) { + carp_unique( "Resultset attribute 'include_columns' is deprecated, use '+columns' instead" ); + $attrs->{'+columns'} = $self->_merge_attr( + $attrs->{'+columns'}, delete $attrs->{include_columns} + ); + } # columns are always placed first, however @@ -2606,16 +2611,9 @@ sub as_query { my $attrs = { %{ $self->_resolved_attrs } }; - # For future use: - # - # in list ctx: - # my ($sql, \@bind, \%dbi_bind_attrs) = _select_args_to_query (...) - # $sql also has no wrapping parenthesis in list ctx - # - my $sqlbind = $self->result_source->storage - ->_select_args_to_query ($attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs); - - return $sqlbind; + $self->result_source->storage->_select_args_to_query ( + $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs + ); } =head2 find_or_new @@ -3919,7 +3917,7 @@ case the key is the C value, and the value is used as the C from that, then auto-populates C from C and L. @@ -3938,10 +3936,10 @@ is the same as =back -Indicates additional columns to be selected from storage. Works the same -as L but adds columns to the selection. (You may also use the -C attribute, as in earlier versions of DBIC). For -example:- +Indicates additional columns to be selected from storage. Works the same as +L but adds columns to the selection. (You may also use the +C attribute, as in earlier versions of DBIC, but this is +deprecated). For example:- $schema->resultset('CD')->search(undef, { '+columns' => ['artist.name'], diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index bdc7aee..87c6c76 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -134,16 +134,16 @@ sub __new_related_find_or_new_helper { my $proc_data = { $new_rel_obj->get_columns }; if ($self->__their_pk_needs_us($relname)) { - MULTICREATE_DEBUG and warn "MC $self constructing $relname via new_result"; + MULTICREATE_DEBUG and print STDERR "MC $self constructing $relname via new_result\n"; return $new_rel_obj; } elsif ($rsrc->_pk_depends_on($relname, $proc_data )) { if (! keys %$proc_data) { # there is nothing to search for - blind create - MULTICREATE_DEBUG and warn "MC $self constructing default-insert $relname"; + MULTICREATE_DEBUG and print STDERR "MC $self constructing default-insert $relname\n"; } else { - MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new"; + MULTICREATE_DEBUG and print STDERR "MC $self constructing $relname via find_or_new\n"; # this is not *really* find or new, as we don't want to double-new the # data (thus potentially double encoding or whatever) my $exists = $rel_rs->find ($proc_data); @@ -214,7 +214,7 @@ sub new { $new->{_rel_in_storage}{$key} = 1; $new->set_from_related($key, $rel_obj); } else { - MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj\n"; + MULTICREATE_DEBUG and print STDERR "MC $new uninserted $key $rel_obj\n"; } $related->{$key} = $rel_obj; @@ -234,7 +234,7 @@ sub new { $rel_obj->throw_exception ('A multi relationship can not be pre-existing when doing multicreate. Something went wrong'); } else { MULTICREATE_DEBUG and - warn "MC $new uninserted $key $rel_obj (${\($idx+1)} of $total)\n"; + print STDERR "MC $new uninserted $key $rel_obj (${\($idx+1)} of $total)\n"; } push(@objects, $rel_obj); } @@ -251,7 +251,7 @@ sub new { $new->{_rel_in_storage}{$key} = 1; } else { - MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj"; + MULTICREATE_DEBUG and print STDERR "MC $new uninserted $key $rel_obj\n"; } $inflated->{$key} = $rel_obj; next; @@ -363,7 +363,7 @@ sub insert { # The guard will save us if we blow out of this scope via die $rollback_guard ||= $storage->txn_scope_guard; - MULTICREATE_DEBUG and warn "MC $self pre-reconstructing $relname $rel_obj\n"; + MULTICREATE_DEBUG and print STDERR "MC $self pre-reconstructing $relname $rel_obj\n"; my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_columns }; my $existing; @@ -395,7 +395,7 @@ sub insert { MULTICREATE_DEBUG and do { no warnings 'uninitialized'; - warn "MC $self inserting (".join(', ', $self->get_columns).")\n"; + print STDERR "MC $self inserting (".join(', ', $self->get_columns).")\n"; }; # perform the insert - the storage will return everything it is asked to @@ -440,14 +440,14 @@ sub insert { $obj->set_from_related($_, $self) for keys %$reverse; if ($self->__their_pk_needs_us($relname)) { if (exists $self->{_ignore_at_insert}{$relname}) { - MULTICREATE_DEBUG and warn "MC $self skipping post-insert on $relname"; + MULTICREATE_DEBUG and print STDERR "MC $self skipping post-insert on $relname\n"; } else { - MULTICREATE_DEBUG and warn "MC $self inserting $relname $obj"; + MULTICREATE_DEBUG and print STDERR "MC $self inserting $relname $obj\n"; $obj->insert; } } else { - MULTICREATE_DEBUG and warn "MC $self post-inserting $obj"; + MULTICREATE_DEBUG and print STDERR "MC $self post-inserting $obj\n"; $obj->insert(); } } diff --git a/lib/DBIx/Class/SQLMaker/LimitDialects.pm b/lib/DBIx/Class/SQLMaker/LimitDialects.pm index 7639988..a5ac467 100644 --- a/lib/DBIx/Class/SQLMaker/LimitDialects.pm +++ b/lib/DBIx/Class/SQLMaker/LimitDialects.pm @@ -358,9 +358,12 @@ sub _prep_for_skimming_limit { for my $ch ($self->_order_by_chunks ($inner_order)) { $ch = $ch->[0] if ref $ch eq 'ARRAY'; - $ch =~ s/\s+ ( ASC|DESC ) \s* $//ix; - my $dir = uc ($1||'ASC'); - push @out_chunks, \join (' ', $ch, $dir eq 'ASC' ? 'DESC' : 'ASC' ); + my $is_desc = ( + $ch =~ s/\s+ ( ASC|DESC ) \s* $//ix + and + uc($1) eq 'DESC' + ) ? 1 : 0; + push @out_chunks, \join (' ', $ch, $is_desc ? 'ASC' : 'DESC' ); } $sq_attrs->{order_by_middle} = $self->_order_by (\@out_chunks); @@ -506,32 +509,6 @@ sub _FetchFirst { return $sql; } -=head2 RowCountOrGenericSubQ - -This is not exactly a limit dialect, but more of a proxy for B. -If no $offset is supplied the limit is simply performed as: - - SET ROWCOUNT $limit - SELECT ... - SET ROWCOUNT 0 - -Otherwise we fall back to L - -=cut - -sub _RowCountOrGenericSubQ { - my $self = shift; - my ($sql, $rs_attrs, $rows, $offset) = @_; - - return $self->_GenericSubQ(@_) if $offset; - - return sprintf <<"EOF", $rows, $sql, $self->_parse_rs_attrs( $rs_attrs ); -SET ROWCOUNT %d -%s %s -SET ROWCOUNT 0 -EOF -} - =head2 GenericSubQ SELECT * FROM ( @@ -569,8 +546,9 @@ sub _GenericSubQ { . 'unique-column order criteria.' ); - $first_order_by =~ s/\s+ ( ASC|DESC ) \s* $//ix; - my $direction = lc ($1 || 'asc'); + my $direction = ( + $first_order_by =~ s/\s+ ( ASC|DESC ) \s* $//ix + ) ? lc($1) : 'asc'; my ($first_ord_alias, $first_ord_col) = $first_order_by =~ /^ (?: ([^\.]+) \. )? ([^\.]+) $/x; diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 3bf644a..d864853 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -1093,8 +1093,7 @@ Attempts to deploy the schema to the current storage using L. See L for a list of values for C<\%sqlt_args>. The most common value for this would be C<< { add_drop_table => 1 } >> to have the SQL produced include a C statement for each table -created. For quoting purposes supply C and -C. +created. For quoting purposes supply C. Additionally, the DBIx::Class parser accepts a C parameter as a hash ref or an array ref, containing a list of source to deploy. If present, then diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm index 6b88d28..f5f2951 100644 --- a/lib/DBIx/Class/Storage.pm +++ b/lib/DBIx/Class/Storage.pm @@ -470,6 +470,8 @@ sub debugobj { $self->{debugobj} ||= do { if (my $profile = $ENV{DBIC_TRACE_PROFILE}) { require DBIx::Class::Storage::Debug::PrettyPrint; + my @pp_args; + if ($profile =~ /^\.?\//) { require Config::Any; @@ -481,10 +483,28 @@ sub debugobj { $self->throw_exception("Failure processing \$ENV{DBIC_TRACE_PROFILE}: $_"); }; - DBIx::Class::Storage::Debug::PrettyPrint->new(values %{$cfg->[0]}); + @pp_args = values %{$cfg->[0]}; } else { - DBIx::Class::Storage::Debug::PrettyPrint->new({ profile => $profile }); + @pp_args = { profile => $profile }; + } + + # FIXME - FRAGILE + # Hash::Merge is a sorry piece of shit and tramples all over $@ + # *without* throwing an exception + # This is a rather serious problem in the debug codepath + # Insulate the condition here with a try{} until a review of + # DBIx::Class::Storage::Debug::PrettyPrint takes place + # we do rethrow the error unconditionally, the only reason + # to try{} is to preserve the precise state of $@ (down + # to the scalar (if there is one) address level) + # + # Yes I am aware this is fragile and TxnScopeGuard needs + # a better fix. This is another yak to shave... :( + try { + DBIx::Class::Storage::Debug::PrettyPrint->new(@pp_args); + } catch { + $self->throw_exception($_); } } else { diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 9c622f8..d207767 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -1703,22 +1703,68 @@ sub _execute { my ($sql, $bind) = $self->_prep_for_execute($op, $ident, \@args); - shift->dbh_do( # retry over disconnects - '_dbh_execute', + # not even a PID check - we do not care about the state of the _dbh. + # All we need is to get the appropriate drivers loaded if they aren't + # already so that the assumption in ad7c50fc26e holds + $self->_populate_dbh unless $self->_dbh; + + $self->dbh_do( _dbh_execute => # retry over disconnects $sql, $bind, - $ident, + $self->_dbi_attrs_for_bind($ident, $bind), ); } sub _dbh_execute { - my ($self, undef, $sql, $bind, $ident) = @_; + my ($self, $dbh, $sql, $bind, $bind_attrs) = @_; $self->_query_start( $sql, $bind ); - my $bind_attrs = $self->_dbi_attrs_for_bind($ident, $bind); + my $sth = $self->_bind_sth_params( + $self->_prepare_sth($dbh, $sql), + $bind, + $bind_attrs, + ); + + # Can this fail without throwing an exception anyways??? + my $rv = $sth->execute(); + $self->throw_exception( + $sth->errstr || $sth->err || 'Unknown error: execute() returned false, but error flags were not set...' + ) if !$rv; + + $self->_query_end( $sql, $bind ); + + return (wantarray ? ($rv, $sth, @$bind) : $rv); +} + +sub _prepare_sth { + my ($self, $dbh, $sql) = @_; + + # 3 is the if_active parameter which avoids active sth re-use + my $sth = $self->disable_sth_caching + ? $dbh->prepare($sql) + : $dbh->prepare_cached($sql, {}, 3); + + # XXX You would think RaiseError would make this impossible, + # but apparently that's not true :( + $self->throw_exception( + $dbh->errstr + || + sprintf( "\$dbh->prepare() of '%s' through %s failed *silently* without " + .'an exception and/or setting $dbh->errstr', + length ($sql) > 20 + ? substr($sql, 0, 20) . '...' + : $sql + , + 'DBD::' . $dbh->{Driver}{Name}, + ) + ) if !$sth; + + $sth; +} - my $sth = $self->_sth($sql); +sub _bind_sth_params { + my ($self, $sth, $bind, $bind_attrs) = @_; for my $i (0 .. $#$bind) { if (ref $bind->[$i][1] eq 'SCALAR') { # any scalarrefs are assumed to be bind_inouts @@ -1730,26 +1776,21 @@ sub _dbh_execute { ); } else { + # FIXME SUBOPTIMAL - most likely this is not necessary at all + # confirm with dbi-dev whether explicit stringification is needed + my $v = ( length ref $bind->[$i][1] and overload::Method($bind->[$i][1], '""') ) + ? "$bind->[$i][1]" + : $bind->[$i][1] + ; $sth->bind_param( $i + 1, - (ref $bind->[$i][1] and overload::Method($bind->[$i][1], '""')) - ? "$bind->[$i][1]" - : $bind->[$i][1] - , + $v, $bind_attrs->[$i], ); } } - # Can this fail without throwing an exception anyways??? - my $rv = $sth->execute(); - $self->throw_exception( - $sth->errstr || $sth->err || 'Unknown error: execute() returned false, but error flags were not set...' - ) if !$rv; - - $self->_query_end( $sql, $bind ); - - return (wantarray ? ($rv, $sth, @$bind) : $rv); + $sth; } sub _prefetch_autovalues { @@ -1886,14 +1927,15 @@ sub insert_bulk { my @col_range = (0..$#$cols); - # FIXME - perhaps this is not even needed? does DBI stringify? + # FIXME SUBOPTIMAL - most likely this is not necessary at all + # confirm with dbi-dev whether explicit stringification is needed # # forcibly stringify whatever is stringifiable # ResultSet::populate() hands us a copy - safe to mangle for my $r (0 .. $#$data) { for my $c (0 .. $#{$data->[$r]}) { $data->[$r][$c] = "$data->[$r][$c]" - if ( ref $data->[$r][$c] and overload::Method($data->[$r][$c], '""') ); + if ( length ref $data->[$r][$c] and overload::Method($data->[$r][$c], '""') ); } } @@ -2077,7 +2119,7 @@ sub insert_bulk { my $guard = $self->txn_scope_guard; $self->_query_start( $sql, @$proto_bind ? [[undef => '__BULK_INSERT__' ]] : () ); - my $sth = $self->_sth($sql); + my $sth = $self->_prepare_sth($self->_dbh, $sql); my $rv = do { if (@$proto_bind) { # proto bind contains the information on which pieces of $data to pull @@ -2243,13 +2285,11 @@ sub _select_args_to_query { $self->_select_args(@_); # my ($sql, $prepared_bind) = $self->_gen_sql_bind($op, $ident, [ $select, $cond, $rs_attrs, $rows, $offset ]); - my ($sql, $prepared_bind) = $self->_gen_sql_bind($op, $ident, \@args); - $prepared_bind ||= []; + my ($sql, $bind) = $self->_gen_sql_bind($op, $ident, \@args); - return wantarray - ? ($sql, $prepared_bind) - : \[ "($sql)", @$prepared_bind ] - ; + # reuse the bind arrayref + unshift @{$bind}, "($sql)"; + \$bind; } sub _select_args { @@ -2395,42 +2435,6 @@ see L. =cut -sub _dbh_sth { - my ($self, $dbh, $sql) = @_; - - # 3 is the if_active parameter which avoids active sth re-use - my $sth = $self->disable_sth_caching - ? $dbh->prepare($sql) - : $dbh->prepare_cached($sql, {}, 3); - - # XXX You would think RaiseError would make this impossible, - # but apparently that's not true :( - $self->throw_exception( - $dbh->errstr - || - sprintf( "\$dbh->prepare() of '%s' through %s failed *silently* without " - .'an exception and/or setting $dbh->errstr', - length ($sql) > 20 - ? substr($sql, 0, 20) . '...' - : $sql - , - 'DBD::' . $dbh->{Driver}{Name}, - ) - ) if !$sth; - - $sth; -} - -sub sth { - carp_unique 'sth was mistakenly marked/documented as public, stop calling it (will be removed before DBIC v0.09)'; - shift->_sth(@_); -} - -sub _sth { - my ($self, $sql) = @_; - $self->dbh_do('_dbh_sth', $sql); # retry over disconnects -} - sub _dbh_columns_info_for { my ($self, $dbh, $table) = @_; @@ -2658,8 +2662,7 @@ $version in the name with "$preversion-$version". See L for a list of values for C<\%sqlt_args>. The most common value for this would be C<< { add_drop_table => 1 } >> to have the SQL produced include a C statement for each table -created. For quoting purposes supply C and -C. +created. For quoting purposes supply C. If no arguments are passed, then the following default values are assumed: diff --git a/lib/DBIx/Class/Storage/DBI/ADO.pm b/lib/DBIx/Class/Storage/DBI/ADO.pm index 0e5c286..705a598 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO.pm @@ -67,7 +67,7 @@ sub _init { # Here I was just experimenting with ADO cursor types, left in as a comment in # case you want to as well. See the DBD::ADO docs. -#sub _dbh_sth { +#sub _prepare_sth { # my ($self, $dbh, $sql) = @_; # # my $sth = $self->disable_sth_caching diff --git a/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm b/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm index 8b7e2a3..4676fc4 100644 --- a/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm +++ b/lib/DBIx/Class/Storage/DBI/Firebird/Common.pm @@ -60,9 +60,10 @@ EOF $sth->execute($table_name); while (my ($trigger) = $sth->fetchrow_array) { - my @trig_cols = map { - /^"([^"]+)/ ? $1 : uc($1) - } $trigger =~ /new\.("?\w+"?)/ig; + my @trig_cols = map + { /^"([^"]+)/ ? $1 : uc($_) } + $trigger =~ /new\.("?\w+"?)/ig + ; my ($quoted, $generator) = $trigger =~ /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix; diff --git a/lib/DBIx/Class/Storage/DBI/MSSQL.pm b/lib/DBIx/Class/Storage/DBI/MSSQL.pm index 679fe7c..fc505fa 100644 --- a/lib/DBIx/Class/Storage/DBI/MSSQL.pm +++ b/lib/DBIx/Class/Storage/DBI/MSSQL.pm @@ -106,28 +106,26 @@ sub last_insert_id { shift->_identity } # http://sqladvice.com/forums/permalink/18496/22931/ShowThread.aspx#22931 # sub _select_args_to_query { + #my ($self, $ident, $select, $cond, $attrs) = @_; my $self = shift; + my $attrs = $_[3]; - my ($sql, $prep_bind, @rest) = $self->next::method (@_); + my $sql_bind = $self->next::method (@_); # see if this is an ordered subquery - my $attrs = $_[3]; if ( - $sql !~ /^ \s* SELECT \s+ TOP \s+ \d+ \s+ /xi - && + $$sql_bind->[0] !~ /^ \s* \( \s* SELECT \s+ TOP \s+ \d+ \s+ /xi + and scalar $self->_extract_order_criteria ($attrs->{order_by}) ) { $self->throw_exception( 'An ordered subselect encountered - this is not safe! Please see "Ordered Subselects" in DBIx::Class::Storage::DBI::MSSQL' ) unless $attrs->{unsafe_subselect_ok}; - my $max = $self->sql_maker->__max_int; - $sql =~ s/^ \s* SELECT \s/SELECT TOP $max /xi; + + $$sql_bind->[0] =~ s/^ \s* \( \s* SELECT (?=\s) / '(SELECT TOP ' . $self->sql_maker->__max_int /exi; } - return wantarray - ? ($sql, $prep_bind, @rest) - : \[ "($sql)", @$prep_bind ] - ; + $sql_bind; } 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 073837f..911ca48 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm @@ -24,7 +24,7 @@ to Microsoft SQL Server over ODBC =head1 DESCRIPTION This class implements support specific to Microsoft SQL Server over ODBC. It is -loaded automatically by by DBIx::Class::Storage::DBI::ODBC when it detects a +loaded automatically by DBIx::Class::Storage::DBI::ODBC when it detects a MSSQL back-end. Most of the functionality is provided from the superclass diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm index af68023..568b561 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm @@ -284,7 +284,7 @@ sub _ping { } sub _dbh_execute { - #my ($self, $dbh, $sql, $bind, $ident) = @_; + #my ($self, $dbh, $sql, $bind, $bind_attrs) = @_; my ($self, $bind) = @_[0,3]; # Turn off sth caching for multi-part LOBs. See _prep_for_execute below diff --git a/lib/DBIx/Class/Storage/DBI/Pg.pm b/lib/DBIx/Class/Storage/DBI/Pg.pm index 3e59028..fcdab67 100644 --- a/lib/DBIx/Class/Storage/DBI/Pg.pm +++ b/lib/DBIx/Class/Storage/DBI/Pg.pm @@ -104,7 +104,7 @@ sub _dbh_get_autoinc_seq { )); } - return $1; + return $1; # exception thrown unless match is made above } # custom method for fetching column default, since column_info has a diff --git a/lib/DBIx/Class/Storage/DBI/Replicated.pm b/lib/DBIx/Class/Storage/DBI/Replicated.pm index adfe403..c6b7b12 100644 --- a/lib/DBIx/Class/Storage/DBI/Replicated.pm +++ b/lib/DBIx/Class/Storage/DBI/Replicated.pm @@ -317,8 +317,6 @@ my $method_dispatch = { sql_maker_class _execute _do_query - _sth - _dbh_sth _dbh_execute /, Class::MOP::Class->initialize('DBIx::Class::Storage::DBIHacks')->get_method_list ], reader => [qw/ @@ -359,7 +357,8 @@ my $method_dispatch = { _is_binary_type _is_text_lob_type - sth + _prepare_sth + _bind_sth_params /,( # the capability framework # not sure if CMOP->initialize does evil things to DBIC::S::DBI, fix if a problem diff --git a/lib/DBIx/Class/Storage/DBI/SQLite.pm b/lib/DBIx/Class/Storage/DBI/SQLite.pm index 14c07d2..db46ce2 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLite.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLite.pm @@ -7,7 +7,6 @@ use base qw/DBIx::Class::Storage::DBI/; use mro 'c3'; use DBIx::Class::Carp; -use Scalar::Util 'looks_like_number'; use Try::Tiny; use namespace::clean; @@ -30,6 +29,47 @@ DBIx::Class::Storage::DBI::SQLite - Automatic primary key class for SQLite This class implements autoincrements for SQLite. +=head2 Known Issues + +=over + +=item RT79576 + + NOTE - This section applies to you only if ALL of these are true: + + * You are or were using DBD::SQLite with a version lesser than 1.38_01 + + * You are or were using DBIx::Class versions between 0.08191 and 0.08209 + (inclusive) or between 0.08240-TRIAL and 0.08242-TRIAL (also inclusive) + + * You use objects with overloaded stringification and are feeding them + to DBIC CRUD methods directly + +An unfortunate chain of events led to DBIx::Class silently hitting the problem +described in L. + +In order to trigger the bug condition one needs to supply B +bind value that is an object with overloaded stringification (nummification +is not relevant, only stringification is). When this is the case the internal +DBIx::Class call to C<< $sth->bind_param >> would be executed in a way that +triggers the above-mentioned DBD::SQLite bug. As a result all the logs and +tracers will contain the expected values, however SQLite will receive B +these bind positions being set to the value of the B supplied +stringifiable object. + +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 will currently detect when this condition (more than one +stringifiable object in one CRUD call) is encountered and will issue a warning +pointing to this section. This warning will be removed 2 years from now, +around April 2015, You can disable it after you've audited your data by +setting the C environment variable. Note - the warning +is emited only once per callsite per process and only when the condition in +question is encountered. Thus it is very unlikey that your logsystem will be +flooded as a result of this. + +=back + =head1 METHODS =cut @@ -207,9 +247,17 @@ sub bind_attribute_by_data_type { # version is detected sub _dbi_attrs_for_bind { my ($self, $ident, $bind) = @_; + my $bindattrs = $self->next::method($ident, $bind); + # an attempt to detect former effects of RT#79576, bug itself present between + # 0.08191 and 0.08209 inclusive (fixed in 0.08210 and higher) + my $stringifiable = 0; + for (0.. $#$bindattrs) { + + $stringifiable++ if ( length ref $bind->[$_][1] and overload::Method($bind->[$_][1], '""') ); + if ( defined $bindattrs->[$_] and @@ -217,16 +265,24 @@ sub _dbi_attrs_for_bind { and $bindattrs->[$_] eq DBI::SQL_INTEGER() and - ! looks_like_number ($bind->[$_][1]) + $bind->[$_][1] !~ /^ [\+\-]? [0-9]+ (?: \. 0* )? $/x ) { carp_unique( sprintf ( - "Non-numeric value supplied for column '%s' despite the numeric datatype", + "Non-integer value supplied for column '%s' despite the integer datatype", $bind->[$_][0]{dbic_colname} || "# $_" ) ); undef $bindattrs->[$_]; } } + carp_unique( + 'POSSIBLE *PAST* DATA CORRUPTION detected - see ' + . 'DBIx::Class::Storage::DBI::SQLite/RT79576 or ' + . 'http://v.gd/DBIC_SQLite_RT79576 for further details or set ' + . '$ENV{DBIC_RT79576_NOWARN} to disable this warning. Trigger ' + . 'condition encountered' + ) if (!$ENV{DBIC_RT79576_NOWARN} and $stringifiable > 1); + return $bindattrs; } diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm index 346dcd9..29563f0 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm @@ -18,7 +18,7 @@ use Try::Tiny; use Context::Preserve 'preserve_context'; use namespace::clean; -__PACKAGE__->sql_limit_dialect ('RowCountOrGenericSubQ'); +__PACKAGE__->sql_limit_dialect ('GenericSubQ'); __PACKAGE__->sql_quote_char ([qw/[ ]/]); __PACKAGE__->datetime_parser_type( 'DBIx::Class::Storage::DBI::Sybase::ASE::DateTime::Format' @@ -254,8 +254,7 @@ sub _is_lob_column { } sub _prep_for_execute { - my $self = shift; - my $ident = $_[1]; + my ($self, $op, $ident, $args) = @_; # ### This is commented out because all tests pass. However I am leaving it @@ -274,7 +273,20 @@ sub _prep_for_execute { # = $self->_parent_storage->_perform_autoinc_retrieval #if ($op eq 'insert' or $op eq 'update') and $self->_parent_storage; - my ($sql, $bind) = $self->next::method (@_); + my $limit; # extract and use shortcut on limit without offset + if ($op eq 'select' and ! $args->[4] and $limit = $args->[3]) { + $args = [ @$args ]; + $args->[3] = undef; + } + + my ($sql, $bind) = $self->next::method($op, $ident, $args); + + # $limit is already sanitized by now + $sql = join( "\n", + "SET ROWCOUNT $limit", + $sql, + "SET ROWCOUNT 0", + ) if $limit; if (my $identity_col = $self->_perform_autoinc_retrieval) { $sql .= "\n" . $self->_fetch_identity_sql($ident, $identity_col) diff --git a/lib/DBIx/Class/Storage/DBI/mysql.pm b/lib/DBIx/Class/Storage/DBI/mysql.pm index ae55f1f..a2aa2fc 100644 --- a/lib/DBIx/Class/Storage/DBI/mysql.pm +++ b/lib/DBIx/Class/Storage/DBI/mysql.pm @@ -5,7 +5,6 @@ use warnings; use base qw/DBIx::Class::Storage::DBI/; -use List::Util 'first'; use namespace::clean; __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::MySQL'); @@ -69,7 +68,7 @@ sub _prep_for_execute { ) { # this is just a plain-ish name, which has been literal-ed for # whatever reason - $target_name = first { defined $_ } ($1, $2); + $target_name = (defined $1) ? $1 : $2; } else { # this is something very complex, perhaps a custom result source or whatnot @@ -79,7 +78,7 @@ sub _prep_for_execute { } local $sm->{_modification_target_referenced_re} = - qr/ (?next::method(@_); diff --git a/lib/DBIx/Class/Storage/TxnScopeGuard.pm b/lib/DBIx/Class/Storage/TxnScopeGuard.pm index 18e2260..580a32b 100644 --- a/lib/DBIx/Class/Storage/TxnScopeGuard.pm +++ b/lib/DBIx/Class/Storage/TxnScopeGuard.pm @@ -19,15 +19,19 @@ sub new { # we are starting with an already set $@ - in order for things to work we need to # be able to recognize it upon destruction - store its weakref # recording it before doing the txn_begin stuff + # + # FIXME FRAGILE - any eval that fails but *does not* rethrow between here + # and the unwind will trample over $@ and invalidate the entire mechanism + # There got to be a saner way of doing this... if (defined $@ and $@ ne '') { - $guard->{existing_exception_ref} = (ref $@ ne '') ? $@ : \$@; - weaken $guard->{existing_exception_ref}; + weaken( + $guard->{existing_exception_ref} = (ref $@ ne '') ? $@ : \$@ + ); } $storage->txn_begin; - $guard->{dbh} = $storage->_dbh; - weaken $guard->{dbh}; + weaken( $guard->{dbh} = $storage->_dbh ); bless $guard, ref $class || $class; diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 0dcbcca..4430e12 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -3,6 +3,14 @@ source maint/travis-ci_scripts/common.bash if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi +# poison the environment - basically look through lib, find all mentioned +# ENVvars and set them to true and see if anything explodes +if [[ "$POISON_ENV" = "true" ]] ; then + for var in $(grep -P '\$ENV\{' -r lib/ | grep -oP 'DBIC_\w+' | sort -u | grep -v DBIC_TRACE) ; do + export $var=1 + done +fi + # try Schwern's latest offering on a stock perl and a threaded blead # can't do this with CLEANTEST=true yet because a lot of our deps fail # tests left and right under T::B 1.5 @@ -66,17 +74,19 @@ 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) + # (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) # parallel_installdeps_notest ExtUtils::MakeMaker + parallel_installdeps_notest File::Path parallel_installdeps_notest Carp parallel_installdeps_notest Module::Build ExtUtils::Depends parallel_installdeps_notest Module::Runtime File::Spec Data::Dumper parallel_installdeps_notest Test::Exception Encode::Locale Test::Fatal parallel_installdeps_notest Test::Warn bareword::filehandles 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 Moo Class::Trigger JSON::XS DBI DateTime::Format::Builder - parallel_installdeps_notest Moose Class::Accessor::Grouped Module::Install JSON Package::Variant + parallel_installdeps_notest YAML LWP Class::Trigger JSON::XS DBI DateTime::Format::Builder Class::Accessor::Grouped Package::Variant + parallel_installdeps_notest Moose Module::Install JSON SQL::Translator if [[ -n "DBICTEST_FIREBIRD_DSN" ]] ; then # the official version is full of 5.10-isms, but works perfectly fine on 5.8 diff --git a/maint/travis-ci_scripts/40_script.bash b/maint/travis-ci_scripts/40_script.bash index c044507..f3dd078 100755 --- a/maint/travis-ci_scripts/40_script.bash +++ b/maint/travis-ci_scripts/40_script.bash @@ -5,15 +5,28 @@ if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi export HARNESS_TIMER=1 HARNESS_OPTIONS=c:j$NUMTHREADS -START_TIME=$SECONDS +TEST_T0=$SECONDS if [[ "$CLEANTEST" = "true" ]] ; then echo_err "$(tstamp) Running tests with plain \`make test\`" run_or_err "Prepare blib" "make pure_all" - make test + make test 2> >(tee "$TEST_STDERR_LOG") else PROVECMD="prove -lrswj$NUMTHREADS t xt" echo_err "$(tstamp) running tests with \`$PROVECMD\`" - $PROVECMD + $PROVECMD 2> >(tee "$TEST_STDERR_LOG") fi +TEST_T1=$SECONDS -echo "$(tstamp) Testing took a total of $(( $SECONDS - $START_TIME ))s" +if [[ -z "$DBICTRACE" ]] && [[ -z "$POISON_ENV" ]] && [[ -s "$TEST_STDERR_LOG" ]] ; then + STDERR_LOG_SIZE=$(wc -l < "$TEST_STDERR_LOG") + + echo + echo "Test run produced $STDERR_LOG_SIZE lines of output on STDERR:" + echo "=============================================================" + cat "$TEST_STDERR_LOG" + echo "=============================================================" + echo "End of test run STDERR output ($STDERR_LOG_SIZE lines)" + echo +fi + +echo "$(tstamp) Testing took a total of $(( $TEST_T1 - $TEST_T0 ))s" diff --git a/maint/travis-ci_scripts/common.bash b/maint/travis-ci_scripts/common.bash index ab5c294..ee8fa00 100755 --- a/maint/travis-ci_scripts/common.bash +++ b/maint/travis-ci_scripts/common.bash @@ -2,6 +2,8 @@ set -e +TEST_STDERR_LOG=/tmp/dbictest.stderr + echo_err() { echo "$@" 1>&2 ; } if [[ "$TRAVIS" != "true" ]] ; then @@ -61,9 +63,22 @@ parallel_installdeps_notest() { # The reason we do things so "non-interactively" is that xargs -P will have the # latest cpanm instance overwrite the buildlog. There seems to be no way to # specify a custom buildlog, hence we just collect the verbose output - # and display it in case of failure + # and display it in case of "worker" failure + # + # Explanation of inline args: + # + # [09:38] you need a $0 + # [09:38] hence the _ + # [09:38] bash -c '...' _ + # [09:39] I like -- because it's the magic that gnu getopts uses for somethign else + # [09:39] or --, yes + # [09:39] ribasushi: you could put "giant space monkey penises" instead of "--" and it would work just as well + # run_or_err "Installing (without testing) $MODLIST" \ - "echo $MODLIST | xargs -n 1 -P $NUMTHREADS cpanm --notest --no-man-pages" + "echo $MODLIST | xargs -n 1 -P $NUMTHREADS bash -c \\ + 'OUT=\$(cpanm --notest --no-man-pages \"\$@\" 2>&1 ) || (LASTEXIT=\$?; echo \"\$OUT\"; exit \$LASTEXIT)' \\ + 'giant space monkey penises' + " } diff --git a/t/100populate.t b/t/100populate.t index 822ad93..f2a3936 100644 --- a/t/100populate.t +++ b/t/100populate.t @@ -3,10 +3,13 @@ use warnings; use Test::More; use Test::Exception; +use Test::Warn; use lib qw(t/lib); use DBICTest; use Path::Class::File (); +use Math::BigInt; use List::Util qw/shuffle/; +use Storable qw/nfreeze dclone/; my $schema = DBICTest->init_schema(); @@ -307,82 +310,108 @@ lives_ok { ]); } 'literal+bind with semantically identical attrs works after normalization'; -# the stringification has nothing to do with the artist name -# this is solely for testing consistency -my $fn = Path::Class::File->new ('somedir/somefilename.tmp'); -my $fn2 = Path::Class::File->new ('somedir/someotherfilename.tmp'); - -lives_ok { - $rs->populate([ - { - name => 'supplied before stringifying object', - }, - { - name => $fn, - } - ]); -} 'stringifying objects pass through'; - -# ... and vice-versa. - -lives_ok { - $rs->populate([ - { - name => $fn2, - }, - { - name => 'supplied after stringifying object', - }, - ]); -} 'stringifying objects pass through'; - -for ( - $fn, - $fn2, - 'supplied after stringifying object', - 'supplied before stringifying object' -) { - my $row = $rs->find ({name => $_}); - ok ($row, "Stringification test row '$_' properly inserted"); -} - -$rs->delete; - -# test stringification with ->create rather than Storage::insert_bulk as well +# test all kinds of population with stringified objects +warnings_like { + local $ENV{DBIC_RT79576_NOWARN}; + + my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' }); + + # the stringification has nothing to do with the artist name + # this is solely for testing consistency + my $fn = Path::Class::File->new ('somedir/somefilename.tmp'); + my $fn2 = Path::Class::File->new ('somedir/someotherfilename.tmp'); + my $rank = Math::BigInt->new(42); + + my $args = { + 'stringifying objects after regular values' => [ map + { { name => $_, rank => $rank } } + ( + 'supplied before stringifying objects', + 'supplied before stringifying objects 2', + $fn, + $fn2, + ) + ], + 'stringifying objects before regular values' => [ map + { { name => $_, rank => $rank } } + ( + $fn, + $fn2, + 'supplied after stringifying objects', + 'supplied after stringifying objects 2', + ) + ], + 'stringifying objects between regular values' => [ map + { { name => $_, rank => $rank } } + ( + 'supplied before stringifying objects', + $fn, + $fn2, + 'supplied after stringifying objects', + ) + ], + 'stringifying objects around regular values' => [ map + { { name => $_, rank => $rank } } + ( + $fn, + 'supplied between stringifying objects', + $fn2, + ) + ], + }; + + local $Storable::canonical = 1; + my $preimage = nfreeze([$fn, $fn2, $rank, $args]); + + for my $tst (keys %$args) { + + # test void ctx + $rs->delete; + $rs->populate($args->{$tst}); + is_deeply( + $rs->all_hri, + $args->{$tst}, + "Populate() $tst in void context" + ); + + # test non-void ctx + $rs->delete; + my $dummy = $rs->populate($args->{$tst}); + is_deeply( + $rs->all_hri, + $args->{$tst}, + "Populate() $tst in non-void context" + ); + + # test create() as we have everything set up already + $rs->delete; + $rs->create($_) for @{$args->{$tst}}; + + is_deeply( + $rs->all_hri, + $args->{$tst}, + "Create() $tst" + ); + } -lives_ok { - my @dummy = $rs->populate([ - { - name => 'supplied before stringifying object', - }, - { - name => $fn, - } - ]); -} 'stringifying objects pass through'; + ok ( + ($preimage eq nfreeze( [$fn, $fn2, $rank, $args] )), + 'Arguments fed to populate()/create() unchanged' + ); -# ... and vice-versa. - -lives_ok { - my @dummy = $rs->populate([ - { - name => $fn2, - }, - { - name => 'supplied after stringifying object', - }, - ]); -} 'stringifying objects pass through'; - -for ( - $fn, - $fn2, - 'supplied after stringifying object', - 'supplied before stringifying object' -) { - my $row = $rs->find ({name => $_}); - ok ($row, "Stringification test row '$_' properly inserted"); -} + $rs->delete; +} [ + # warning to be removed around Apr 1st 2015 + # smokers start failing a month before that + ( + ( DBICTest::RunMode->is_author and ( time() > 1427846400 ) ) + or + ( DBICTest::RunMode->is_smoker and ( time() > 1425168000 ) ) + ) + ? () + # one unique for populate() and create() each + : (qr/\QPOSSIBLE *PAST* DATA CORRUPTION detected \E.+\QTrigger condition encountered at @{[ __FILE__ ]} line\E \d/) x 2 +], 'Data integrity warnings as planned'; lives_ok { $schema->resultset('TwoKeys')->populate([{ diff --git a/t/103many_to_many_warning.t b/t/103many_to_many_warning.t index f2944b4..9e5c19a 100644 --- a/t/103many_to_many_warning.t +++ b/t/103many_to_many_warning.t @@ -12,6 +12,8 @@ my $exp_warn = qr/The many-to-many relationship 'bars' is trying to create/; my @w; local $SIG{__WARN__} = sub { $_[0] =~ $exp_warn ? push @w, $_[0] : warn $_[0] }; my $code = gen_code ( suffix => 1 ); + + local $ENV{DBIC_OVERWRITE_HELPER_METHODS_OK}; eval "$code"; ok (! $@, 'Eval code without warnings suppression') || diag $@; diff --git a/t/106dbic_carp.t b/t/106dbic_carp.t index 8bd65eb..241fc5d 100644 --- a/t/106dbic_carp.t +++ b/t/106dbic_carp.t @@ -1,27 +1,78 @@ -#!/usr/bin/perl - use strict; use warnings; +# without this the stacktrace of $schema will be activated +BEGIN { $ENV{DBIC_TRACE} = 0 } + use Test::More; use Test::Warn; +use Test::Exception; use DBIx::Class::Carp; use lib 't/lib'; use DBICTest; -warnings_exist { - DBIx::Class::frobnicate(); -} [ - qr/carp1/, - qr/carp2/, -], 'expected warnings from carp_once'; +{ + sub DBICTest::DBICCarp::frobnicate { + DBICTest::DBICCarp::branch1(); + DBICTest::DBICCarp::branch2(); + } -done_testing; + sub DBICTest::DBICCarp::branch1 { carp_once 'carp1' } + sub DBICTest::DBICCarp::branch2 { carp_once 'carp2' } + + + warnings_exist { + DBICTest::DBICCarp::frobnicate(); + } [ + qr/carp1/, + qr/carp2/, + ], 'expected warnings from carp_once'; +} + +{ + { + package DBICTest::DBICCarp::Exempt; + use DBIx::Class::Carp; -sub DBIx::Class::frobnicate { - DBIx::Class::branch1(); - DBIx::Class::branch2(); + sub _skip_namespace_frames { qr/^DBICTest::DBICCarp::Exempt/ } + + sub thrower { + sub { + DBICTest->init_schema(no_deploy => 1)->throw_exception('time to die'); + }->(); + } + + sub dcaller { + sub { + thrower(); + }->(); + } + + sub warner { + eval { + sub { + eval { + carp ('time to warn') + } + }->() + } + } + + sub wcaller { + warner(); + } + } + + # the __LINE__ relationship below is important - do not reformat + throws_ok { DBICTest::DBICCarp::Exempt::dcaller() } + qr/\QDBICTest::DBICCarp::Exempt::thrower(): time to die at @{[ __FILE__ ]} line @{[ __LINE__ - 1 ]}\E$/, + 'Expected exception callsite and originator' + ; + + # the __LINE__ relationship below is important - do not reformat + warnings_like { DBICTest::DBICCarp::Exempt::wcaller() } + qr/\QDBICTest::DBICCarp::Exempt::warner(): time to warn at @{[ __FILE__ ]} line @{[ __LINE__ - 1 ]}\E$/, + ; } -sub DBIx::Class::branch1 { carp_once 'carp1' } -sub DBIx::Class::branch2 { carp_once 'carp2' } +done_testing; diff --git a/t/60core.t b/t/60core.t index ffb7d13..3a674de 100644 --- a/t/60core.t +++ b/t/60core.t @@ -173,7 +173,7 @@ is_deeply( \@cd, [qw/cdid artist title year genreid single_track/], 'column orde $cd = $schema->resultset("CD")->search({ title => 'Spoonful of bees' }, { columns => ['title'] })->next; is($cd->title, 'Spoonful of bees', 'subset of columns returned correctly'); -$cd = $schema->resultset("CD")->search(undef, { include_columns => [ { name => 'artist.name' } ], join => [ 'artist' ] })->find(1); +$cd = $schema->resultset("CD")->search(undef, { '+columns' => [ { name => 'artist.name' } ], join => [ 'artist' ] })->find(1); is($cd->title, 'Spoonful of bees', 'Correct CD returned with include'); is($cd->get_column('name'), 'Caterwauler McCrae', 'Additional column returned'); @@ -309,7 +309,9 @@ for (keys %{$schema->storage->dbh->{CachedKids}}) { } my $tag = $schema->resultset('Tag')->search( - [ { 'me.tag' => 'Blue' } ], { cols=>[qw/tagid/] } )->next; + [ { 'me.tag' => 'Blue' } ], + { columns => 'tagid' } +)->next; ok($tag->has_column_loaded('tagid'), 'Has tagid loaded'); ok(!$tag->has_column_loaded('tag'), 'Has not tag loaded'); diff --git a/t/61findnot.t b/t/61findnot.t index d7dde4d..b8b0d31 100644 --- a/t/61findnot.t +++ b/t/61findnot.t @@ -57,7 +57,7 @@ $artist_rs = $schema->resultset("Artist"); warnings_exist { $artist_rs->find({}) -} qr/\QDBIx::Class::ResultSet::find(): Query returned more than one row. SQL that returns multiple rows is DEPRECATED for ->find and ->single/ +} qr/\QQuery returned more than one row. SQL that returns multiple rows is DEPRECATED for ->find and ->single/ => "Non-unique find generated a cursor inexhaustion warning"; throws_ok { @@ -65,6 +65,7 @@ throws_ok { } qr/Unable to satisfy requested constraint 'primary'/; for (1, 0) { + local $ENV{DBIC_NULLABLE_KEY_NOWARN}; warnings_like sub { $artist_rs->find({ artistid => undef }, { key => 'primary' }) diff --git a/t/71mysql.t b/t/71mysql.t index de1e2fd..e492417 100644 --- a/t/71mysql.t +++ b/t/71mysql.t @@ -319,20 +319,34 @@ NULLINSEARCH: { ); } - my $ac = $schema->resultset('Artist')->count_rs; - my $old_count = $ac->next; - $ac->reset; + is ($rs->count, 10, '10 artists present'); my $orig_debug = $schema->storage->debug; $schema->storage->debug(1); - my $query_count = 0; + my $query_count; $schema->storage->debugcb(sub { $query_count++ }); + + $query_count = 0; $complex_rs->delete; - $schema->storage->debugcb(undef); - $schema->storage->debug($orig_debug); is ($query_count, 1, 'One delete query fired'); - is ($old_count - $ac->next, 10, '10 Artists correctly deleted'); + is ($rs->count, 0, '10 Artists correctly deleted'); + + $rs->create({ + name => 'baby_with_cd', + cds => [ { title => 'babeeeeee', year => 2013 } ], + }); + is ($rs->count, 1, 'Artist with cd created'); + + $query_count = 0; + $schema->resultset('CD')->search_related('artist', + { 'artist.name' => { -like => 'baby_with_%' } } + )->delete; + is ($query_count, 1, 'And one more delete query fired'); + is ($rs->count, 0, 'Artist with cd deleted'); + + $schema->storage->debugcb(undef); + $schema->storage->debug($orig_debug); } ZEROINSEARCH: { diff --git a/t/752sqlite.t b/t/752sqlite.t index 1895a9f..1a511f2 100644 --- a/t/752sqlite.t +++ b/t/752sqlite.t @@ -121,7 +121,7 @@ my $schema = DBICTest->init_schema(); # make sure the side-effects of RT#67581 do not result in data loss my $row; warnings_exist { $row = $schema->resultset('Artist')->create ({ name => 'alpha rank', rank => 'abc' }) } - [qr/Non-numeric value supplied for column 'rank' despite the numeric datatype/], + [qr/Non-integer value supplied for column 'rank' despite the integer datatype/], 'proper warning on string insertion into an numeric column' ; $row->discard_changes; diff --git a/t/85utf8.t b/t/85utf8.t index ea630a2..a07e42a 100644 --- a/t/85utf8.t +++ b/t/85utf8.t @@ -37,6 +37,7 @@ warnings_are ( warnings_like ( sub { + local $ENV{DBIC_UTF8COLUMNS_OK}; package A::Test1Loud; use base 'DBIx::Class::Core'; __PACKAGE__->load_components(qw(Core +A::Comp Ordered UTF8Columns)); diff --git a/t/86might_have.t b/t/86might_have.t index c1a66de..0ca9a06 100644 --- a/t/86might_have.t +++ b/t/86might_have.t @@ -40,6 +40,8 @@ is($queries, 1, 'liner_notes (might_have) prefetched - do not load liner_notes on update'); warning_like { + local $ENV{DBIC_DONT_VALIDATE_RELS}; + DBICTest::Schema::Bookmark->might_have( linky => 'DBICTest::Schema::Link', { "foreign.id" => "self.link" }, diff --git a/t/94versioning.t b/t/94versioning.t index 146c7c3..299ac2f 100644 --- a/t/94versioning.t +++ b/t/94versioning.t @@ -35,6 +35,9 @@ BEGIN { my $s = DBICTest::Schema->connect($dsn, $user, $pass); } +# in case it came from the env +$ENV{DBIC_NO_VERSION_CHECK} = 0; + use_ok('DBICVersion_v1'); my $version_table_name = 'dbix_class_schema_versions'; diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index 589f82b..75599eb 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -328,6 +328,9 @@ sub deploy_schema { my $schema = shift; my $args = shift || {}; + local $schema->storage->{debug} + if ($ENV{TRAVIS}||'') eq 'true'; + if ($ENV{"DBICTEST_SQLT_DEPLOY"}) { $schema->deploy($args); } else { @@ -356,6 +359,9 @@ sub populate_schema { my $self = shift; my $schema = shift; + local $schema->storage->{debug} + if ($ENV{TRAVIS}||'') eq 'true'; + $schema->populate('Genre', [ [qw/genreid name/], [qw/1 emo /], diff --git a/t/resultset/update_delete.t b/t/resultset/update_delete.t index aea2ba7..340bb41 100644 --- a/t/resultset/update_delete.t +++ b/t/resultset/update_delete.t @@ -114,7 +114,7 @@ $schema->storage->_use_multicolumn_in (1); $schema->storage->debugobj ($debugobj); $schema->storage->debug (1); throws_ok { $fks->update ({ read_count => \ 'read_count + 1' }) } # this can't actually execute, we just need the "as_query" - qr/\Q DBI Exception:/ or do { $sql = ''; @bind = () }; + qr/\QDBI Exception:/ or do { $sql = ''; @bind = () }; $schema->storage->_use_multicolumn_in (undef); $schema->storage->debugobj ($orig_debugobj); $schema->storage->debug ($orig_debug); diff --git a/t/search/deprecated_attributes.t b/t/search/deprecated_attributes.t new file mode 100644 index 0000000..f4d2e28 --- /dev/null +++ b/t/search/deprecated_attributes.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Warn; +use lib qw(t/lib); +use DBICTest; + +my $schema = DBICTest->init_schema(); + +my $cd_rs = $schema->resultset("CD"); + +warnings_exist( sub { + my $cd = $cd_rs->search( undef, { + cols => [ { name => 'artist.name' } ], + join => 'artist', + })->next; + + is_deeply ( + { $cd->get_inflated_columns }, + { name => 'Caterwauler McCrae' }, + 'cols attribute still works', + ); +}, qr/Resultset attribute 'cols' is deprecated/, +'deprecation warning when passing cols attribute'); + +warnings_exist( sub { + my $cd = $cd_rs->search_rs( undef, { + include_columns => [ { name => 'artist.name' } ], + join => 'artist', + })->next; + + is ( + $cd->get_column('name'), + 'Caterwauler McCrae', + 'include_columns attribute still works', + ); +}, qr/Resultset attribute 'include_columns' is deprecated/, +'deprecation warning when passing include_columns attribute'); + +done_testing; diff --git a/t/sqlmaker/limit_dialects/torture.t b/t/sqlmaker/limit_dialects/torture.t index d7a4254..9c998a5 100644 --- a/t/sqlmaker/limit_dialects/torture.t +++ b/t/sqlmaker/limit_dialects/torture.t @@ -632,57 +632,6 @@ my $tests = { ], }, - RowCountOrGenericSubQ => { - limit => [ - '( - SET ROWCOUNT 4 - SELECT me.id, owner.id, owner.name, ? * ?, ? - FROM books me - JOIN owners owner - ON owner.id = me.owner - WHERE source != ? AND me.title = ? AND source = ? - GROUP BY AVG(me.id / ?), MAX(owner.id) - HAVING ? - ORDER BY me.id - SET ROWCOUNT 0 - )', - [ - @select_bind, - @where_bind, - @group_bind, - @having_bind, - ], - ], - limit_offset => [ - '( - SELECT me.id, owner__id, owner__name, bar, baz - FROM ( - SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz - FROM books me - JOIN owners owner - ON owner.id = me.owner - WHERE source != ? AND me.title = ? AND source = ? - GROUP BY AVG(me.id / ?), MAX(owner.id) - HAVING ? - ) me - WHERE ( - SELECT COUNT( * ) - FROM books rownum__emulation - WHERE rownum__emulation.id < me.id - ) BETWEEN ? AND ? - ORDER BY me.id - )', - [ - @select_bind, - @where_bind, - @group_bind, - @having_bind, - [ { sqlt_datatype => 'integer' } => 3 ], - [ { sqlt_datatype => 'integer' } => 6 ], - ], - ], - }, - GenericSubQ => { limit => [ '( diff --git a/t/sqlmaker/mysql.t b/t/sqlmaker/mysql.t index 9de4c7f..b00691f 100644 --- a/t/sqlmaker/mysql.t +++ b/t/sqlmaker/mysql.t @@ -49,7 +49,7 @@ bless ( $schema->storage, 'DBIx::Class::Storage::DBI::mysql' ); 'Correct delete-SQL with double-wrapped subquery', ); - # and a really contrived example (we test it live in t/71mysql.t) + # and a couple of really contrived examples (we test them live in t/71mysql.t) my $rs = $schema->resultset('Artist')->search({ name => { -like => 'baby_%' } }); my ($count_sql, @count_bind) = @${$rs->count_rs->as_query}; eval { @@ -86,6 +86,31 @@ bless ( $schema->storage, 'DBIx::Class::Storage::DBI::mysql' ); [ ("'baby_%'") x 2 ], ); + eval { + $schema->resultset('CD')->search_related('artist', + { 'artist.name' => { -like => 'baby_with_%' } } + )->delete + }; + + is_same_sql_bind ( + $sql, + \@bind, + q( + DELETE FROM `artist` + WHERE `artistid` IN ( + SELECT * + FROM ( + SELECT `artist`.`artistid` + FROM cd `me` + INNER JOIN `artist` `artist` + ON `artist`.`artistid` = `me`.`artist` + WHERE `artist`.`name` LIKE ? + ) `_forced_double_subquery` + ) + ), + [ "'baby_with_%'" ], + ); + $schema->storage->debugobj ($orig_debugobj); $schema->storage->debug ($orig_debug); } diff --git a/t/storage/base.t b/t/storage/base.t index 2aac70c..948d49a 100644 --- a/t/storage/base.t +++ b/t/storage/base.t @@ -8,33 +8,6 @@ use lib qw(t/lib); use DBICTest; use Data::Dumper; -{ - package DBICTest::ExplodingStorage::Sth; - use strict; - use warnings; - - sub execute { die "Kablammo!" } - - sub bind_param {} - - package DBICTest::ExplodingStorage; - use strict; - use warnings; - use base 'DBIx::Class::Storage::DBI::SQLite'; - - my $count = 0; - sub sth { - my ($self, $sql) = @_; - return bless {}, "DBICTest::ExplodingStorage::Sth" unless $count++; - return $self->next::method($sql); - } - - sub connected { - return 0 if $count == 1; - return shift->next::method(@_); - } -} - my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); is( ref($schema->storage), 'DBIx::Class::Storage::DBI::SQLite', @@ -51,16 +24,6 @@ throws_ok { $schema->resultset('CD')->search_literal('broken +%$#$1')->all; } qr/prepare_cached failed/, 'exception via DBI->HandleError, etc'; -bless $storage, "DBICTest::ExplodingStorage"; -$schema->storage($storage); - -lives_ok { - $schema->resultset('Artist')->create({ name => "Exploding Sheep" }); -} 'Exploding $sth->execute was caught'; - -is(1, $schema->resultset('Artist')->search({name => "Exploding Sheep" })->count, - "And the STH was retired"); - # testing various invocations of connect_info ([ ... ]) @@ -158,6 +121,7 @@ my $invocations = { }; for my $type (keys %$invocations) { + local $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK}; # we can not use a cloner portably because of the coderef # so compare dumps instead @@ -166,7 +130,7 @@ for my $type (keys %$invocations) { warnings_exist ( sub { $storage->connect_info ($invocations->{$type}{args}) }, - $invocations->{$type}{warn} || (), + $invocations->{$type}{warn} || [], 'Warned about ignored attributes', ); diff --git a/t/storage/disable_sth_caching.t b/t/storage/disable_sth_caching.t index c32f8c7..d6dcc03 100644 --- a/t/storage/disable_sth_caching.t +++ b/t/storage/disable_sth_caching.t @@ -5,15 +5,22 @@ use Test::More; use lib qw(t/lib); use DBICTest; -plan tests => 2; +##!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +## This test uses undocumented internal methods +## DO NOT USE THEM IN THE SAME MANNER +## They are subject to ongoing change +##!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # Set up the "usual" sqlite for DBICTest my $schema = DBICTest->init_schema; +my $dbh = $schema->storage->_get_dbh; -my $sth_one = $schema->storage->_sth('SELECT 42'); -my $sth_two = $schema->storage->_sth('SELECT 42'); +my $sth_one = $schema->storage->_prepare_sth($dbh, 'SELECT 42'); +my $sth_two = $schema->storage->_prepare_sth($dbh, 'SELECT 42'); $schema->storage->disable_sth_caching(1); -my $sth_three = $schema->storage->_sth('SELECT 42'); +my $sth_three = $schema->storage->_prepare_sth($dbh, 'SELECT 42'); ok($sth_one == $sth_two, "statement caching works"); ok($sth_two != $sth_three, "disabling statement caching works"); + +done_testing; diff --git a/t/storage/txn_scope_guard.t b/t/storage/txn_scope_guard.t index c0cb347..ca67c98 100644 --- a/t/storage/txn_scope_guard.t +++ b/t/storage/txn_scope_guard.t @@ -117,9 +117,10 @@ use DBICTest; # make sure it warns *big* on failed rollbacks # test with and without a poisoned $@ -for my $poison (0,1) { +for my $pre_poison (0,1) { +for my $post_poison (0,1) { - my $schema = DBICTest->init_schema(); + my $schema = DBICTest->init_schema(no_populate => 1); no strict 'refs'; no warnings 'redefine'; @@ -161,16 +162,86 @@ for my $poison (0,1) { warn $_[0]; } }; + { - eval { die 'GIFT!' if $poison }; - my $guard = $schema->txn_scope_guard; - $schema->resultset ('Artist')->create ({ name => 'bohhoo'}); + eval { die 'pre-GIFT!' if $pre_poison }; + my $guard = $schema->txn_scope_guard; + eval { die 'post-GIFT!' if $post_poison }; + $schema->resultset ('Artist')->create ({ name => 'bohhoo'}); } - is (@w, 2, 'Both expected warnings found' . ($poison ? ' (after $@ poisoning)' : '') ); + local $TODO = 'Do not know how to deal with trapped exceptions occuring after guard instantiation...' + if ( $post_poison and ( + # take no chances on installation + ( DBICTest::RunMode->is_plain and ($ENV{TRAVIS}||'') ne 'true' ) + or + # this always fails + ! $pre_poison + or + # I do not underdtand why but on <= 5.8.8 and $pre_poison && $post_poison passes... + $] > 5.008008 + )); + + is (@w, 2, "Both expected warnings found - \$\@ pre-poison: $pre_poison, post-poison: $post_poison" ); # just to mask off warning since we could not disconnect above $schema->storage->_dbh->disconnect; +}} + +# add a TODO to catch when Text::Balanced is finally fixed +# https://rt.cpan.org/Public/Bug/Display.html?id=74994 +# +# while it doesn't matter much for DBIC itself, this particular bug +# is a *BANE*, and DBIC is to bump its dep as soon as possible +{ + + require Text::Balanced; + + my $great_success; + { + local $TODO = 'RT#74994 *STILL* not fixed'; + + lives_ok { + # this is what poisons $@ + Text::Balanced::extract_bracketed( '(foo', '()' ); + + my $s = DBICTest->init_schema( deploy => 0 ); + my $g = $s->txn_scope_guard; + $g->commit; + $great_success++; + } 'Text::Balanced is no longer screwing up $@'; + } + + # delete all of this when T::B dep is bumped + unless ($great_success) { + +# hacky workaround for desperate folk +# intended to be copypasted into your app + { + require Text::Balanced; + require overload; + + local $@; + + # this is what poisons $@ + Text::Balanced::extract_bracketed( '(foo', '()' ); + + if ($@ and overload::Overloaded($@) and ! overload::Method($@,'fallback') ) { + my $class = ref $@; + eval "package $class; overload->import(fallback => 1);" + } + } +# end of hacky workaround + + lives_ok { + # this is what poisons $@ + Text::Balanced::extract_bracketed( '(foo', '()' ); + + my $s = DBICTest->init_schema( deploy => 0 ); + my $g = $s->txn_scope_guard; + $g->commit; + } 'Monkeypatched Text::Balanced is no longer screwing up $@'; + } } done_testing; diff --git a/xt/strictures.t b/xt/strictures.t index 0307cc2..3996621 100644 --- a/xt/strictures.t +++ b/xt/strictures.t @@ -3,7 +3,7 @@ use strict; use Test::More; use lib 't/lib'; -use DBICTest ':GlobalLock'; +use DBICTest; unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_strictures') ) { my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_strictures');