- CLEANTEST=false
- BREWOPTS="-Duseithreads"
- BREWVER=5.8.5
+ - DBIC_TRACE_PROFILE=console
# minimum supported without threads
- perl: 5.8.3_nt
- CLEANTEST=false
- BREWOPTS=""
- BREWVER=5.8.3
+ - DBIC_TRACE_PROFILE=console_monochrome
# check CLEANTEST of minimum supported
- perl: 5.8.3_nt_mb
- 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
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
1;
+__END__
+
+=encoding UTF-8
+
=head1 NAME
DBIx::Class - Extensible and flexible object <-> relational mapper.
=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<git://git.shadowcat.co.uk/dbsrgits/DBIx-Class.git>
-
-=item * Official gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git>
-
-=item * GitHub mirror: L<https://github.com/dbsrgits/DBIx-Class>
-
-=item * Authorized committers: L<ssh://dbsrgits@git.shadowcat.co.uk/DBIx-Class.git>
-
-=item * Travis-CI log: L<https://travis-ci.org/dbsrgits/dbix-class/builds>
-
-=for html
-<br>↪ Stable branch CI status: <img src="https://secure.travis-ci.org/dbsrgits/dbix-class.png?branch=master"></img>
-
-=back
-
=head1 SYNOPSIS
-Create a schema class called MyApp/Schema.pm:
+=head2 Schema classes preparation
+
+Create a schema class called F<MyApp/Schema.pm>:
package MyApp::Schema;
use base qw/DBIx::Class::Schema/;
1;
Create a result class to represent artists, who have many CDs, in
-MyApp/Schema/Result/Artist.pm:
+F<MyApp/Schema/Result/Artist.pm>:
See L<DBIx::Class::ResultSource> 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<MyApp/Schema/Result/CD.pm>:
package MyApp::Schema::Result::CD;
use base qw/DBIx::Class::Core/;
1;
+=head2 API usage
+
Then you can use these classes in your application's code:
# Connect to your database.
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<JOIN>, C<LEFT JOIN>, C<COUNT>, C<DISTINCT>, C<GROUP BY>, C<ORDER BY> and
+C<HAVING> 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
L<your DBD may not be|DBI/Threads and Thread Safety>).
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<experimental> - such APIs are still usable but may have edge bugs.
+Failing test cases are I<always> 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
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<git://git.shadowcat.co.uk/dbsrgits/DBIx-Class.git>
+
+=item * Official gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git>
+
+=item * GitHub mirror: L<https://github.com/dbsrgits/DBIx-Class>
+
+=item * Authorized committers: L<ssh://dbsrgits@git.shadowcat.co.uk/DBIx-Class.git>
+
+=item * Travis-CI log: L<https://travis-ci.org/dbsrgits/dbix-class/builds>
+
+=for html
+↪ Stable branch CI status: <img src="https://secure.travis-ci.org/dbsrgits/dbix-class.png?branch=master"></img>
+
+=back
+
=head1 AUTHOR
mst: Matt S. Trout <mst@shadowcatsystems.co.uk>
da5id: David Jack Olrik <djo@cpan.org>
+dariusj: Darius Jokilehto <dariusjokilehto@yahoo.co.uk>
+
davewood: David Schmidt <davewood@gmx.at>
+daxim: Lars Dɪᴇᴄᴋᴏᴡ 迪拉斯 <daxim@cpan.org>
+
debolaz: Anders Nor Berle <berle@cpan.org>
dew: Dan Thomas <dan@godders.org>
This library is free software and may be distributed under the same terms
as perl itself.
-
-=cut
} 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, @_));
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}";
use Carp ();
use namespace::clean ();
+$Carp::Internal{ (__PACKAGE__) }++;
+
sub __find_caller {
my ($skip_pattern, $class) = @_;
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
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
);
};
use warnings;
use DBIx::Class::Carp ();
+$Carp::Internal{ (__PACKAGE__) }++;
use overload
'""' => sub { shift->{msg} },
});
} 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
$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";
}
# 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'";
}
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
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
expression). Adds C<me.> onto the start of any column without a C<.> in
it and sets C<select> from that, then auto-populates C<as> from
C<select> as normal. (You may also use the C<cols> attribute, as in
-earlier versions of DBIC.)
+earlier versions of DBIC, but this is deprecated.)
Essentially C<columns> does the same as L</select> and L</as>.
=back
-Indicates additional columns to be selected from storage. Works the same
-as L</columns> but adds columns to the selection. (You may also use the
-C<include_columns> attribute, as in earlier versions of DBIC). For
-example:-
+Indicates additional columns to be selected from storage. Works the same as
+L</columns> but adds columns to the selection. (You may also use the
+C<include_columns> attribute, as in earlier versions of DBIC, but this is
+deprecated). For example:-
$schema->resultset('CD')->search(undef, {
'+columns' => ['artist.name'],
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);
$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;
$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);
}
$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;
# 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;
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
$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();
}
}
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);
return $sql;
}
-=head2 RowCountOrGenericSubQ
-
-This is not exactly a limit dialect, but more of a proxy for B<Sybase ASE>.
-If no $offset is supplied the limit is simply performed as:
-
- SET ROWCOUNT $limit
- SELECT ...
- SET ROWCOUNT 0
-
-Otherwise we fall back to L</GenericSubQ>
-
-=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 (
. '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;
See L<SQL::Translator/METHODS> 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<DROP TABLE> statement for each table
-created. For quoting purposes supply C<quote_table_names> and
-C<quote_field_names>.
+created. For quoting purposes supply C<quote_identifiers>.
Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash
ref or an array ref, containing a list of source to deploy. If present, then
$self->{debugobj} ||= do {
if (my $profile = $ENV{DBIC_TRACE_PROFILE}) {
require DBIx::Class::Storage::Debug::PrettyPrint;
+ my @pp_args;
+
if ($profile =~ /^\.?\//) {
require Config::Any;
$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 {
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
);
}
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 {
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], '""') );
}
}
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
$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 {
=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) = @_;
See L<SQL::Translator/METHODS> 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<DROP TABLE> statement for each table
-created. For quoting purposes supply C<quote_table_names> and
-C<quote_field_names>.
+created. For quoting purposes supply C<quote_identifiers>.
If no arguments are passed, then the following default values are assumed:
# 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
$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;
# 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;
}
=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
}
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
));
}
- return $1;
+ return $1; # exception thrown unless match is made above
}
# custom method for fetching column default, since column_info has a
sql_maker_class
_execute
_do_query
- _sth
- _dbh_sth
_dbh_execute
/, Class::MOP::Class->initialize('DBIx::Class::Storage::DBIHacks')->get_method_list ],
reader => [qw/
_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
use mro 'c3';
use DBIx::Class::Carp;
-use Scalar::Util 'looks_like_number';
use Try::Tiny;
use namespace::clean;
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
# 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
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;
}
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'
}
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
# = $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)
use base qw/DBIx::Class::Storage::DBI/;
-use List::Util 'first';
use namespace::clean;
__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::MySQL');
) {
# 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
}
local $sm->{_modification_target_referenced_re} =
- qr/ (?<!DELETE) [\s\)] FROM \s (?: \` \Q$target_name\E \` | \Q$target_name\E ) [\s\(] /xi
+ qr/ (?<!DELETE) [\s\)] (?: FROM | JOIN ) \s (?: \` \Q$target_name\E \` | \Q$target_name\E ) [\s\(] /xi
if $target_name;
$self->next::method(@_);
# 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;
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
# 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
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"
set -e
+TEST_STDERR_LOG=/tmp/dbictest.stderr
+
echo_err() { echo "$@" 1>&2 ; }
if [[ "$TRAVIS" != "true" ]] ; then
# 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'
+ "
}
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();
]);
} '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([{
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 $@;
-#!/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;
$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');
}
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');
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 {
} 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' })
);
}
- 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: {
# 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;
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));
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" },
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';
my $schema = shift;
my $args = shift || {};
+ local $schema->storage->{debug}
+ if ($ENV{TRAVIS}||'') eq 'true';
+
if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
$schema->deploy($args);
} else {
my $self = shift;
my $schema = shift;
+ local $schema->storage->{debug}
+ if ($ENV{TRAVIS}||'') eq 'true';
+
$schema->populate('Genre', [
[qw/genreid name/],
[qw/1 emo /],
$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);
--- /dev/null
+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;
],
},
- 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 => [
'(
'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 {
[ ("'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);
}
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',
$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 ([ ... ])
};
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
warnings_exist (
sub { $storage->connect_info ($invocations->{$type}{args}) },
- $invocations->{$type}{warn} || (),
+ $invocations->{$type}{warn} || [],
'Warned about ignored attributes',
);
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;
# 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';
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;
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');
projects / dbsrgits/DBIx-Class.git / commitdiff