22 changes: 11 additions & 11 deletions lib/DBIx/Class/Row.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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);
Expand Down Expand Up @@ -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;
Expand All @@ -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);
}
Expand All @@ -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;
Expand Down Expand Up @@ -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;
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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();
}
}
Expand Down
14 changes: 9 additions & 5 deletions lib/DBIx/Class/SQLMaker/LimitDialects.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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);
Expand Down Expand Up @@ -569,8 +572,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;

Expand Down
24 changes: 22 additions & 2 deletions lib/DBIx/Class/Storage.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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;

Expand All @@ -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 {
Expand Down
132 changes: 68 additions & 64 deletions lib/DBIx/Class/Storage/DBI.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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 {
Expand Down Expand Up @@ -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], '""') );
}
}

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 {
Expand Down Expand Up @@ -2395,42 +2435,6 @@ see L<DBIx::Class::SQLMaker::LimitDialects>.
=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) = @_;

Expand Down
2 changes: 1 addition & 1 deletion lib/DBIx/Class/Storage/DBI/ADO.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
7 changes: 4 additions & 3 deletions lib/DBIx/Class/Storage/DBI/Firebird/Common.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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;
Expand Down
18 changes: 8 additions & 10 deletions lib/DBIx/Class/Storage/DBI/MSSQL.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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;
}


Expand Down
2 changes: 1 addition & 1 deletion lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion lib/DBIx/Class/Storage/DBI/Pg.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
5 changes: 2 additions & 3 deletions lib/DBIx/Class/Storage/DBI/Replicated.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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/
Expand Down Expand Up @@ -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
Expand Down
62 changes: 59 additions & 3 deletions lib/DBIx/Class/Storage/DBI/SQLite.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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;

Expand All @@ -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<RT#79576|https://rt.cpan.org/Public/Bug/Display.html?id=79576>.
In order to trigger the bug condition one needs to supply B<more than one>
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<all>
these bind positions being set to the value of the B<last> 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<DBIC_RT79576_NOWARN> 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
Expand Down Expand Up @@ -207,26 +247,42 @@ 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
defined $bind->[$_][1]
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;
}

Expand Down
3 changes: 1 addition & 2 deletions lib/DBIx/Class/Storage/DBI/mysql.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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');
Expand Down Expand Up @@ -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
Expand Down
12 changes: 8 additions & 4 deletions lib/DBIx/Class/Storage/TxnScopeGuard.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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;

Expand Down
16 changes: 13 additions & 3 deletions maint/travis-ci_scripts/30_before_script.bash
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
21 changes: 17 additions & 4 deletions maint/travis-ci_scripts/40_script.bash
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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"
19 changes: 17 additions & 2 deletions maint/travis-ci_scripts/common.bash
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,8 @@

set -e

TEST_STDERR_LOG=/tmp/dbictest.stderr

echo_err() { echo "$@" 1>&2 ; }

if [[ "$TRAVIS" != "true" ]] ; then
Expand Down Expand Up @@ -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] <T> you need a $0
# [09:38] <G> hence the _
# [09:38] <G> bash -c '...' _
# [09:39] <T> I like -- because it's the magic that gnu getopts uses for somethign else
# [09:39] <G> or --, yes
# [09:39] <T> 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'
"
}


Expand Down
177 changes: 103 additions & 74 deletions t/100populate.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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();

Expand Down Expand Up @@ -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([{
Expand Down
2 changes: 2 additions & 0 deletions t/103many_to_many_warning.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 $@;
Expand Down
79 changes: 65 additions & 14 deletions t/106dbic_carp.t
View file
Original file line number Diff line number Diff line change
@@ -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;
6 changes: 4 additions & 2 deletions t/60core.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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');
Expand Down Expand Up @@ -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');
Expand Down
3 changes: 2 additions & 1 deletion t/61findnot.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -57,14 +57,15 @@ $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 {
$artist_rs->find({}, { key => 'primary' })
} 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' })
Expand Down
2 changes: 1 addition & 1 deletion t/752sqlite.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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;
Expand Down
1 change: 1 addition & 0 deletions t/85utf8.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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));
Expand Down
2 changes: 2 additions & 0 deletions t/86might_have.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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" },
Expand Down
3 changes: 3 additions & 0 deletions t/94versioning.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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';
Expand Down
6 changes: 6 additions & 0 deletions t/lib/DBICTest.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 {
Expand Down Expand Up @@ -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 /],
Expand Down
2 changes: 1 addition & 1 deletion t/resultset/update_delete.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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);
Expand Down
41 changes: 41 additions & 0 deletions t/search/deprecated_attributes.t
View file
Original file line number Diff line number Diff line change
@@ -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;
40 changes: 2 additions & 38 deletions t/storage/base.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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',
Expand All @@ -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 ([ ... ])

Expand Down Expand Up @@ -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
Expand All @@ -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',
);

Expand Down
15 changes: 11 additions & 4 deletions t/storage/disable_sth_caching.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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;
29 changes: 22 additions & 7 deletions t/storage/txn_scope_guard.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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';
Expand Down Expand Up @@ -161,16 +162,30 @@ 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;
}
}}

done_testing;
2 changes: 1 addition & 1 deletion xt/strictures.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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');
Expand Down