Revision history for DBIx::Class
- - Add a warning to load_namespaces if a class in ResultSet/
- is not a subclass of DBIx::Class::ResultSet
+ * New Features
+ - Add DBIx::Class::FilterColumn for non-ref filtering
- ::Storage::DBI now correctly preserves a parent $dbh from
terminating children, even during interpreter-global
out-of-order destruction
+ - dbicadmin supports an -I option with the same semantics as
+ perl itself
- InflateColumn::DateTime support for MSSQL via DBD::Sybase
- Millisecond precision support for MSSQL datetimes for
InflateColumn::DateTime
resultsets
- MSSQL limits now don't require nearly as many applications of
the unsafe_subselect_ok attribute, due to optimized queries
+ - Support for Generic Subquery limit "emulation" - awfully slow
+ and inefficient but works on almost any db, and is preferred
+ to a soft-limit
+
+ * Fixes
+ - Fix nasty potentially data-eating bug when deleting/updating
+ a limited resultset
+ - Fix find() to use result_class set on object
+ - Fix result_class setter behaviour to not mistakenly stuff attrs.
+ - Don't try and ensure_class_loaded an object. This doesn't work.
- Fix as_subselect_rs to not inject resultset class-wide where
conditions outside of the resulting subquery
+ - update() on row not in_storage no longer throws an exception
+ if there are no dirty columns to update (fixes cascaded update
+ annoyances)
+ - update()/delete() on prefetching resultsets no longer results
+ in malformed SQL (some $rs attributes were erroneously left in)
+ - Fix dbicadmin to allow deploy() on non-versioned schema
+ - Fix dbicadmin to respect sql_dir on upgrade() (RT#57732)
+ - Update Schema::Versioned to respect hashref style of
+ connection_info
+ - Do not recreate the same related object twice during MultiCreate
+ (solves the problem of orphaned IC::FS files)
+ - Fully qualify xp_msver selector when using DBD::Sybase with
+ MSSQL (RT#57467)
+ - Fix ::DBI::Storage to always be able to present a full set of
+ connect() attributes to e.g. Schema::Versioned
+
+ * Misc
+ - Add a warning to load_namespaces if a class in ResultSet/
+ is not a subclass of DBIx::Class::ResultSet
+ - All DBIC exception-handling switched to Try::Tiny
- Depend on optimized SQL::Abstract (faster SQL generation)
- - update on row not in database now OK if no changes -
- fixes problems with cascaded unnecessary updates
-
0.08121 2010-04-11 18:43:00 (UTC)
- Support for Firebird RDBMS with DBD::InterBase and ODBC
'MRO::Compat' => '0.09',
'Module::Find' => '0.06',
'Path::Class' => '0.18',
- 'SQL::Abstract' => '1.66',
+ 'SQL::Abstract' => '1.67',
'SQL::Abstract::Limit' => '0.13',
'Sub::Name' => '0.04',
'Data::Dumper::Concise' => '1.000',
'Scope::Guard' => '0.03',
'Context::Preserve' => '0.01',
+ 'Try::Tiny' => '0.04',
+ 'namespace::clean' => '0.14',
};
# this is so we can order requires alphabetically
sub _attr_cache {
my $self = shift;
my $cache = $self->can('__attr_cache') ? $self->__attr_cache : {};
- my $rest = eval { $self->next::method };
- return $@ ? $cache : { %$cache, %$rest };
+
+ return {
+ %$cache,
+ %{ $self->maybe::next::method || {} },
+ };
}
1;
Tom Hukins
+tonvoon: Ton Voon <tonvoon@cpan.org>
+
triode: Pete Gamache <gamache@cpan.org>
typester: Daisuke Murase <typester@cpan.org>
sub _build_schema {
my ($self) = @_;
require Class::MOP;
- Class::MOP::load_class($self->schema_class);
-
+ {
+ my @include_dirs = @{$self->include_dirs};
+ local @INC = (@include_dirs, @INC);
+ Class::MOP::load_class($self->schema_class);
+ }
$self->connect_info->[3]->{ignore_version} =1;
return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
}
+=head2 include_dirs
+
+Extra include directories to look when loading C<schema_class>
+
+=cut
+
+has 'include_dirs' => (
+ is => 'rw',
+ isa => 'ArrayRef',
+ default => sub {[]}
+);
=head2 resultset
=head2 config
-Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
+Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
config_stanza will still be required.
=cut
sub _build_config {
my ($self) = @_;
- eval { require Config::Any }
- or die ("Config::Any is required to parse the config file.\n");
+ try { require Config::Any }
+ catch { die ("Config::Any is required to parse the config file.\n") };
my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
=back
-L<create> will generate sql for the supplied schema_class in sql_dir. The flavour of sql to
-generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
+L<create> will generate sql for the supplied schema_class in sql_dir. The
+flavour of sql to generate can be controlled by supplying a sqlt_type which
+should be a L<SQL::Translator> name.
Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
sub upgrade {
my ($self) = @_;
my $schema = $self->schema();
+
if (!$schema->get_db_version()) {
# schema is unversioned
$schema->throw_exception ("Could not determin current schema version, please either install() or deploy().\n");
} else {
+ $schema->upgrade_directory ($self->sql_dir) if $self->sql_dir; # this will override whatever default the schema has
my $ret = $schema->upgrade();
return $ret;
}
=back
-install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
-database. install will take a version and add the version tracking tables and 'install' the version. No
-further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
+install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
+database. install will take a version and add the version tracking tables and 'install' the version. No
+further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
already versioned databases.
=cut
$version ||= $self->version();
if (!$schema->get_db_version() ) {
# schema is unversioned
- print "Going to install schema version\n";
+ print "Going to install schema version\n" if (!$self->quiet);
my $ret = $schema->install($version);
- print "retun is $ret\n";
+ print "return is $ret\n" if (!$self->quiet);
}
elsif ($schema->get_db_version() and $self->force ) {
carp "Forcing install may not be a good idea";
=back
-deploy will create the schema at the connected database. C<$args> are passed straight to
+deploy will create the schema at the connected database. C<$args> are passed straight to
L<DBIx::Class::Schema/deploy>.
=cut
sub deploy {
my ($self, $args) = @_;
my $schema = $self->schema();
- if (!$schema->get_db_version() ) {
- # schema is unversioned
- $schema->deploy( $args, $self->sql_dir)
- or $schema->throw_exception ("Could not deploy schema.\n"); # FIXME deploy() does not return 1/0 on success/fail
- } else {
- $schema->throw_exception("A versioned schema has already been deployed, try upgrade instead.\n");
- }
+ $schema->deploy( $args, $self->sql_dir );
}
=head2 insert
=back
-select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
+select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
The found data is returned in a array ref where the first row will be the columns list.
=cut
my @data;
my @columns = $resultset->result_source->columns();
- push @data, [@columns];#
+ push @data, [@columns];#
while (my $row = $resultset->next()) {
my @fields;
sub _confirm {
my ($self) = @_;
- print "Are you sure you want to do this? (type YES to confirm) \n";
+
# mainly here for testing
return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
+
+ print "Are you sure you want to do this? (type YES to confirm) \n";
my $response = <STDIN>;
- return 1 if ($response=~/^YES/);
- return;
+
+ return ($response=~/^YES/);
}
sub _find_stanza {
for (qw/DBIx::Class::UTF8Columns DBIx::Class::ForceUTF8/) {
if ($comp->isa ($_) ) {
$keep_checking = 0; # no use to check from this point on
- carp "Use of $_ is strongly discouraged. See documentationm of DBIx::Class::UTF8Columns for more info\n"
+ carp "Use of $_ is strongly discouraged. See documentation of DBIx::Class::UTF8Columns for more info\n"
unless ($warned->{UTF8Columns}++ || $ENV{DBIC_UTF8COLUMNS_OK});
last;
}
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
+use Carp::Clan qw/^DBIx::Class|^Try::Tiny/;
use Scalar::Util qw/blessed/;
+use Try::Tiny;
+use namespace::clean;
use overload
'""' => sub { shift->{msg} },
L<Carp::Clan/croak>.
DBIx::Class::Exception->throw('Foo');
- eval { ... }; DBIx::Class::Exception->throw($@) if $@;
+ try { ... } catch { DBIx::Class::Exception->throw(shift) }
=cut
# use Carp::Clan's croak if we're not stack tracing
if(!$stacktrace) {
- local $@;
- eval { croak $msg };
- $msg = $@
+ try { croak $msg } catch { $msg = shift };
}
else {
$msg = Carp::longmess($msg);
--- /dev/null
+package DBIx::Class::FilterColumn;
+use strict;
+use warnings;
+
+use base qw/DBIx::Class::Row/;
+
+sub filter_column {
+ my ($self, $col, $attrs) = @_;
+
+ $self->throw_exception("FilterColumn does not work with InflateColumn")
+ if $self->isa('DBIx::Class::InflateColumn') &&
+ defined $self->column_info($col)->{_inflate_info};
+
+ $self->throw_exception("No such column $col to filter")
+ unless $self->has_column($col);
+
+ $self->throw_exception("filter_column needs attr hashref")
+ unless ref $attrs eq 'HASH';
+
+ $self->column_info($col)->{_filter_info} = $attrs;
+ my $acc = $self->column_info($col)->{accessor};
+ $self->mk_group_accessors(filtered_column => [ (defined $acc ? $acc : $col), $col]);
+ return 1;
+}
+
+sub _column_from_storage {
+ my ($self, $col, $value) = @_;
+
+ return $value unless defined $value;
+
+ my $info = $self->column_info($col)
+ or $self->throw_exception("No column info for $col");
+
+ return $value unless exists $info->{_filter_info};
+
+ my $filter = $info->{_filter_info}{filter_from_storage};
+ $self->throw_exception("No filter for $col") unless defined $filter;
+
+ return $self->$filter($value);
+}
+
+sub _column_to_storage {
+ my ($self, $col, $value) = @_;
+
+ my $info = $self->column_info($col) or
+ $self->throw_exception("No column info for $col");
+
+ return $value unless exists $info->{_filter_info};
+
+ my $unfilter = $info->{_filter_info}{filter_to_storage};
+ $self->throw_exception("No unfilter for $col") unless defined $unfilter;
+ return $self->$unfilter($value);
+}
+
+sub get_filtered_column {
+ my ($self, $col) = @_;
+
+ $self->throw_exception("$col is not a filtered column")
+ unless exists $self->column_info($col)->{_filter_info};
+
+ return $self->{_filtered_column}{$col}
+ if exists $self->{_filtered_column}{$col};
+
+ my $val = $self->get_column($col);
+
+ return $self->{_filtered_column}{$col} = $self->_column_from_storage($col, $val);
+}
+
+sub get_column {
+ my ($self, $col) = @_;
+ if (exists $self->{_filtered_column}{$col}) {
+ return $self->{_column_data}{$col} ||= $self->_column_to_storage ($col, $self->{_filtered_column}{$col});
+ }
+
+ return $self->next::method ($col);
+}
+
+# sadly a separate codepath in Row.pm ( used by insert() )
+sub get_columns {
+ my $self = shift;
+
+ foreach my $col (keys %{$self->{_filtered_column}||{}}) {
+ $self->{_column_data}{$col} ||= $self->_column_to_storage ($col, $self->{_filtered_column}{$col})
+ if exists $self->{_filtered_column}{$col};
+ }
+
+ $self->next::method (@_);
+}
+
+sub store_column {
+ my ($self, $col) = (shift, @_);
+
+ # blow cache
+ delete $self->{_filtered_column}{$col};
+
+ $self->next::method(@_);
+}
+
+sub set_filtered_column {
+ my ($self, $col, $filtered) = @_;
+
+ # do not blow up the cache via set_column unless necessary
+ # (filtering may be expensive!)
+ if (exists $self->{_filtered_column}{$col}) {
+ return $filtered
+ if ($self->_eq_column_values ($col, $filtered, $self->{_filtered_column}{$col} ) );
+
+ $self->make_column_dirty ($col); # so the comparison won't run again
+ }
+
+ $self->set_column($col, $self->_column_to_storage($col, $filtered));
+
+ return $self->{_filtered_column}{$col} = $filtered;
+}
+
+sub update {
+ my ($self, $attrs, @rest) = @_;
+
+ foreach my $key (keys %{$attrs||{}}) {
+ if (
+ $self->has_column($key)
+ &&
+ exists $self->column_info($key)->{_filter_info}
+ ) {
+ $self->set_filtered_column($key, delete $attrs->{$key});
+
+ # FIXME update() reaches directly into the object-hash
+ # and we may *not* have a filtered value there - thus
+ # the void-ctx filter-trigger
+ $self->get_column($key) unless exists $self->{_column_data}{$key};
+ }
+ }
+
+ return $self->next::method($attrs, @rest);
+}
+
+sub new {
+ my ($class, $attrs, @rest) = @_;
+ my $source = $attrs->{-result_source}
+ or $class->throw_exception('Sourceless rows are not supported with DBIx::Class::FilterColumn');
+
+ my $obj = $class->next::method($attrs, @rest);
+ foreach my $key (keys %{$attrs||{}}) {
+ if ($obj->has_column($key) &&
+ exists $obj->column_info($key)->{_filter_info} ) {
+ $obj->set_filtered_column($key, $attrs->{$key});
+ }
+ }
+
+ return $obj;
+}
+
+1;
+
+=head1 NAME
+
+DBIx::Class::FilterColumn - Automatically convert column data
+
+=head1 SYNOPSIS
+
+ # In your result classes
+ __PACKAGE__->filter_column( money => {
+ filter_to_storage => 'to_pennies',
+ filter_from_storage => 'from_pennies',
+ });
+
+ sub to_pennies { $_[1] * 100 }
+
+ sub from_pennies { $_[1] / 100 }
+
+ 1;
+
+=head1 DESCRIPTION
+
+This component is meant to be a more powerful, but less DWIM-y,
+L<DBIx::Class::InflateColumn>. One of the major issues with said component is
+that it B<only> works with references. Generally speaking anything that can
+be done with L<DBIx::Class::InflateColumn> can be done with this component.
+
+=head1 METHODS
+
+=head2 filter_column
+
+ __PACKAGE__->filter_column( colname => {
+ filter_from_storage => 'method',
+ filter_to_storage => 'method',
+ })
+
+This is the method that you need to call to set up a filtered column. It takes
+exactly two arguments; the first being the column name the second being a
+C<HashRef> with C<filter_from_storage> and C<filter_to_storage> having
+something that can be called as a method. The method will be called with
+the value of the column as the first non-C<$self> argument.
+
+=head2 get_filtered_column
+
+ $obj->get_filtered_column('colname')
+
+Returns the filtered value of the column
+
+=head2 set_filtered_column
+
+ $obj->set_filtered_column(colname => 'new_value')
+
+Sets the filtered value of the column
to work.
If you want to filter plain scalar values and replace them with
-something else, contribute a filtering component.
+something else, see L<DBIx::Class::FilterColumn>.
=head1 METHODS
sub inflate_column {
my ($self, $col, $attrs) = @_;
+
+ $self->throw_exception("InflateColumn does not work with FilterColumn")
+ if $self->isa('DBIx::Class::FilterColumn') &&
+ defined $self->column_info($col)->{_filter_info};
+
$self->throw_exception("No such column $col to inflate")
unless $self->has_column($col);
$self->throw_exception("inflate_column needs attr hashref")
$self->set_column($col, $self->_deflated_column($col, $inflated));
# if (blessed $inflated) {
if (ref $inflated && ref($inflated) ne 'SCALAR') {
- $self->{_inflated_column}{$col} = $inflated;
+ $self->{_inflated_column}{$col} = $inflated;
} else {
- delete $self->{_inflated_column}{$col};
+ delete $self->{_inflated_column}{$col};
}
return $inflated;
}
use warnings;
use base qw/DBIx::Class/;
use Carp::Clan qw/^DBIx::Class/;
+use Try::Tiny;
+use namespace::clean;
=head1 NAME
=head1 SYNOPSIS
-Load this component and then declare one or more
+Load this component and then declare one or more
columns to be of the datetime, timestamp or date datatype.
package Event;
=head1 DESCRIPTION
-This module figures out the type of DateTime::Format::* class to
-inflate/deflate with based on the type of DBIx::Class::Storage::DBI::*
-that you are using. If you switch from one database to a different
+This module figures out the type of DateTime::Format::* class to
+inflate/deflate with based on the type of DBIx::Class::Storage::DBI::*
+that you are using. If you switch from one database to a different
one your code should continue to work without modification (though note
that this feature is new as of 0.07, so it may not be perfect yet - bug
reports to the list very much welcome).
inflate => sub {
my ($value, $obj) = @_;
- my $dt = eval { $obj->_inflate_to_datetime( $value, \%info ) };
- if (my $err = $@ ) {
- return undef if ($undef_if_invalid);
- $self->throw_exception ("Error while inflating ${value} for ${column} on ${self}: $err");
- }
-
- return $obj->_post_inflate_datetime( $dt, \%info );
+ my $dt = try
+ { $obj->_inflate_to_datetime( $value, \%info ) }
+ catch {
+ $self->throw_exception ("Error while inflating ${value} for ${column} on ${self}: $_")
+ unless $undef_if_invalid;
+ undef; # rv
+ };
+
+ return (defined $dt)
+ ? $obj->_post_inflate_datetime( $dt, \%info )
+ : undef
+ ;
},
deflate => sub {
my ($value, $obj) = @_;
=over 4
-=item More information about the add_columns method, and column metadata,
+=item More information about the add_columns method, and column metadata,
can be found in the documentation for L<DBIx::Class::ResultSource>.
=item Further discussion of problems inherent to the Floating timezone:
- L<Floating DateTimes|DateTime/Floating_DateTimes>
+ L<Floating DateTimes|DateTime/Floating_DateTimes>
and L<< $dt->set_time_zone|DateTime/"Set" Methods >>
=back
return $genus->species;
};
+ use Try::Tiny;
my $rs;
- eval {
+ try {
$rs = $schema->txn_do($coderef1);
- };
-
- if ($@) { # Transaction failed
+ } catch {
+ # Transaction failed
die "the sky is falling!" #
- if ($@ =~ /Rollback failed/); # Rollback failed
+ if ($_ =~ /Rollback failed/); # Rollback failed
deal_with_failed_transaction();
- }
+ };
Note: by default C<txn_do> will re-run the coderef one more time if an
error occurs due to client disconnection (e.g. the server is bounced).
my $schema = MySchema->connect("dbi:Pg:dbname=my_db");
# Start a transaction. Every database change from here on will only be
- # committed into the database if the eval block succeeds.
- eval {
+ # committed into the database if the try block succeeds.
+ use Try::Tiny;
+ my $exception;
+ try {
$schema->txn_do(sub {
# SQL: BEGIN WORK;
for (1..10) {
# Start a nested transaction, which in fact sets a savepoint.
- eval {
+ try {
$schema->txn_do(sub {
# SQL: SAVEPOINT savepoint_0;
# WHERE ( id = 42 );
}
});
- };
- if ($@) {
+ } catch {
# SQL: ROLLBACK TO SAVEPOINT savepoint_0;
# There was an error while creating a $thing. Depending on the error
# changes related to the creation of this $thing
# Abort the whole job
- if ($@ =~ /horrible_problem/) {
+ if ($_ =~ /horrible_problem/) {
print "something horrible happend, aborting job!";
- die $@; # rethrow error
+ die $_; # rethrow error
}
# Ignore this $thing, report the error, and continue with the
# next $thing
- print "Cannot create thing: $@";
+ print "Cannot create thing: $_";
}
# There was no error, so save all changes since the last
# savepoint.
# SQL: RELEASE SAVEPOINT savepoint_0;
}
});
- };
- if ($@) {
+ } catch {
+ $exception = $_;
+ }
+
+ if ($caught) {
# 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
# SQL: ROLLBACK;
- print "ERROR: $@\n";
+ print "ERROR: $exception\n";
}
else {
# There was no error while handling the $job. Commit all changes.
In this example it might be hard to see where the rollbacks, releases and
commits are happening, but it works just the same as for plain L<<txn_do>>: If
-the C<eval>-block around C<txn_do> fails, a rollback is issued. If the C<eval>
+the C<try>-block around C<txn_do> fails, a rollback is issued. If the C<try>
succeeds, the transaction is committed (or the savepoint released).
While you can get more fine-grained control using C<svp_begin>, C<svp_release>
replicated => {
req => {
%$moose_basic,
- 'namespace::clean' => '0.11',
'Hash::Merge' => '0.12',
},
pod => {
# This is to be called by the author only (automatically in Makefile.PL)
sub _gen_pod {
+
my $class = shift;
my $modfn = __PACKAGE__ . '.pm';
$modfn =~ s/\:\:/\//g;
- require DBIx::Class;
- my $distver = DBIx::Class->VERSION;
+ my $podfn = __FILE__;
+ $podfn =~ s/\.pm$/\.pod/;
+
+ my $distver =
+ eval { require DBIx::Class; DBIx::Class->VERSION; }
+ ||
+ do {
+ warn
+"\n\n---------------------------------------------------------------------\n" .
+'Unable to load core DBIx::Class module to determine current version, '.
+'possibly due to missing dependencies. Author-mode autodocumentation ' .
+"halted\n\n" . $@ .
+"\n\n---------------------------------------------------------------------\n"
+ ;
+ '*UNKNOWN*'; # rv
+ }
+ ;
+
my $sqltver = $class->req_list_for ('deploy')->{'SQL::Translator'}
or die "Hrmm? No sqlt dep?";
<<'EOD',
Dependencies are organized in C<groups> and each group can list one or more
required modules, with an optional minimum version (or 0 for any version).
-The group name can be used in the
+The group name can be used in the
EOD
);
'You may distribute this code under the same terms as Perl itself',
);
- my $fn = __FILE__;
- $fn =~ s/\.pm$/\.pod/;
-
- open (my $fh, '>', $fn) or croak "Unable to write to $fn: $!";
+ open (my $fh, '>', $podfn) or croak "Unable to write to $podfn: $!";
print $fh join ("\n\n", @chunks);
close ($fh);
}
use Scalar::Util ();
use base qw/DBIx::Class/;
+use Try::Tiny;
+use namespace::clean;
=head1 NAME
=item is_foreign_key_constraint
If you are using L<SQL::Translator> to create SQL for you and you find that it
-is creating constraints where it shouldn't, or not creating them where it
+is creating constraints where it shouldn't, or not creating them where it
should, set this attribute to a true or false value to override the detection
of when to create constraints.
If C<cascade_copy> is true on a C<has_many> relationship for an
object, then when you copy the object all the related objects will
-be copied too. To turn this behaviour off, pass C<< cascade_copy => 0 >>
-in the C<$attr> hashref.
+be copied too. To turn this behaviour off, pass C<< cascade_copy => 0 >>
+in the C<$attr> hashref.
The behaviour defaults to C<< cascade_copy => 1 >> for C<has_many>
relationships.
By default, DBIx::Class cascades deletes across C<has_many>,
C<has_one> and C<might_have> relationships. You can disable this
-behaviour on a per-relationship basis by supplying
+behaviour on a per-relationship basis by supplying
C<< cascade_delete => 0 >> in the relationship attributes.
The cascaded operations are performed after the requested delete,
=item on_delete / on_update
If you are using L<SQL::Translator> to create SQL for you, you can use these
-attributes to explicitly set the desired C<ON DELETE> or C<ON UPDATE> constraint
-type. If not supplied the SQLT parser will attempt to infer the constraint type by
+attributes to explicitly set the desired C<ON DELETE> or C<ON UPDATE> constraint
+type. If not supplied the SQLT parser will attempt to infer the constraint type by
interrogating the attributes of the B<opposite> relationship. For any 'multi'
-relationship with C<< cascade_delete => 1 >>, the corresponding belongs_to
-relationship will be created with an C<ON DELETE CASCADE> constraint. For any
+relationship with C<< cascade_delete => 1 >>, the corresponding belongs_to
+relationship will be created with an C<ON DELETE CASCADE> constraint. For any
relationship bearing C<< cascade_copy => 1 >> the resulting belongs_to constraint
will be C<ON UPDATE CASCADE>. If you wish to disable this autodetection, and just
-use the RDBMS' default constraint type, pass C<< on_delete => undef >> or
+use the RDBMS' default constraint type, pass C<< on_delete => undef >> or
C<< on_delete => '' >>, and the same for C<on_update> respectively.
=item is_deferrable
# condition resolution may fail if an incomplete master-object prefetch
# is encountered - that is ok during prefetch construction (not yet in_storage)
- my $cond = eval { $source->_resolve_condition( $rel_info->{cond}, $rel, $self ) };
- if (my $err = $@) {
+ my $cond = try {
+ $source->_resolve_condition( $rel_info->{cond}, $rel, $self )
+ }
+ catch {
if ($self->in_storage) {
- $self->throw_exception ($err);
- }
- else {
- $cond = $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION;
+ $self->throw_exception ($_);
}
- }
+
+ $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION; # RV
+ };
if ($cond eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) {
my $reverse = $source->reverse_relationship_info($rel);
( $objects_rs ) = $rs->search_related_rs('relname', $cond, $attrs);
-This method works exactly the same as search_related, except that
+This method works exactly the same as search_related, except that
it guarantees a resultset, even in list context.
=cut
my $new_obj = $obj->new_related('relname', \%col_data);
Create a new item of the related foreign class. If called on a
-L<Row|DBIx::Class::Manual::Glossary/"Row"> object, it will magically
-set any foreign key columns of the new object to the related primary
-key columns of the source object for you. The newly created item will
+L<Row|DBIx::Class::Manual::Glossary/"Row"> object, it will magically
+set any foreign key columns of the new object to the related primary
+key columns of the source object for you. The newly created item will
not be saved into your storage until you call L<DBIx::Class::Row/insert>
on it.
=back
my $actor = $schema->resultset('Actor')->find(1);
- my @roles = $schema->resultset('Role')->search({ role =>
+ my @roles = $schema->resultset('Role')->search({ role =>
{ '-in' => ['Fred', 'Barney'] } } );
$actor->set_roles(\@roles);
use strict;
use warnings;
+use Try::Tiny;
+use namespace::clean;
-our %_pod_inherit_config =
+our %_pod_inherit_config =
(
class_map => { 'DBIx::Class::Relationship::BelongsTo' => 'DBIx::Class::Relationship' }
);
my ($class, $rel, $f_class, $cond, $attrs) = @_;
# assume a foreign key contraint unless defined otherwise
- $attrs->{is_foreign_key_constraint} = 1
+ $attrs->{is_foreign_key_constraint} = 1
if not exists $attrs->{is_foreign_key_constraint};
$attrs->{undef_on_null_fk} = 1
if not exists $attrs->{undef_on_null_fk};
# no join condition or just a column name
if (!ref $cond) {
$class->ensure_class_loaded($f_class);
- my %f_primaries = map { $_ => 1 } eval { $f_class->_pri_cols };
- $class->throw_exception(
- "Can't infer join condition for ${rel} on ${class}: $@"
- ) if $@;
+ my %f_primaries = map { $_ => 1 } try { $f_class->_pri_cols }
+ catch {
+ $class->throw_exception( "Can't infer join condition for ${rel} on ${class}: $_");
+ };
my ($pri, $too_many) = keys %f_primaries;
$class->throw_exception(
use strict;
use warnings;
+use Try::Tiny;
+use namespace::clean;
-our %_pod_inherit_config =
+our %_pod_inherit_config =
(
class_map => { 'DBIx::Class::Relationship::HasMany' => 'DBIx::Class::Relationship' }
);
unless (ref $cond) {
$class->ensure_class_loaded($f_class);
- my ($pri, $too_many) = eval { $class->_pri_cols };
- $class->throw_exception(
- "Can't infer join condition for ${rel} on ${class}: $@"
- ) if $@;
+ my ($pri, $too_many) = try { $class->_pri_cols }
+ catch {
+ $class->throw_exception("Can't infer join condition for ${rel} on ${class}: $_");
+ };
$class->throw_exception(
"has_many can only infer join for a single primary key; ".
$guess = "using our class name '$class' as foreign key";
}
- my $f_class_loaded = eval { $f_class->columns };
+ my $f_class_loaded = try { $f_class->columns };
$class->throw_exception(
"No such column ${f_key} on foreign class ${f_class} ($guess)"
) if $f_class_loaded && !$f_class->has_column($f_key);
use strict;
use warnings;
use Carp::Clan qw/^DBIx::Class/;
+use Try::Tiny;
+use namespace::clean;
-our %_pod_inherit_config =
+our %_pod_inherit_config =
(
class_map => { 'DBIx::Class::Relationship::HasOne' => 'DBIx::Class::Relationship' }
);
"${class} has none"
) if !defined $pri && (!defined $cond || !length $cond);
- my $f_class_loaded = eval { $f_class->columns };
+ my $f_class_loaded = try { $f_class->columns };
my ($f_key,$too_many,$guess);
if (defined $cond && length $cond) {
$f_key = $cond;
sub _get_primary_key {
my ( $class, $target_class ) = @_;
$target_class ||= $class;
- my ($pri, $too_many) = eval { $target_class->_pri_cols };
- $class->throw_exception(
- "Can't infer join condition on ${target_class}: $@"
- ) if $@;
+ my ($pri, $too_many) = try { $target_class->_pri_cols }
+ catch {
+ $class->throw_exception("Can't infer join condition on ${target_class}: $_");
+ };
$class->throw_exception(
"might_have/has_one can only infer join for a single primary key; ".
The query that the ResultSet represents is B<only> executed against
the database when these methods are called:
-L</find> L</next> L</all> L</first> L</single> L</count>
+L</find>, L</next>, L</all>, L</first>, L</single>, L</count>.
+
+If a resultset is used in a numeric context it returns the L</count>.
+However, if it is used in a boolean context it is B<always> true. So if
+you want to check if a resultset has any results, you must use C<if $rs
+!= 0>.
=head1 EXAMPLES
L</join>, L</prefetch>, L</+select>, L</+as> attributes are merged
into the existing ones from the original resultset.
-The L</where>, L</having> attribute, and any search conditions are
+The L</where> and L</having> attributes, and any search conditions, are
merged with an SQL C<AND> to the existing condition from the original
resultset.
See: L</search>, L</count>, L</get_column>, L</all>, L</create>.
-=head1 OVERLOADING
-
-If a resultset is used in a numeric context it returns the L</count>.
-However, if it is used in a boolean context it is always true. So if
-you want to check if a resultset has any results use C<if $rs != 0>.
-C<if $rs> will always be true.
-
=head1 METHODS
=head2 new
my $self = {
_source_handle => $source,
cond => $attrs->{where},
- count => undef,
pager => undef,
attrs => $attrs
};
: $self->_add_alias($input_query, $alias);
}
- # Run the query
- my $rs = $self->search ($query, $attrs);
+ # Run the query, passing the result_class since it should propagate for find
+ my $rs = $self->search ($query, {result_class => $self->result_class, %$attrs});
if (keys %{$rs->_resolved_attrs->{collapse}}) {
my $row = $rs->next;
carp "Query returned more than one row" if $rs->next;
sub result_class {
my ($self, $result_class) = @_;
if ($result_class) {
- $self->ensure_class_loaded($result_class);
+ unless (ref $result_class) { # don't fire this for an object
+ $self->ensure_class_loaded($result_class);
+ }
$self->_result_class($result_class);
- $self->{attrs}{result_class} = $result_class if ref $self;
+ # THIS LINE WOULD BE A BUG - this accessor specifically exists to
+ # permit the user to set result class on one result set only; it only
+ # chains if provided to search()
+ #$self->{attrs}{result_class} = $result_class if ref $self;
}
$self->_result_class;
}
my $cond = $rsrc->schema->storage->_strip_cond_qualifiers ($self->{cond});
my $needs_group_by_subq = $self->_has_resolved_attr (qw/collapse group_by -join/);
- my $needs_subq = $needs_group_by_subq || (not defined $cond) || $self->_has_resolved_attr(qw/row offset/);
+ my $needs_subq = $needs_group_by_subq || (not defined $cond) || $self->_has_resolved_attr(qw/rows offset/);
if ($needs_group_by_subq or $needs_subq) {
# make a new $rs selecting only the PKs (that's all we really need)
my $attrs = $self->_resolved_attrs_copy;
- delete $attrs->{$_} for qw/collapse select as/;
+
+ delete $attrs->{$_} for qw/collapse _collapse_order_by select _prefetch_select as/;
$attrs->{columns} = [ map { "$attrs->{alias}.$_" } ($self->result_source->_pri_cols) ];
if ($needs_group_by_subq) {
}
my $subrs = (ref $self)->new($rsrc, $attrs);
-
return $self->result_source->storage->_subq_update_delete($subrs, $op, $values);
}
else {
use DBIx::Class::Exception;
use Carp::Clan qw/^DBIx::Class/;
+use Try::Tiny;
+use namespace::clean;
use base qw/DBIx::Class/;
If a column name beginning with a plus sign ('+col1') is provided, the
attributes provided will be merged with any existing attributes for the
column, with the new attributes taking precedence in the case that an
-attribute already exists. Using this without a hashref
+attribute already exists. Using this without a hashref
(C<< $source->add_columns(qw/+col1 +col2/) >>) is legal, but useless --
it does the same thing it would do without the plus.
This contains the column type. It is automatically filled if you use the
L<SQL::Translator::Producer::DBIx::Class::File> producer, or the
-L<DBIx::Class::Schema::Loader> module.
+L<DBIx::Class::Schema::Loader> module.
Currently there is no standard set of values for the data_type. Use
whatever your database supports.
$self->{_columns_info_loaded}++;
my $info = {};
my $lc_info = {};
- # eval for the case of storage without table
- eval { $info = $self->storage->columns_info_for( $self->from ) };
- unless ($@) {
+
+ # try for the case of storage without table
+ try {
+ $info = $self->storage->columns_info_for( $self->from );
for my $realcol ( keys %{$info} ) {
$lc_info->{lc $realcol} = $info->{$realcol};
}
%{ $info->{$col} || $lc_info->{lc $col} || {} }
};
}
- }
+ };
}
return $self->_columns->{$column};
}
my $schema = $source->schema();
-Returns the L<DBIx::Class::Schema> object that this result source
+Returns the L<DBIx::Class::Schema> object that this result source
belongs to.
=head2 storage
return $self;
- # XXX disabled. doesn't work properly currently. skip in tests.
+# XXX disabled. doesn't work properly currently. skip in tests.
my $f_source = $self->schema->source($f_source_name);
unless ($f_source) {
}
return unless $f_source; # Can't test rel without f_source
- eval { $self->_resolve_join($rel, 'me', {}, []) };
-
- if ($@) { # If the resolve failed, back out and re-throw the error
- delete $rels{$rel}; #
+ try { $self->_resolve_join($rel, 'me', {}, []) }
+ catch {
+ # If the resolve failed, back out and re-throw the error
+ delete $rels{$rel};
$self->_relationships(\%rels);
- $self->throw_exception("Error creating relationship $rel: $@");
- }
+ $self->throw_exception("Error creating relationship $rel: $_");
+ };
+
1;
}
keys %{$rel_info->{cond}};
my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
? @{$rel_info->{attrs}{order_by}}
-
+
: (defined $rel_info->{attrs}{order_by}
? ($rel_info->{attrs}{order_by})
: ()));
=head2 handle
-Obtain a new handle to this source. Returns an instance of a
+Obtain a new handle to this source. Returns an instance of a
L<DBIx::Class::ResultSourceHandle>.
=cut
use DBIx::Class::Exception;
use Scalar::Util ();
+use Try::Tiny;
+use namespace::clean;
###
### Internal method
MULTICREATE_DEBUG and warn "MC $self pre-reconstructing $relname $rel_obj\n";
- my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_inflated_columns };
+ my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_columns };
my $existing;
# if there are no keys - nothing to search for
my $reverse = $source->reverse_relationship_info($relname);
foreach my $obj (@cands) {
$obj->set_from_related($_, $self) for keys %$reverse;
- my $them = { %{$obj->{_relationship_data} || {} }, $obj->get_inflated_columns };
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";
- } else {
- MULTICREATE_DEBUG and warn "MC $self re-creating $relname $obj";
- my $re = $self->result_source
- ->related_source($relname)
- ->resultset
- ->create($them);
- %{$obj} = %{$re};
- MULTICREATE_DEBUG and warn "MC $self new $relname $obj";
+ }
+ else {
+ MULTICREATE_DEBUG and warn "MC $self inserting $relname $obj";
+ $obj->insert;
}
} else {
MULTICREATE_DEBUG and warn "MC $self post-inserting $obj";
my ($self, $column, $new_value) = @_;
# if we can't get an ident condition on first try - mark the object as unidentifiable
- $self->{_orig_ident} ||= (eval { $self->ident_condition }) || {};
+ $self->{_orig_ident} ||= (try { $self->ident_condition }) || {};
my $old_value = $self->get_column($column);
$new_value = $self->store_column($column, $new_value);
- my $dirty;
- if (!$self->in_storage) { # no point tracking dirtyness on uninserted data
- $dirty = 1;
- }
- elsif (defined $old_value xor defined $new_value) {
- $dirty = 1;
- }
- elsif (not defined $old_value) { # both undef
- $dirty = 0;
- }
- elsif ($old_value eq $new_value) {
- $dirty = 0;
- }
- else { # do a numeric comparison if datatype allows it
- if ($self->_is_column_numeric($column)) {
- $dirty = $old_value != $new_value;
- }
- else {
- $dirty = 1;
- }
- }
+ my $dirty =
+ $self->{_dirty_columns}{$column}
+ ||
+ $self->in_storage # no point tracking dirtyness on uninserted data
+ ? ! $self->_eq_column_values ($column, $old_value, $new_value)
+ : 1
+ ;
- # sadly the update code just checks for keys, not for their value
+ # FIXME sadly the update code just checks for keys, not for their value
$self->{_dirty_columns}{$column} = 1 if $dirty;
# XXX clear out the relation cache for this column
return $new_value;
}
+sub _eq_column_values {
+ my ($self, $col, $old, $new) = @_;
+
+ if (defined $old xor defined $new) {
+ return 0;
+ }
+ elsif (not defined $old) { # both undef
+ return 1;
+ }
+ elsif ($old eq $new) {
+ return 1;
+ }
+ elsif ($self->_is_column_numeric($col)) { # do a numeric comparison if datatype allows it
+ return $old == $new;
+ }
+ else {
+ return 0;
+ }
+}
+
=head2 set_columns
$row->set_columns({ $col => $val, ... });
if ($source->isa('DBIx::Class::ResultSourceHandle')) {
$source = $source_handle->resolve
- }
+ }
else {
$source_handle = $source->handle
}
sub discard_changes {
my ($self, $attrs) = @_;
- delete $self->{_dirty_columns};
return unless $self->in_storage; # Don't reload if we aren't real!
# add a replication default to read from the master only
# !!! THIS IS ALSO HORRIFIC !!! /me ashamed
#
-# generate inner/outer select lists for various limit dialects
+# Generates inner/outer select lists for various limit dialects
# which result in one or more subqueries (e.g. RNO, Top, RowNum)
# Any non-root-table columns need to have their table qualifier
# turned into a column alias (otherwise names in subqueries clash
# and/or lose their source table)
#
-# returns inner/outer strings of SQL QUOTED selectors with aliases
+# Returns inner/outer strings of SQL QUOTED selectors with aliases
# (to be used in whatever select statement), and an alias index hashref
# of QUOTED SEL => QUOTED ALIAS pairs (to maybe be used for string-subst
-# higher up)
-#
-# If the $scan_order option is supplied, it signals that the limit dialect
-# needs to order the outer side of the query, which in turn means that the
-# inner select needs to bring out columns used in implicit (non-selected)
-# orders, and the order condition itself needs to be realiased to the proper
-# names in the outer query.
-#
-# In this case ($scan_order os true) we also return a hashref (order doesn't
-# matter) of QUOTED EXTRA-SEL => QUOTED ALIAS pairs, which is a list of extra
-# selectors that do *not* exist in the original select list
+# higher up).
+# If an order_by is supplied, the inner select needs to bring out columns
+# used in implicit (non-selected) orders, and the order condition itself
+# needs to be realiased to the proper names in the outer query. Thus we
+# also return a hashref (order doesn't matter) of QUOTED EXTRA-SEL =>
+# QUOTED ALIAS pairs, which is a list of extra selectors that do *not*
+# exist in the original select list
sub _subqueried_limit_attrs {
- my ($self, $rs_attrs, $scan_order) = @_;
+ my ($self, $rs_attrs) = @_;
croak 'Limit dialect implementation usable only in the context of DBIC (missing $rs_attrs)'
unless ref ($rs_attrs) eq 'HASH';
$in_sel_index->{$sql_sel}++;
$in_sel_index->{$self->_quote ($sql_alias)}++ if $sql_alias;
-# this *may* turn out to be necessary, not sure yet
-# my ($sql_unqualified_sel) = $sql_sel =~ / $re_sep (.+) $/x
-# if ! ref $s;
-# $in_sel_index->{$sql_unqualified_sel}++;
+ # record unqualified versions too, so we do not have
+ # to reselect the same column twice (in qualified and
+ # unqualified form)
+ if (! ref $s && $sql_sel =~ / $re_sep (.+) $/x) {
+ $in_sel_index->{$1}++;
+ }
}
}
}
+ # see if the order gives us anything
my %extra_order_sel;
- if ($scan_order) {
- for my $chunk ($self->_order_by_chunks ($rs_attrs->{order_by})) {
- # order with bind
- $chunk = $chunk->[0] if (ref $chunk) eq 'ARRAY';
- $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
+ for my $chunk ($self->_order_by_chunks ($rs_attrs->{order_by})) {
+ # order with bind
+ $chunk = $chunk->[0] if (ref $chunk) eq 'ARRAY';
+ $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
- next if $in_sel_index->{$chunk};
+ next if $in_sel_index->{$chunk};
- $extra_order_sel{$chunk} ||= $self->_quote (
- 'ORDER__BY__' . scalar keys %extra_order_sel
- );
- }
+ $extra_order_sel{$chunk} ||= $self->_quote (
+ 'ORDER__BY__' . scalar keys %extra_order_sel
+ );
}
+
return (
(map { join (', ', @$_ ) } (
\@in_sel,
or croak "Unrecognizable SELECT: $sql";
# get selectors, and scan the order_by (if any)
- my ($in_sel, $out_sel, $alias_map, $extra_order_sel) = $self->_subqueried_limit_attrs (
- $rs_attrs, 'scan_order_by',
- );
+ my ($in_sel, $out_sel, $alias_map, $extra_order_sel)
+ = $self->_subqueried_limit_attrs ( $rs_attrs );
# make up an order if none exists
my $requested_order = (delete $rs_attrs->{order_by}) || $self->_rno_default_order;
SELECT $mid_sel, ROW_NUMBER() OVER( $rno_ord ) AS $idx_name FROM (
SELECT $in_sel ${sql}${group_having}
) $qalias
-) $qalias WHERE $idx_name BETWEEN %d AND %d
+) $qalias WHERE $idx_name BETWEEN %u AND %u
EOS
return sprintf ('SELECT %s%s%s%s',
$offset
- ? sprintf ('SKIP %d ', $offset)
+ ? sprintf ('SKIP %u ', $offset)
: ''
,
- sprintf ('FIRST %d ', $rows),
+ sprintf ('FIRST %u ', $rows),
$sql,
$self->_parse_rs_attrs ($rs_attrs),
);
or croak "Unrecognizable SELECT: $sql";
return sprintf ('SELECT %s%s%s%s',
- sprintf ('FIRST %d ', $rows),
+ sprintf ('FIRST %u ', $rows),
$offset
- ? sprintf ('SKIP %d ', $offset)
+ ? sprintf ('SKIP %u ', $offset)
: ''
,
$sql,
SELECT $outsel, ROWNUM $idx_name FROM (
SELECT $insel ${sql}${order_group_having}
) $qalias
-) $qalias WHERE $idx_name BETWEEN %d AND %d
+) $qalias WHERE $idx_name BETWEEN %u AND %u
EOS
# get selectors
my ($in_sel, $out_sel, $alias_map, $extra_order_sel)
- = $self->_subqueried_limit_attrs ($rs_attrs, 'outer_order_by');
+ = $self->_subqueried_limit_attrs ($rs_attrs);
my $requested_order = delete $rs_attrs->{order_by};
$mid_sel .= ', ' . $extra_order_sel->{$extra_col};
}
+
+ # since whatever order bindvals there are, they will be realiased
+ # and need to show up in front of the entire initial inner subquery
+ # Unshift *from_bind* to make this happen (horrible, horrible, but
+ # we don't have another mechanism yet)
+ unshift @{$self->{from_bind}}, @{$self->{order_bind}};
}
# and this is order re-alias magic
my $quoted_rs_alias = $self->_quote ($rs_attrs->{alias});
- $sql = sprintf ('SELECT TOP %d %s %s %s %s',
+ $sql = sprintf ('SELECT TOP %u %s %s %s %s',
$rows + ($offset||0),
$in_sel,
$sql,
$order_by_inner,
);
- $sql = sprintf ('SELECT TOP %d %s FROM ( %s ) %s %s',
+ $sql = sprintf ('SELECT TOP %u %s FROM ( %s ) %s %s',
$rows,
$mid_sel,
$sql,
$order_by_reversed,
) if $offset;
- $sql = sprintf ('SELECT TOP %d %s FROM ( %s ) %s %s',
+ $sql = sprintf ('SELECT TOP %u %s FROM ( %s ) %s %s',
$rows,
$out_sel,
$sql,
$order_by_requested,
) if ( ($offset && $order_by_requested) || ($mid_sel ne $out_sel) );
+ $sql =~ s/\s*\n\s*/ /g; # easier to read in the debugger
+ return $sql;
+}
+
+# This is the most evil limit "dialect" (more of a hack) for *really*
+# stupid databases. It works by ordering the set by some unique column,
+# and calculating amount of rows that have a less-er value (thus
+# emulating a RowNum-like index). Of course this implies the set can
+# only be ordered by a single unique columns.
+sub _GenericSubQ {
+ my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
+
+ my $root_rsrc = $rs_attrs->{_rsroot_source_handle}->resolve;
+ my $root_tbl_name = $root_rsrc->name;
+
+ # mangle the input sql as we will be replacing the selector
+ $sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix
+ or croak "Unrecognizable SELECT: $sql";
+
+ my ($order_by, @rest) = do {
+ local $self->{quote_char};
+ $self->_order_by_chunks ($rs_attrs->{order_by})
+ };
+
+ unless (
+ $order_by
+ &&
+ ! @rest
+ &&
+ ( ! ref $order_by
+ ||
+ ( ref $order_by eq 'ARRAY' and @$order_by == 1 )
+ )
+ ) {
+ croak (
+ 'Generic Subquery Limit does not work on resultsets without an order, or resultsets '
+ . 'with complex order criteria (multicolumn and/or functions). Provide a single, '
+ . 'unique-column order criteria.'
+ );
+ }
+
+ ($order_by) = @$order_by if ref $order_by;
+
+ $order_by =~ s/\s+ ( ASC|DESC ) \s* $//ix;
+ my $direction = lc ($1 || 'asc');
+
+ my ($unq_sort_col) = $order_by =~ /(?:^|\.)([^\.]+)$/;
+
+ my $inf = $root_rsrc->storage->_resolve_column_info (
+ $rs_attrs->{from}, [$order_by, $unq_sort_col]
+ );
+
+ my $ord_colinfo = $inf->{$order_by} || croak "Unable to determine source of order-criteria '$order_by'";
+
+ if ($ord_colinfo->{-result_source}->name ne $root_tbl_name) {
+ croak "Generic Subquery Limit order criteria can be only based on the root-source '"
+ . $root_rsrc->source_name . "' (aliased as '$rs_attrs->{alias}')";
+ }
+
+ # make sure order column is qualified
+ $order_by = "$rs_attrs->{alias}.$order_by"
+ unless $order_by =~ /^$rs_attrs->{alias}\./;
+
+ my $is_u;
+ my $ucs = { $root_rsrc->unique_constraints };
+ for (values %$ucs ) {
+ if (@$_ == 1 && "$rs_attrs->{alias}.$_->[0]" eq $order_by) {
+ $is_u++;
+ last;
+ }
+ }
+ croak "Generic Subquery Limit order criteria column '$order_by' must be unique (no unique constraint found)"
+ unless $is_u;
+
+ my ($in_sel, $out_sel, $alias_map, $extra_order_sel)
+ = $self->_subqueried_limit_attrs ($rs_attrs);
+
+ my $cmp_op = $direction eq 'desc' ? '>' : '<';
+ my $count_tbl_alias = 'rownum__emulation';
+
+ my $order_group_having = $self->_parse_rs_attrs($rs_attrs);
+
+ # add the order supplement (if any) as this is what will be used for the outer WHERE
+ $in_sel .= ", $_" for keys %{$extra_order_sel||{}};
+
+ $sql = sprintf (<<EOS,
+SELECT $out_sel
+ FROM (
+ SELECT $in_sel ${sql}${order_group_having}
+ ) %s
+WHERE ( SELECT COUNT(*) FROM %s %s WHERE %s $cmp_op %s ) %s
+EOS
+ ( map { $self->_quote ($_) } (
+ $rs_attrs->{alias},
+ $root_tbl_name,
+ $count_tbl_alias,
+ "$count_tbl_alias.$unq_sort_col",
+ $order_by,
+ )),
+ $offset
+ ? sprintf ('BETWEEN %u AND %u', $offset, $offset + $rows - 1)
+ : sprintf ('< %u', $rows )
+ ,
+ );
+
+ $sql =~ s/\s*\n\s*/ /g; # easier to read in the debugger
return $sql;
}
use DBIx::Class::Exception;
use Carp::Clan qw/^DBIx::Class/;
+use Try::Tiny;
use Scalar::Util ();
use File::Spec;
use Sub::Name ();
use Module::Find();
+use namespace::clean;
use base qw/DBIx::Class/;
If a Result class is found to already have a ResultSet class set using
L</resultset_class> to some other class, you will be warned like this:
- We found ResultSet class '$rs_class' for '$result', but it seems
+ We found ResultSet class '$rs_class' for '$result', but it seems
that you had already set '$result' to use '$rs_set' instead
Both of the sub-namespaces are configurable if you don't like the defaults,
If any classes found do not appear to be Result class files, you will
get the following warning:
- Failed to load $comp_class. Can't find source_name method. Is
+ Failed to load $comp_class. Can't find source_name method. Is
$comp_class really a full DBIC result class? Fix it, move it elsewhere,
or make your load_classes call more specific.
=back
-An optional sub which you can declare in your own Schema class that will get
+An optional sub which you can declare in your own Schema class that will get
passed the L<SQL::Translator::Schema> object when you deploy the schema via
L</create_ddl_dir> or L</deploy>.
-For an example of what you can do with this, see
+For an example of what you can do with this, see
L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
Note that sqlt_deploy_hook is called by L</deployment_statements>, which in turn
=head2 txn_scope_guard
-Runs C<txn_scope_guard> on the schema's storage. See
+Runs C<txn_scope_guard> on the schema's storage. See
L<DBIx::Class::Storage/txn_scope_guard>.
=cut
Pass this method a resultsource name, and an arrayref of
arrayrefs. The arrayrefs should contain a list of column names,
-followed by one or many sets of matching data for the given columns.
+followed by one or many sets of matching data for the given columns.
In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
to insert the data, as this is a fast method. However, insert_bulk currently
...
]);
-Since wantarray context is basically the same as looping over $rs->create(...)
+Since wantarray context is basically the same as looping over $rs->create(...)
you won't see any performance benefits and in this case the method is more for
convenience. Void context sends the column information directly to storage
-using <DBI>s bulk insert method. So the performance will be much better for
+using <DBI>s bulk insert method. So the performance will be much better for
storages that support this method.
-Because of this difference in the way void context inserts rows into your
+Because of this difference in the way void context inserts rows into your
database you need to note how this will effect any loaded components that
-override or augment insert. For example if you are using a component such
-as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use
+override or augment insert. For example if you are using a component such
+as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use
wantarray context if you want the PKs automatically created.
=cut
$rs->populate($data);
}
} else {
- $self->throw_exception("$name is not a resultset");
+ $self->throw_exception("$name is not a resultset");
}
}
my ($self, @info) = @_;
return $self if !@info && $self->storage;
- my ($storage_class, $args) = ref $self->storage_type ?
+ my ($storage_class, $args) = ref $self->storage_type ?
($self->_normalize_storage_type($self->storage_type),{}) : ($self->storage_type, {});
$storage_class = 'DBIx::Class::Storage'.$storage_class
if $storage_class =~ m/^::/;
- eval { $self->ensure_class_loaded ($storage_class) };
- $self->throw_exception(
- "No arguments to load_classes and couldn't load ${storage_class} ($@)"
- ) if $@;
+ try {
+ $self->ensure_class_loaded ($storage_class);
+ }
+ catch {
+ $self->throw_exception(
+ "No arguments to load_classes and couldn't load ${storage_class} ($_)"
+ );
+ };
my $storage = $storage_class->new($self=>$args);
$storage->connect_info(\@info);
$self->storage($storage);
=head2 svp_begin
-Creates a new savepoint (does nothing outside a transaction).
+Creates a new savepoint (does nothing outside a transaction).
Equivalent to calling $schema->storage->svp_begin. See
L<DBIx::Class::Storage/"svp_begin"> for more information.
=head2 svp_release
-Releases a savepoint (does nothing outside a transaction).
+Releases a savepoint (does nothing outside a transaction).
Equivalent to calling $schema->storage->svp_release. See
L<DBIx::Class::Storage/"svp_release"> for more information.
=head2 svp_rollback
-Rollback to a savepoint (does nothing outside a transaction).
+Rollback to a savepoint (does nothing outside a transaction).
Equivalent to calling $schema->storage->svp_rollback. See
L<DBIx::Class::Storage/"svp_rollback"> for more information.
created. For quoting purposes supply C<quote_table_names> and
C<quote_field_names>.
-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
+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
only the sources listed will get deployed. Furthermore, you can use the
C<add_fk_index> parser parameter to prevent the parser from creating an index for each
FK.
=back
-A convenient shortcut to
+A convenient shortcut to
C<< $self->storage->create_ddl_dir($self, @args) >>.
Creates an SQL file based on the Schema, for each of the specified
my $filename = $table->ddl_filename($type, $dir, $version, $preversion)
In recent versions variables $dir and $version were reversed in order to
- bring the signature in line with other Schema/Storage methods. If you
+ bring the signature in line with other Schema/Storage methods. If you
really need to maintain backward compatibility, you can do the following
in any overriding methods:
=head2 thaw
-Provided as the recommended way of thawing schema objects. You can call
+Provided as the recommended way of thawing schema objects. You can call
C<Storable::thaw> directly if you wish, but the thawed objects will not have a
reference to any schema, so are rather useless.
=back
-This method is called by L</load_namespaces> and L</load_classes> to install the found classes into your Schema. You should be using those instead of this one.
+This method is called by L</load_namespaces> and L</load_classes> to install the found classes into your Schema. You should be using those instead of this one.
You will only need this method if you have your Result classes in
files which are not named after the packages (or all in the same
=back
-As L</register_source> but should be used if the result class already
+As L</register_source> but should be used if the result class already
has a source and you want to register an extra one.
=cut
sub _unregister_source {
my ($self, $moniker) = @_;
- my %reg = %{$self->source_registrations};
+ my %reg = %{$self->source_registrations};
my $source = delete $reg{$moniker};
$self->source_registrations(\%reg);
unless ($INC{"DBIx/Class/CDBICompat.pm"} || $warn++);
my $base = 'DBIx::Class::ResultSetProxy';
- eval "require ${base};";
- $self->throw_exception
- ("No arguments to load_classes and couldn't load ${base} ($@)")
- if $@;
+ try {
+ eval "require ${base};"
+ }
+ catch {
+ $self->throw_exception
+ ("No arguments to load_classes and couldn't load ${base} ($_)")
+ };
if ($self eq $target) {
# Pathological case, largely caused by the docs on early C::M::DBIC::Plain
use Carp::Clan qw/^DBIx::Class/;
use Time::HiRes qw/gettimeofday/;
+use Try::Tiny;
+use namespace::clean;
__PACKAGE__->mk_classdata('_filedata');
__PACKAGE__->mk_classdata('upgrade_directory');
# must be called on a fresh database
if ($self->get_db_version()) {
- carp 'Install not possible as versions table already exists in database';
+ $self->throw_exception("A versioned schema has already been deployed, try upgrade instead.\n");
}
# default to current version if none passed
my ($self, $rs) = @_;
my $vtable = $self->{vschema}->resultset('Table');
- my $version = eval {
+ my $version = try {
$vtable->search({}, { order_by => { -desc => 'installed' }, rows => 1 } )
->get_column ('version')
->next;
sub connection {
my $self = shift;
$self->next::method(@_);
- $self->_on_connect($_[3]);
+ $self->_on_connect();
return $self;
}
sub _on_connect
{
- my ($self, $args) = @_;
+ my ($self) = @_;
- $args = {} unless $args;
+ my $conn_info = $self->storage->connect_info;
+ $self->{vschema} = DBIx::Class::Version->connect(@$conn_info);
+ my $conn_attrs = $self->{vschema}->storage->_dbic_connect_attributes || {};
- $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
my $vtable = $self->{vschema}->resultset('Table');
# useful when connecting from scripts etc
- return if ($args->{ignore_version} || ($ENV{DBIC_NO_VERSION_CHECK} && !exists $args->{ignore_version}));
+ return if ($conn_attrs->{ignore_version} || ($ENV{DBIC_NO_VERSION_CHECK} && !exists $conn_attrs->{ignore_version}));
# check for legacy versions table and move to new if exists
- my $vschema_compat = DBIx::Class::VersionCompat->connect(@{$self->storage->connect_info()});
+ my $vschema_compat = DBIx::Class::VersionCompat->connect(@$conn_info);
unless ($self->_source_exists($vtable)) {
my $vtable_compat = $vschema_compat->resultset('TableCompat');
if ($self->_source_exists($vtable_compat)) {
$self->{vschema}->deploy;
map { $vtable->create({ installed => $_->Installed, version => $_->Version }) } $vtable_compat->all;
- $self->storage->dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
+ $self->storage->_get_dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
}
}
# This is necessary since there are legitimate cases when upgrades can happen
# back to back within the same second. This breaks things since we relay on the
# ability to sort by the 'installed' value. The logical choice of an autoinc
- # is not possible, as it will break multiple legacy installations. Also it is
+ # is not possible, as it will break multiple legacy installations. Also it is
# not possible to format the string sanely, as the column is a varchar(20).
# The 'v' character is added to the front of the string, so that any version
# formatted by this new function will sort _after_ any existing 200... strings.
my @tm = gettimeofday();
my @dt = gmtime ($tm[0]);
- my $o = $vtable->create({
+ my $o = $vtable->create({
version => $version,
installed => sprintf("v%04d%02d%02d_%02d%02d%02d.%03.0f",
$dt[5] + 1900,
{
my ($self, $rs) = @_;
- my $c = eval {
- $rs->search({ 1, 0 })->count;
- };
- return 0 if $@ || !defined $c;
+ my $c = try { $rs->search({ 1, 0 })->count };
- return 1;
+ return (defined $c) ? 1 : 0;
}
1;
use Scalar::Util();
use IO::File;
use DBIx::Class::Storage::TxnScopeGuard;
+use Try::Tiny;
+use namespace::clean;
__PACKAGE__->mk_group_accessors('simple' => qw/debug debugobj schema/);
__PACKAGE__->mk_group_accessors('inherited' => 'cursor_class');
};
my $rs;
- eval {
+ try {
$rs = $schema->txn_do($coderef);
- };
-
- if ($@) { # Transaction failed
+ } catch {
+ my $error = shift;
+ # Transaction failed
die "something terrible has happened!" #
- if ($@ =~ /Rollback failed/); # Rollback failed
+ if ($error =~ /Rollback failed/); # Rollback failed
deal_with_failed_transaction();
- }
+ };
In a nested transaction (calling txn_do() from within a txn_do() coderef) only
the outermost transaction will issue a L</txn_commit>, and txn_do() can be
$self->txn_begin; # If this throws an exception, no rollback is needed
my $wantarray = wantarray; # Need to save this since the context
- # inside the eval{} block is independent
+ # inside the try{} block is independent
# of the context that called txn_do()
- eval {
+ try {
# Need to differentiate between scalar/list context to allow for
# returning a list in scalar context to get the size of the list
$coderef->(@args);
}
$self->txn_commit;
- };
-
- if ($@) {
- my $error = $@;
+ }
+ catch {
+ my $error = shift;
- eval {
+ try {
$self->txn_rollback;
- };
-
- if ($@) {
- my $rollback_error = $@;
+ } catch {
my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
$self->throw_exception($error) # propagate nested rollback
- if $rollback_error =~ /$exception_class/;
+ if $_ =~ /$exception_class/;
$self->throw_exception(
- "Transaction aborted: $error. Rollback failed: ${rollback_error}"
+ "Transaction aborted: $error. Rollback failed: $_"
);
- } else {
- $self->throw_exception($error); # txn failed but rollback succeeded
}
- }
+ $self->throw_exception($error); # txn failed but rollback succeeded
+ };
return $wantarray ? @return_values : $return_value;
}
written to the file C</path/name>.
This environment variable is checked when the storage object is first
-created (when you call connect on your schema). So, run-time changes
-to this environment variable will not take effect unless you also
+created (when you call connect on your schema). So, run-time changes
+to this environment variable will not take effect unless you also
re-connect on your schema.
=head2 DBIX_CLASS_STORAGE_DBI_DEBUG
use List::Util();
use Data::Dumper::Concise();
use Sub::Name ();
-
+use Try::Tiny;
use File::Path ();
+use namespace::clean;
-__PACKAGE__->mk_group_accessors('simple' =>
- qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid
- _conn_tid transaction_depth _dbh_autocommit _driver_determined savepoints
- _server_info_hash/
-);
+__PACKAGE__->mk_group_accessors('simple' => qw/
+ _connect_info _dbi_connect_info _dbic_connect_attributes _driver_determined
+ _dbh _server_info_hash _conn_pid _conn_tid _sql_maker _sql_maker_opts
+ transaction_depth _dbh_autocommit savepoints
+/);
# the values for these accessors are picked out (and deleted) from
# the attribute hashref passed to connect_info
my @rdbms_specific_methods = qw/
deployment_statements
sqlt_type
+ sql_maker
build_datetime_parser
datetime_parser_type
# some databases need this to stop spewing warnings
if (my $dbh = $self->_dbh) {
- local $@;
- eval {
+ try {
%{ $dbh->{CachedKids} } = ();
$dbh->disconnect;
};
$self->_dbi_connect_info([@args,
%attrs && !(ref $args[0] eq 'CODE') ? \%attrs : ()]);
+ # FIXME - dirty:
+ # save attributes them in a separate accessor so they are always
+ # introspectable, even in case of a CODE $dbhmaker
+ $self->_dbic_connect_attributes (\%attrs);
+
return $self->_connect_info;
}
my $dbh = $self->_get_dbh;
- return $self->$code($dbh, @_) if $self->{_in_dbh_do}
- || $self->{transaction_depth};
+ return $self->$code($dbh, @_)
+ if ( $self->{_in_dbh_do} || $self->{transaction_depth} );
local $self->{_in_dbh_do} = 1;
- my @result;
- my $want_array = wantarray;
+ my @args = @_;
+ return try {
+ $self->$code ($dbh, @args);
+ } catch {
+ $self->throw_exception($_) if $self->connected;
- eval {
+ # We were not connected - reconnect and retry, but let any
+ # exception fall right through this time
+ carp "Retrying $code after catching disconnected exception: $_"
+ if $ENV{DBIC_DBIRETRY_DEBUG};
- if($want_array) {
- @result = $self->$code($dbh, @_);
- }
- elsif(defined $want_array) {
- $result[0] = $self->$code($dbh, @_);
- }
- else {
- $self->$code($dbh, @_);
- }
+ $self->_populate_dbh;
+ $self->$code($self->_dbh, @args);
};
-
- # ->connected might unset $@ - copy
- my $exception = $@;
- if(!$exception) { return $want_array ? @result : $result[0] }
-
- $self->throw_exception($exception) if $self->connected;
-
- # We were not connected - reconnect and retry, but let any
- # exception fall right through this time
- carp "Retrying $code after catching disconnected exception: $exception"
- if $ENV{DBIC_DBIRETRY_DEBUG};
- $self->_populate_dbh;
- $self->$code($self->_dbh, @_);
}
# This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
my $tried = 0;
while(1) {
- eval {
+ my $exception;
+ my @args = @_;
+ try {
$self->_get_dbh;
$self->txn_begin;
if($want_array) {
- @result = $coderef->(@_);
+ @result = $coderef->(@args);
}
elsif(defined $want_array) {
- $result[0] = $coderef->(@_);
+ $result[0] = $coderef->(@args);
}
else {
- $coderef->(@_);
+ $coderef->(@args);
}
$self->txn_commit;
+ } catch {
+ $exception = $_;
};
- # ->connected might unset $@ - copy
- my $exception = $@;
- if(!$exception) { return $want_array ? @result : $result[0] }
+ if(! defined $exception) { return $want_array ? @result : $result[0] }
if($tried++ || $self->connected) {
- eval { $self->txn_rollback };
- my $rollback_exception = $@;
- if($rollback_exception) {
+ my $rollback_exception;
+ try { $self->txn_rollback } catch { $rollback_exception = shift };
+ if(defined $rollback_exception) {
my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
$self->throw_exception($exception) # propagate nested rollback
if $rollback_exception =~ /$exception_class/;
my %info;
- my $server_version = do {
- local $@; # might be happenin in some sort of destructor
- eval { $self->_get_server_version };
- };
+ my $server_version = try { $self->_get_server_version };
if (defined $server_version) {
$info{dbms_version} = $server_version;
$DBI::connect_via = 'connect';
}
- eval {
+ try {
if(ref $info[0] eq 'CODE') {
$dbh = $info[0]->();
}
$dbh = DBI->connect(@info);
}
- if($dbh && !$self->unsafe) {
+ if (!$dbh) {
+ die $DBI::errstr;
+ }
+
+ unless ($self->unsafe) {
my $weak_self = $self;
Scalar::Util::weaken($weak_self);
$dbh->{HandleError} = sub {
$dbh->{RaiseError} = 1;
$dbh->{PrintError} = 0;
}
+ }
+ catch {
+ $self->throw_exception("DBI Connection failed: $_")
+ }
+ finally {
+ $DBI::connect_via = $old_connect_via if $old_connect_via;
};
- $DBI::connect_via = $old_connect_via if $old_connect_via;
-
- $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
- if !$dbh || $@;
-
$self->_dbh_autocommit($dbh->{AutoCommit});
-
$dbh;
}
sub txn_rollback {
my $self = shift;
my $dbh = $self->_dbh;
- eval {
+ try {
if ($self->{transaction_depth} == 1) {
$self->debugobj->txn_rollback()
if ($self->debug);
else {
die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
}
- };
- if ($@) {
- my $error = $@;
- my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
- $error =~ /$exception_class/ and $self->throw_exception($error);
- # ensure that a failed rollback resets the transaction depth
- $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
- $self->throw_exception($error);
}
+ catch {
+ my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
+
+ if ($_ !~ /$exception_class/) {
+ # ensure that a failed rollback resets the transaction depth
+ $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
+ }
+
+ $self->throw_exception($_)
+ };
}
sub _dbh_rollback {
# Can this fail without throwing an exception anyways???
my $rv = $sth->execute();
- $self->throw_exception($sth->errstr) if !$rv;
+ $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 );
if ($opts->{returning}) {
my @ret_cols = @{$opts->{returning}};
- my @ret_vals = eval {
+ my @ret_vals = try {
local $SIG{__WARN__} = sub {};
my @r = $sth->fetchrow_array;
$sth->finish;
$placeholder_index++;
}
- my $rv = eval {
- $self->_dbh_execute_array($sth, $tuple_status, @extra);
+ my ($rv, $err);
+ try {
+ $rv = $self->_dbh_execute_array($sth, $tuple_status, @extra);
+ }
+ catch {
+ $err = shift;
+ }
+ finally {
+ # Statement must finish even if there was an exception.
+ try {
+ $sth->finish
+ }
+ catch {
+ $err = shift unless defined $err
+ };
};
- my $err = $@ || $sth->errstr;
-# Statement must finish even if there was an exception.
- eval { $sth->finish };
- $err = $@ unless $err;
+ $err = $sth->errstr
+ if (! defined $err and $sth->err);
- if ($err) {
+ if (defined $err) {
my $i = 0;
++$i while $i <= $#$tuple_status && !ref $tuple_status->[$i];
}),
);
}
+
return $rv;
}
sub _dbh_execute_inserts_with_no_binds {
my ($self, $sth, $count) = @_;
- eval {
+ my $err;
+ try {
my $dbh = $self->_get_dbh;
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
$sth->execute foreach 1..$count;
+ }
+ catch {
+ $err = shift;
+ }
+ finally {
+ # Make sure statement is finished even if there was an exception.
+ try {
+ $sth->finish
+ }
+ catch {
+ $err = shift unless defined $err;
+ };
};
- my $exception = $@;
-
-# Make sure statement is finished even if there was an exception.
- eval { $sth->finish };
- $exception = $@ unless $exception;
- $self->throw_exception($exception) if $exception;
+ $self->throw_exception($err) if defined $err;
return $count;
}
}
# adjust limits
- if (
- $attrs->{software_limit}
- ||
- $sql_maker->_default_limit_syntax eq "GenericSubQ"
- ) {
- $attrs->{software_limit} = 1;
- }
- else {
+ if (defined $attrs->{rows}) {
$self->throw_exception("rows attribute must be positive if present")
- if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
-
+ unless $attrs->{rows} > 0;
+ }
+ elsif (defined $attrs->{offset}) {
# MySQL actually recommends this approach. I cringe.
- $attrs->{rows} = 2**48 if not defined $attrs->{rows} and defined $attrs->{offset};
+ $attrs->{rows} = 2**32;
}
my @limit;
if ($dbh->can('column_info')) {
my %result;
- eval {
+ my $caught;
+ try {
my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
$sth->execute();
$result{$col_name} = \%column_info;
}
+ } catch {
+ $caught = 1;
};
- return \%result if !$@ && scalar keys %result;
+ return \%result if !$caught && scalar keys %result;
}
my %result;
sub _dbh_last_insert_id {
my ($self, $dbh, $source, $col) = @_;
- my $id = eval { $dbh->last_insert_id (undef, undef, $source->name, $col) };
+ my $id = try { $dbh->last_insert_id (undef, undef, $source->name, $col) };
return $id if defined $id;
# some drivers provide a $dbh attribute (e.g. Sybase and $dbh->{syb_dynamic_supported})
# but it is inaccurate more often than not
- eval {
+ return try {
local $dbh->{PrintError} = 0;
local $dbh->{RaiseError} = 1;
$dbh->do('select ?', {}, 1);
+ 1;
+ }
+ catch {
+ 0;
};
- return $@ ? 0 : 1;
}
# Check if placeholders bound to non-string types throw exceptions
my $self = shift;
my $dbh = $self->_get_dbh;
- eval {
+ return try {
local $dbh->{PrintError} = 0;
local $dbh->{RaiseError} = 1;
# this specifically tests a bind that is NOT a string
$dbh->do('select 1 where 1 = ?', {}, 1);
+ 1;
+ }
+ catch {
+ 0;
};
- return $@ ? 0 : 1;
}
=head2 sqlt_type
return if($line =~ /^COMMIT/m);
return if $line =~ /^\s+$/; # skip whitespace only
$self->_query_start($line);
- eval {
+ try {
# do a dbh_do cycle here, as we need some error checking in
# place (even though we will ignore errors)
$self->dbh_do (sub { $_[1]->do($line) });
+ } catch {
+ carp qq{$_ (running "${line}")};
};
- if ($@) {
- carp qq{$@ (running "${line}")};
- }
$self->_query_end($line);
};
my @statements = $schema->deployment_statements($type, undef, $dir, { %{ $sqltargs || {} }, no_comments => 1 } );
DBIx::Class::Storage::DBI::ADO;
use base 'DBIx::Class::Storage::DBI';
+use Try::Tiny;
+use namespace::clean;
sub _rebless {
my $self = shift;
# XXX This should be using an OpenSchema method of some sort, but I don't know
# how.
# Current version is stolen from Sybase.pm
- my $dbtype = eval {
- @{$self->_get_dbh
+ try {
+ my $dbtype = @{$self->_get_dbh
->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})
- }[2]
- };
+ }[2];
- unless ($@) {
$dbtype =~ s/\W/_/gi;
my $subclass = "DBIx::Class::Storage::DBI::ADO::${dbtype}";
if ($self->load_optional_class($subclass) && !$self->isa($subclass)) {
bless $self, $subclass;
$self->_rebless;
}
- }
+ };
}
# Here I was just experimenting with ADO cursor types, left in as a comment in
use base qw/DBIx::Class::Cursor/;
+use Try::Tiny;
+use namespace::clean;
+
__PACKAGE__->mk_group_accessors('simple' =>
qw/sth/
);
my ($self) = @_;
# No need to care about failures here
- eval { $self->sth->finish if $self->sth && $self->sth->{Active} };
+ try { $self->sth->finish }
+ if $self->sth && $self->sth->{Active};
$self->_soft_reset;
return undef;
}
my ($self) = @_;
# None of the reasons this would die matter if we're in DESTROY anyways
- local $@;
- eval { $self->sth->finish if $self->sth && $self->sth->{Active} };
+ try { $self->sth->finish }
+ if $self->sth && $self->sth->{Active};
}
1;
use base qw/DBIx::Class::Storage::DBI/;
use mro 'c3';
use List::Util();
+use Try::Tiny;
+use namespace::clean;
=head1 NAME
}
$self->throw_exception('No sequence to fetch') unless $sequence;
-
+
my ($val) = $self->_get_dbh->selectrow_array(
'SELECT GEN_ID(' . $self->sql_maker->_quote($sequence) .
', 1) FROM rdb$database');
return $val;
-}
+}
sub _dbh_get_autoinc_seq {
my ($self, $dbh, $source, $col) = @_;
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
- eval {
+ return try {
$dbh->do('select 1 from rdb$database');
+ 1;
+ } catch {
+ 0;
};
-
- return $@ ? 0 : 1;
}
# We want dialect 3 for new features and quoting to work, DBD::InterBase uses
use base qw/DBIx::Class::Storage::DBI::UniqueIdentifier/;
use mro 'c3';
+use Try::Tiny;
+use namespace::clean;
use List::Util();
);
my $dbh = $self->_get_dbh;
- eval { $dbh->do ($sql) };
- if ($@) {
+ try { $dbh->do ($sql) }
+ catch {
$self->throw_exception (sprintf "Error executing '%s': %s",
$sql,
$dbh->errstr,
);
- }
+ };
}
sub _unset_identity_insert {
# this should bring back the result of SELECT SCOPE_IDENTITY() we tacked
# on in _prep_for_execute above
- my ($identity) = eval { $sth->fetchrow_array };
+ my ($identity) = try { $sth->fetchrow_array };
# SCOPE_IDENTITY failed, but we can do something else
if ( (! $identity) && $self->_identity_method) {
if (
$sql !~ /^ \s* SELECT \s+ TOP \s+ \d+ \s+ /xi
&&
- scalar $self->_parse_order_by ($attrs->{order_by})
+ scalar $self->_parse_order_by ($attrs->{order_by})
) {
$self->throw_exception(
'An ordered subselect encountered - this is not safe! Please see "Ordered Subselects" in DBIx::Class::Storage::DBI::MSSQL
sub datetime_parser_type {
'DBIx::Class::Storage::DBI::MSSQL::DateTime::Format'
-}
+}
sub sqlt_type { 'SQLServer' }
# stored procedures like xp_msver, or version detection failed for some
# other reason.
# So, we use a query to check if RNO is implemented.
- $have_rno = 1 if (eval { local $@; ($self->_get_dbh
- ->selectrow_array('SELECT row_number() OVER (ORDER BY rand())')
- )[0] });
+ try {
+ $self->_get_dbh->selectrow_array('SELECT row_number() OVER (ORDER BY rand())');
+ $have_rno = 1;
+ };
}
$self->{_sql_maker_opts} = {
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
- eval {
+ return try {
$dbh->do('select 1');
+ 1;
+ } catch {
+ 0;
};
-
- return $@ ? 0 : 1;
}
package # hide from PAUSE
DBIx::Class::Storage::DBI::MSSQL::DateTime::Format;
-my $datetime_format = '%Y-%m-%d %H:%M:%S.%3N'; # %F %T
+my $datetime_format = '%Y-%m-%d %H:%M:%S.%3N'; # %F %T
my $smalldatetime_format = '%Y-%m-%d %H:%M:%S';
my ($datetime_parser, $smalldatetime_parser);
use base qw/DBIx::Class::Storage::DBI/;
use mro 'c3';
+use Try::Tiny;
+use namespace::clean;
sub _rebless {
- my ($self) = @_;
-
- my $dbtype = eval { $self->_get_dbh->get_info(17) };
-
- unless ( $@ ) {
- # Translate the backend name into a perl identifier
- $dbtype =~ s/\W/_/gi;
- my $subclass = "DBIx::Class::Storage::DBI::ODBC::${dbtype}";
- if ($self->load_optional_class($subclass) && !$self->isa($subclass)) {
- bless $self, $subclass;
- $self->_rebless;
- }
+ my ($self) = @_;
+
+ try {
+ my $dbtype = $self->_get_dbh->get_info(17);
+
+ # Translate the backend name into a perl identifier
+ $dbtype =~ s/\W/_/gi;
+ my $subclass = "DBIx::Class::Storage::DBI::ODBC::${dbtype}";
+
+ if ($self->load_optional_class($subclass) && !$self->isa($subclass)) {
+ bless $self, $subclass;
+ $self->_rebless;
}
+ };
}
1;
use List::Util();
use Scalar::Util ();
+use Try::Tiny;
+use namespace::clean;
__PACKAGE__->mk_group_accessors(simple => qw/
_using_dynamic_cursors
my $self = shift;
my $dbh = $self->_get_dbh;
- eval {
+ try {
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
$dbh->do('SELECT @@IDENTITY');
- };
- if ($@) {
+ } catch {
$self->throw_exception (<<'EOF');
Your drivers do not seem to support dynamic cursors (odbc_cursortype => 2),
if you're using FreeTDS, make sure to set tds_version to 8.0 or greater.
EOF
- }
+ };
$self->_using_dynamic_cursors(1);
$self->_identity_method('@@identity');
use base qw/DBIx::Class::Storage::DBI/;
use mro 'c3';
+use Try::Tiny;
+use namespace::clean;
sub _rebless {
my ($self) = @_;
- my $version = eval { $self->_get_dbh->get_info(18); };
+ try {
+ my $version = $self->_get_dbh->get_info(18);
- if ( !$@ ) {
- my ($major, $minor, $patchlevel) = split(/\./, $version);
+ my ($major, $minor, $patchlevel) = split(/\./, $version);
- # Default driver
- my $class = $major <= 8
- ? 'DBIx::Class::Storage::DBI::Oracle::WhereJoins'
- : 'DBIx::Class::Storage::DBI::Oracle::Generic';
+ # Default driver
+ my $class = $major <= 8
+ ? 'DBIx::Class::Storage::DBI::Oracle::WhereJoins'
+ : 'DBIx::Class::Storage::DBI::Oracle::Generic';
- $self->ensure_class_loaded ($class);
- bless $self, $class;
- }
+ $self->ensure_class_loaded ($class);
+ bless $self, $class;
+ };
}
1;
use warnings;
use Scope::Guard ();
use Context::Preserve ();
+use Try::Tiny;
+use namespace::clean;
=head1 NAME
$sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
$sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
- my $oracle_version = eval { $self->_get_dbh->get_info(18) };
+ my $oracle_version = try { $self->_get_dbh->get_info(18) };
$sqltargs->{producer_args}{oracle_version} = $oracle_version;
{
$schema ? (owner => $schema) : (),
table_name => $table || $source_name,
- triggering_event => 'INSERT',
+ triggering_event => { -like => '%INSERT%' },
status => 'ENABLED',
},
);
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
- eval {
+ return try {
$dbh->do('select 1 from dual');
+ 1;
+ } catch {
+ 0;
};
-
- return $@ ? 0 : 1;
}
sub _dbh_execute {
my $self = shift;
my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
- my $wantarray = wantarray;
-
- my (@res, $exception, $retried);
-
- RETRY: {
- do {
- eval {
- if ($wantarray) {
- @res = $self->next::method(@_);
- } else {
- $res[0] = $self->next::method(@_);
- }
- };
- $exception = $@;
- if ($exception =~ /ORA-01003/) {
+ my (@res, $tried);
+ my $wantarray = wantarray();
+ my $next = $self->next::can;
+ do {
+ try {
+ my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
+
+ if (!defined $wantarray) {
+ $exec->();
+ }
+ elsif (! $wantarray) {
+ $res[0] = $exec->();
+ }
+ else {
+ @res = $exec->();
+ }
+
+ $tried++;
+ }
+ catch {
+ if (! $tried and $_ =~ /ORA-01003/) {
# ORA-01003: no statement parsed (someone changed the table somehow,
# invalidating your cursor.)
my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
delete $dbh->{CachedKids}{$sql};
- } else {
- last RETRY;
}
- } while (not $retried++);
- }
-
- $self->throw_exception($exception) if $exception;
+ else {
+ $self->throw_exception($_);
+ }
+ };
+ } while (! $tried++);
- $wantarray ? @res : $res[0]
+ return $wantarray ? @res : $res[0];
}
=head2 get_autoinc_seq
$self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
}
-=head2 columns_info_for
-
-This wraps the superclass version of this method to force table
-names to uppercase
-
-=cut
-
-sub columns_info_for {
- my ($self, $table) = @_;
-
- $self->next::method($table);
-}
-
=head2 datetime_parser_type
This sets the proper DateTime::Format module for use with
use Scalar::Util 'reftype';
use Hash::Merge;
use List::Util qw/min max reduce/;
+use Try::Tiny;
+use namespace::clean;
use namespace::clean -except => 'meta';
$schema->storage_type( ['::DBI::Replicated', {balancer=>'::Random'}] );
$schema->connection(...);
-Next, you need to add in the Replicants. Basically this is an array of
+Next, you need to add in the Replicants. Basically this is an array of
arrayrefs, where each arrayref is database connect information. Think of these
arguments as what you'd pass to the 'normal' $schema->connect method.
my $RS = $schema->resultset('Source')->search(undef, {force_pool=>'master'});
Now $RS will force everything (both reads and writes) to use whatever was setup
-as the master storage. 'master' is hardcoded to always point to the Master,
+as the master storage. 'master' is hardcoded to always point to the Master,
but you can also use any Replicant name. Please see:
L<DBIx::Class::Storage::DBI::Replicated::Pool> and the replicants attribute for more.
=head2 pool_type
-Contains the classname which will instantiate the L</pool> object. Defaults
+Contains the classname which will instantiate the L</pool> object. Defaults
to: L<DBIx::Class::Storage::DBI::Replicated::Pool>.
=cut
=head2 balancer
-Is a <DBIx::Class::Storage::DBI::Replicated::Balancer> or derived class. This
+Is a <DBIx::Class::Storage::DBI::Replicated::Balancer> or derived class. This
is a class that takes a pool (<DBIx::Class::Storage::DBI::Replicated::Pool>)
=cut
=head1 ATTRIBUTES IMPLEMENTING THE DBIx::Storage::DBI INTERFACE
-The following methods are delegated all the methods required for the
+The following methods are delegated all the methods required for the
L<DBIx::Class::Storage::DBI> interface.
=head2 read_handler
select
select_single
columns_info_for
- _dbh_columns_info_for
+ _dbh_columns_info_for
_select
/],
);
_fix_bind_params
_default_dbi_connect_attributes
_dbi_connect_info
+ _dbic_connect_attributes
auto_savepoint
_sqlt_version_ok
_query_end
=cut
sub BUILDARGS {
- my ($class, $schema, $storage_type_args, @args) = @_;
+ my ($class, $schema, $storage_type_args, @args) = @_;
return {
schema=>$schema,
my $reliably = sub {
my $name = shift @_;
$schema->resultset('User')->create({name=>$name});
- my $user_rs = $schema->resultset('User')->find({name=>$name});
+ my $user_rs = $schema->resultset('User')->find({name=>$name});
return $user_rs;
};
my @result;
my $want_array = wantarray;
- eval {
+ try {
if($want_array) {
@result = $coderef->(@args);
} elsif(defined $want_array) {
} else {
$coderef->(@args);
}
+ } catch {
+ $self->throw_exception("coderef returned an error: $_");
+ } finally {
+ ##Reset to the original state
+ $self->read_handler($current);
};
- ##Reset to the original state
- $self->read_handler($current);
-
- ##Exception testing has to come last, otherwise you might leave the
- ##read_handler set to master.
-
- if($@) {
- $self->throw_exception("coderef returned an error: $@");
- } else {
- return $want_array ? @result : $result[0];
- }
+ return $want_array ? @result : $result[0];
}
=head2 set_reliable_storage
my $self = shift;
return max map $_->lag_behind_master, $self->replicants;
-}
+}
=head2 is_replicating
sub _driver_determined {
my $self = shift;
-
+
if (@_) {
$_->_driver_determined(@_) for $self->all_storages;
}
sub _init {
my $self = shift;
-
+
$_->_init for $self->all_storages;
}
sub _run_connection_actions {
my $self = shift;
-
+
$_->_run_connection_actions for $self->all_storages;
}
sub _do_connection_actions {
my $self = shift;
-
+
if (@_) {
$_->_do_connection_actions(@_) for $self->all_storages;
}
if (not $self->_server_info_hash) {
my $min_version_info = (
- reduce { $a->[0] < $b->[0] ? $a : $b }
+ reduce { $a->[0] < $b->[0] ? $a : $b }
map [ $numify_ver->($_->{dbms_version}), $_ ],
map $_->_server_info, $self->all_storages
)->[1];
use Carp::Clan qw/^DBIx::Class/;
use MooseX::Types::Moose qw/Num Int ClassName HashRef/;
use DBIx::Class::Storage::DBI::Replicated::Types 'DBICStorageDBI';
+use Try::Tiny;
use namespace::clean -except => 'meta';
sub _safely {
my ($self, $replicant, $name, $code) = @_;
- eval {
- $code->()
- };
- if ($@) {
+ return try {
+ $code->();
+ 1;
+ } catch {
$replicant->debugobj->print(sprintf(
"Exception trying to $name for replicant %s, error is %s",
- $replicant->_dbi_connect_info->[0], $@)
+ $replicant->_dbi_connect_info->[0], $_)
);
- return undef;
- }
-
- return 1;
+ undef;
+ };
}
=head2 connected_replicants
use Scalar::Util 'reftype';
requires qw/_query_start/;
+use Try::Tiny;
use namespace::clean -except => 'meta';
=head1 NAME
around '_query_start' => sub {
my ($method, $self, $sql, @bind) = @_;
- my $dsn = eval { $self->dsn } || $self->_dbi_connect_info->[0];
+ my $dsn = (try { $self->dsn }) || $self->_dbi_connect_info->[0];
my($op, $rest) = (($sql=~m/^(\w+)(.+)$/),'NOP', 'NO SQL');
my $storage_type = $self->can('active') ? 'REPLICANT' : 'MASTER';
if ((reftype($dsn)||'') ne 'CODE') {
"$op [DSN_$storage_type=$dsn]$rest";
}
- elsif (my $id = eval { $self->id }) {
+ elsif (my $id = try { $self->id }) {
"$op [$storage_type=$id]$rest";
}
else {
use base qw/DBIx::Class::Storage::DBI::UniqueIdentifier/;
use mro 'c3';
use List::Util ();
+use Try::Tiny;
+use namespace::clean;
__PACKAGE__->mk_group_accessors(simple => qw/
_identity
my ($source, $to_insert) = @_;
my $identity_col = List::Util::first {
- $source->column_info($_)->{is_auto_increment}
+ $source->column_info($_)->{is_auto_increment}
} $source->columns;
# user might have an identity PK without is_auto_increment
my $table_name = $source->from;
$table_name = $$table_name if ref $table_name;
- my ($identity) = eval {
- local $@; $dbh->selectrow_array("SELECT GET_IDENTITY('$table_name')")
+ my ($identity) = try {
+ $dbh->selectrow_array("SELECT GET_IDENTITY('$table_name')")
};
if (defined $identity) {
sub build_datetime_parser {
my $self = shift;
my $type = "DateTime::Format::Strptime";
- eval "use ${type}";
- $self->throw_exception("Couldn't load ${type}: $@") if $@;
+ try {
+ eval "require ${type}"
+ }
+ catch {
+ $self->throw_exception("Couldn't load ${type}: $_");
+ };
+
return $type->new( pattern => '%Y-%m-%d %H:%M:%S.%6N' );
}
use strict;
use warnings;
+use Try::Tiny;
+use namespace::clean;
use base qw/DBIx::Class::Storage::DBI/;
sub _rebless {
my $self = shift;
- my $dbtype = eval {
- @{$self->_get_dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
+ my $dbtype;
+ try {
+ $dbtype = @{$self->_get_dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
+ } catch {
+ $self->throw_exception("Unable to estable connection to determine database type: $_")
};
- $self->throw_exception("Unable to estable connection to determine database type: $@")
- if $@;
-
if ($dbtype) {
$dbtype =~ s/\W/_/gi;
if ($dbh->{syb_no_child_con}) {
# if extra connections are not allowed, then ->ping is reliable
- my $ping = eval { $dbh->ping };
- return $@ ? 0 : $ping;
+ return try { $dbh->ping } catch { 0; };
}
- eval {
+ return try {
# XXX if the main connection goes stale, does opening another for this statement
# really determine anything?
$dbh->do('select 1');
+ 1;
+ } catch {
+ 0;
};
-
- return $@ ? 0 : 1;
}
sub _set_max_connect {
sub set_textsize {
my $self = shift;
- my $text_size = shift ||
- eval { $self->_dbi_connect_info->[-1]->{LongReadLen} } ||
+ my $text_size =
+ shift
+ ||
+ try { $self->_dbi_connect_info->[-1]->{LongReadLen} }
+ ||
32768; # the DBD::Sybase default
return unless defined $text_size;
use List::Util();
use Sub::Name();
use Data::Dumper::Concise();
+use Try::Tiny;
+use namespace::clean;
__PACKAGE__->mk_group_accessors('simple' =>
qw/_identity _blob_log_on_update _writer_storage _is_extra_storage
return 0;
});
- eval {
+ my $exception;
+ try {
my $bulk = $self->_bulk_storage;
my $guard = $bulk->txn_scope_guard;
);
$bulk->_query_end($sql);
+ } catch {
+ $exception = shift;
};
- my $exception = $@;
DBD::Sybase::set_cslib_cb($orig_cslib_cb);
if ($exception =~ /-Y option/) {
sub _update_blobs {
my ($self, $source, $blob_cols, $where) = @_;
- my @primary_cols = eval { $source->_pri_cols };
- $self->throw_exception("Cannot update TEXT/IMAGE column(s): $@")
- if $@;
+ my @primary_cols = try
+ { $source->_pri_cols }
+ catch {
+ $self->throw_exception("Cannot update TEXT/IMAGE column(s): $_")
+ };
# check if we're updating a single row by PK
my $pk_cols_in_where = 0;
my $table = $source->name;
my %row = %$row;
- my @primary_cols = eval { $source->_pri_cols} ;
- $self->throw_exception("Cannot update TEXT/IMAGE column(s): $@")
- if $@;
+ my @primary_cols = try
+ { $source->_pri_cols }
+ catch {
+ $self->throw_exception("Cannot update TEXT/IMAGE column(s): $_")
+ };
$self->throw_exception('Cannot update TEXT/IMAGE column(s) without primary key values')
if ((grep { defined $row{$_} } @primary_cols) != @primary_cols);
my $sth = $cursor->sth;
if (not $sth) {
-
$self->throw_exception(
"Could not find row in table '$table' for blob update:\n"
. Data::Dumper::Concise::Dumper (\%where)
);
}
- eval {
+ try {
do {
$sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
} while $sth->fetch;
$sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
$sth->func('ct_finish_send') or die $sth->errstr;
- };
- my $exception = $@;
- $sth->finish if $sth;
- if ($exception) {
+ }
+ catch {
if ($self->using_freetds) {
$self->throw_exception (
- 'TEXT/IMAGE operation failed, probably because you are using FreeTDS: '
- . $exception
+ "TEXT/IMAGE operation failed, probably because you are using FreeTDS: $_"
);
- } else {
- $self->throw_exception($exception);
+ }
+ else {
+ $self->throw_exception($_);
}
}
+ finally {
+ $sth->finish if $sth;
+ };
}
}
sub _get_server_version {
my $self = shift;
- my $product_version = $self->_get_dbh->selectrow_hashref('xp_msver ProductVersion');
+ my $product_version = $self->_get_dbh->selectrow_hashref('master.dbo.xp_msver ProductVersion');
if ((my $version = $product_version->{Character_Value}) =~ /^(\d+)\./) {
return $version;
use strict;
use warnings;
use Carp::Clan qw/^DBIx::Class/;
+use Try::Tiny;
+use namespace::clean;
sub new {
my ($class, $storage) = @_;
carp 'A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back.'
unless $exception;
- eval { $storage->txn_rollback };
- my $rollback_exception = $@;
+ my $rollback_exception;
+ try { $storage->txn_rollback }
+ catch { $rollback_exception = shift };
- if ($rollback_exception && $rollback_exception !~ /DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION/) {
+ if (defined $rollback_exception && $rollback_exception !~ /DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION/) {
if ($exception) {
$exception = "Transaction aborted: ${exception} "
."Rollback failed: ${rollback_exception}";
=head1 DESCRIPTION
An object that behaves much like L<Scope::Guard>, but hardcoded to do the
-right thing with transactions in DBIx::Class.
+right thing with transactions in DBIx::Class.
=head1 METHODS
use Exporter;
use SQL::Translator::Utils qw(debug normalize_name);
-use Carp::Clan qw/^SQL::Translator|^DBIx::Class/;
+use Carp::Clan qw/^SQL::Translator|^DBIx::Class|^Try::Tiny/;
use Scalar::Util ();
+use Try::Tiny;
+use namespace::clean;
use base qw(Exporter);
croak 'No DBIx::Class::Schema' unless ($dbicschema);
if (!ref $dbicschema) {
- eval "use $dbicschema;";
- croak "Can't load $dbicschema ($@)" if($@);
+ try {
+ eval "require $dbicschema;"
+ }
+ catch {
+ croak "Can't load $dbicschema ($_)";
+ }
}
my $schema = $tr->schema;
$dbicschema->throw_exception ("'sources' parameter must be an array or hash ref")
unless( $ref eq 'ARRAY' || ref eq 'HASH' );
- # limit monikers to those specified in
+ # limit monikers to those specified in
my $sources;
if ($ref eq 'ARRAY') {
$sources->{$_} = 1 for (@$limit_sources);
# Force the order of @cond to match the order of ->add_columns
my $idx;
my %other_columns_idx = map {'foreign.'.$_ => ++$idx } $relsource->columns;
- my @cond = sort { $other_columns_idx{$a} cmp $other_columns_idx{$b} } keys(%{$rel_info->{cond}});
+ my @cond = sort { $other_columns_idx{$a} cmp $other_columns_idx{$b} } keys(%{$rel_info->{cond}});
# Get the key information, mapping off the foreign/self markers
my @refkeys = map {/^\w+\.(\w+)$/} @cond;
['deploy' => 'Deploy the schema to the database',],
['select' => 'Select data from the schema', ],
['insert' => 'Insert data into the schema', ],
- ['update' => 'Update data in the schema', ],
+ ['update' => 'Update data in the schema', ],
['delete' => 'Delete data from the schema',],
['op:s' => 'compatiblity option all of the above can be suppied as --op=<action>'],
['help' => 'display this help', { implies => { schema_class => '__dummy__' } } ],
['force' => 'Be forceful with some operations'],
['trace' => 'Turn on DBIx::Class trace output'],
['quiet' => 'Be less verbose'],
+ ['I:s@' => 'Same as perl\'s -I, prepended to current @INC'],
)
);
);
}
+# FIXME - lowercasing will eventually go away when Getopt::Long::Descriptive is fixed
+if($opts->{i}) {
+ $opts->{include_dirs} = delete $opts->{i};
+}
+
if($opts->{help}) {
$usage->die();
}
if($opts->{connect}) {
$opts->{connect_info} = delete $opts->{connect};
}
-
my $admin = DBIx::Class::Admin->new( %$opts );
-
my $action = $opts->{action};
$action = $opts->{op} if ($action eq 'op');
-print "Performig action $action...\n";
+print "Performing action $action...\n";
my $res = $admin->$action();
if ($action eq 'select') {
MULTICREATE_DEBUG
/],
},
+ 'DBIx::Class::FilterColumn' => {
+ ignore => [qw/
+ new
+ update
+ store_column
+ get_column
+ get_columns
+ /],
+ },
'DBIx::Class::ResultSource' => {
ignore => [qw/
compare_relationship_keys
is( $uc_name_info->{size}, 3, "Case insensitive matching info for 'uc_name'" );
+## Test ResultSet->update
+my $artist = $schema->resultset('Artist')->first;
+my $cds = $artist->cds_unordered->search({
+ year => { '!=' => 2010 }
+}, { prefetch => 'liner_notes' });
+TODO: {
+ todo_skip 'update resultset with a prefetch over a might_have rel', 1;
+ $cds->update({ year => '2010' });
+}
## Test SELECT ... FOR UPDATE
});
$dbh->do(qq{
CREATE OR REPLACE TRIGGER cd_insert_trg
- BEFORE INSERT ON cd
+ BEFORE INSERT OR UPDATE ON cd
FOR EACH ROW
BEGIN
IF :new.cdid IS NULL THEN
is ($limited_rs->count_rs->next, 6, "$test_type: Correct count_rs of limited right-sorted joined resultset");
my $queries;
+ my $orig_debug = $schema->storage->debug;
$schema->storage->debugcb(sub { $queries++; });
$schema->storage->debug(1);
is ($queries, 1, "$test_type: Only one query with prefetch");
$schema->storage->debugcb(undef);
- $schema->storage->debug(0);
+ $schema->storage->debug($orig_debug);
is_deeply (
[map { $_->name } ($limited_rs->search_related ('owner')->all) ],
my ($sql, @bind) = @${$owners->page(3)->as_query};
is_deeply (
\@bind,
- [ ([ 'me.name' => 'somebogusstring' ], [ test => 'xxx' ]) x 2 ], # double because of the prefetch subq
+ [
+ $dialect eq 'Top' ? [ test => 'xxx' ] : (), # the extra re-order bind
+ ([ 'me.name' => 'somebogusstring' ], [ test => 'xxx' ]) x 2 # double because of the prefetch subq
+ ],
);
is ($owners->page(1)->all, 3, "$test_type: has_many prefetch returns correct number of rows");
isa_ok($schema->storage, "DBIx::Class::Storage::$storage_type");
-# start disconnected to test _ping
- $schema->storage->_dbh->disconnect;
+ SKIP: {
+ skip 'This version of DBD::Sybase segfaults on disconnect', 1 if DBD::Sybase->VERSION < 1.08;
- lives_ok {
- $schema->storage->dbh_do(sub { $_[1]->do('select 1') })
- } '_ping works';
+ # start disconnected to test _ping
+ $schema->storage->_dbh->disconnect;
+
+ lives_ok {
+ $schema->storage->dbh_do(sub { $_[1]->do('select 1') })
+ } '_ping works';
+ }
my $dbh = $schema->storage->dbh;
SKIP: {
my $storage = $schema->storage;
my $version = $storage->_server_info->{normalized_dbms_version};
-
- skip 1, 'could not detect SQL Server version' if not defined $version;
- my $have_rno = $version >= 9 ? 1 : 0;
-
- # Delete version information to force RNO check when rebuilding SQLA
- # instance.
- no strict 'refs';
- no warnings 'redefine';
- local *{(ref $storage).'::_get_server_version'} = sub { undef };
+ skip 'could not detect SQL Server version', 1 if not defined $version;
- my $server_info = { %{ $storage->_server_info_hash } }; # clone
-
- delete @$server_info{qw/dbms_version normalized_dbms_version/};
+ my $have_rno = $version >= 9 ? 1 : 0;
- local $storage->{_server_info_hash} = $server_info;
local $storage->{_sql_maker} = undef;
local $storage->{_sql_maker_opts} = undef;
+ local $storage->{_server_info_hash} = { %{ $storage->_server_info_hash } }; # clone
+ delete @{$storage->{_server_info_hash}}{qw/dbms_version normalized_dbms_version/};
+
$storage->sql_maker;
my $rno_detected =
- ($storage->{_sql_maker_opts}{limit_dialect} eq 'RowNumberOver');
+ ($storage->{_sql_maker_opts}{limit_dialect} eq 'RowNumberOver') ? 1 : 0;
- ok ((not ($have_rno xor $rno_detected)),
+ ok (($have_rno == $rno_detected),
'row_number() over support detected correctly');
}
+
+ {
+ my $schema = DBICTest::Schema->clone;
+ $schema->connection($dsn, $user, $pass);
+
+ like $schema->storage->sql_maker->{limit_dialect},
+ qr/^(?:Top|RowNumberOver)\z/,
+ 'sql_maker is correct on unconnected schema';
+ }
}
# test op-induced autoconnect
use Test::Warn;
use lib qw(t/lib);
use DBICTest;
+use DBIC::DebugObj;
{
package A::Comp;
DBICTest::Schema::CD->utf8_columns('title');
Class::C3->reinitialize();
-{
- package DBICTest::UTF8::Debugger;
-
- use base 'DBIx::Class::Storage::Statistics';
-
- __PACKAGE__->mk_group_accessors(simple => 'call_stack');
-
- sub query_start {
- my $self = shift;
- my $sql = shift;
-
- my @bind = map { substr $_, 1, -1 } (@_); # undo the effect of _fix_bind_params
-
- $self->call_stack ( [ @{$self->call_stack || [] }, [$sql, @bind] ] );
- $self->next::method ($sql, @_);
- }
-}
-
# as per http://search.cpan.org/dist/Test-Simple/lib/Test/More.pm#utf8
binmode (Test::More->builder->$_, ':utf8') for qw/output failure_output todo_output/;
cmp_ok ($bytestream_title, 'ne', $utf8_title, 'unicode/raw differ (sanity check)');
my $storage = $schema->storage;
-$storage->debugobj (DBICTest::UTF8::Debugger->new);
-$storage->debugobj->silence (1);
+my ($sql, @bind);
+my $debugobj = DBIC::DebugObj->new (\$sql, \@bind);
+my ($orig_debug, $orig_debugobj) = ($storage->debug, $storage->debugobj);
+$storage->debugobj ($debugobj);
$storage->debug (1);
my $cd = $schema->resultset('CD')->create( { artist => 1, title => $utf8_title, year => '2048' } );
-# bind values are always alphabetically ordered by column, thus [2]
+$storage->debugobj ($orig_debugobj);
+$storage->debug ($orig_debug);
+
+# bind values are always alphabetically ordered by column, thus [1]
+# the single quotes are an artefact of the debug-system
TODO: {
local $TODO = "This has been broken since rev 1191, Mar 2006";
- is ($storage->debugobj->call_stack->[-1][2], $bytestream_title, 'INSERT: raw bytes sent to the database');
+ is ($bind[1], "'$bytestream_title'", 'INSERT: raw bytes sent to the database');
}
# this should be using the cursor directly, no inflation/processing of any sort
$bytestream_title = $utf8_title = "something \x{219} else";
utf8::encode($bytestream_title);
+
+$storage->debugobj ($debugobj);
+$storage->debug (1);
+
$cd->update ({ title => $utf8_title });
-is ($storage->debugobj->call_stack->[-1][1], $bytestream_title, 'UPDATE: raw bytes sent to the database');
+
+$storage->debugobj ($orig_debugobj);
+$storage->debug ($orig_debug);
+
+is ($bind[0], "'$bytestream_title'", 'UPDATE: raw bytes sent to the database');
($raw_db_title) = $schema->resultset('CD')
->search ($cd->ident_condition)
->get_column('title')
is($schema_v2->get_db_version(), '3.0', 'Fast deploy/upgrade');
};
+# Check that it Schema::Versioned deals with new/all forms of connect arguments.
+{
+ my $get_db_version_run = 0;
+
+ no warnings qw/once redefine/;
+ local *DBIx::Class::Schema::Versioned::get_db_version = sub {
+ $get_db_version_run = 1;
+ return $_[0]->schema_version;
+ };
+
+ # Make sure the env var isn't whats triggering it
+ local $ENV{DBIC_NO_VERSION_CHECK} = 0;
+
+ DBICVersion::Schema->connect({
+ dsn => $dsn,
+ user => $user,
+ pass => $pass,
+ ignore_version => 1
+ });
+
+ ok($get_db_version_run == 0, "attributes pulled from hashref connect_info");
+ $get_db_version_run = 0;
+
+ DBICVersion::Schema->connect( $dsn, $user, $pass, { ignore_version => 1 } );
+ ok($get_db_version_run == 0, "attributes pulled from list connect_info");
+}
+
unless ($ENV{DBICTEST_KEEP_VERSIONING_DDL}) {
unlink $_ for (values %$fn);
}
no_populate=>1,
sqlite_use_file => 1,
);
+
{ # create the schema
# make sure we are clean
my $admin = DBIx::Class::Admin->new(
schema_class=> "DBICTest::Schema",
sql_dir=> $sql_dir,
- connect_info => \@connect_info,
+ connect_info => \@connect_info,
);
isa_ok ($admin, 'DBIx::Class::Admin', 'create the admin object');
lives_ok { $admin->create('MySQL'); } 'Can create MySQL sql';
lives_ok { $admin->create('SQLite'); } 'Can Create SQLite sql';
+lives_ok {
+ $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /no such table.+DROP TABLE/s };
+ $admin->deploy()
+} 'Can Deploy schema';
}
{ # upgrade schema
-#my $schema = DBICTest->init_schema(
-# no_deploy => 1,
-# no_populat => 1,
-# sqlite_use_file => 1,
-#);
-
clean_dir($sql_dir);
require DBICVersion_v1;
my $admin = DBIx::Class::Admin->new(
- schema_class => 'DBICVersion::Schema',
+ schema_class => 'DBICVersion::Schema',
sql_dir => $sql_dir,
connect_info => \@connect_info,
);
require DBICVersion_v2;
+DBICVersion::Schema->upgrade_directory (undef); # so that we can test use of $sql_dir
$admin = DBIx::Class::Admin->new(
- schema_class => 'DBICVersion::Schema',
+ schema_class => 'DBICVersion::Schema',
sql_dir => $sql_dir,
connect_info => \@connect_info
);
{
local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /DB version .+? is lower than the schema version/ };
lives_ok {$admin->upgrade();} 'upgrade the schema';
+ dies_ok {$admin->deploy} 'cannot deploy installed schema, should upgrade instead';
}
is($schema->get_db_version, $DBICVersion::Schema::VERSION, 'Schema and db versions match');
clean_dir($sql_dir);
my $admin = DBIx::Class::Admin->new(
- schema_class => 'DBICVersion::Schema',
+ schema_class => 'DBICVersion::Schema',
sql_dir => $sql_dir,
_confirm => 1,
connect_info => \@connect_info,
}
foreach my $file ($dir->children) {
# skip any hidden files
- next if ($file =~ /^\./);
+ next if ($file =~ /^\./);
unlink $file;
}
}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+BEGIN {
+ require DBIx::Class;
+ plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for('admin');
+}
+
+if(use_ok 'DBIx::Class::Admin') {
+ my $admin = DBIx::Class::Admin->new(
+ include_dirs => ['t/lib/testinclude'],
+ schema_class => 'DBICTestAdminInc',
+ config => { DBICTestAdminInc => {} },
+ config_stanza => 'DBICTestAdminInc'
+ );
+ lives_ok { $admin->_build_schema } 'should survive attempt to load module located in include_dirs';
+ {
+ no warnings 'once';
+ ok($DBICTestAdminInc::loaded);
+ }
+}
+
+done_testing;
my @json_backends = qw/XS JSON DWIW/;
my $tests_per_run = 5;
+plan tests => ($tests_per_run * @json_backends) + 1;
-plan tests => $tests_per_run * @json_backends;
+
+# test the script is setting @INC properly
+test_exec (qw| -It/lib/testinclude --schema=DBICTestAdminInc --op=deploy --connect=[] |);
+cmp_ok ( $? >> 8, '==', 70, 'Correct exit code from deploying a custom INC schema' );
for my $js (@json_backends) {
my $employees = $schema->resultset('Employee');
- system( _prepare_system_args( qw|--op=insert --set={"name":"Matt"}| ) );
+ test_exec( default_args(), qw|--op=insert --set={"name":"Matt"}| );
ok( ($employees->count()==1), "$ENV{JSON_ANY_ORDER}: insert count" );
my $employee = $employees->find(1);
ok( ($employee->name() eq 'Matt'), "$ENV{JSON_ANY_ORDER}: insert valid" );
- system( _prepare_system_args( qw|--op=update --set={"name":"Trout"}| ) );
+ test_exec( default_args(), qw|--op=update --set={"name":"Trout"}| );
$employee = $employees->find(1);
ok( ($employee->name() eq 'Trout'), "$ENV{JSON_ANY_ORDER}: update" );
- system( _prepare_system_args( qw|--op=insert --set={"name":"Aran"}| ) );
+ test_exec( default_args(), qw|--op=insert --set={"name":"Aran"}| );
SKIP: {
skip ("MSWin32 doesn't support -| either", 1) if $^O eq 'MSWin32';
- open(my $fh, "-|", _prepare_system_args( qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!;
+ open(my $fh, "-|", ( 'script/dbicadmin', default_args(), qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!;
my $data = do { local $/; <$fh> };
close($fh);
if (!ok( ($data=~/Aran.*Trout/s), "$ENV{JSON_ANY_ORDER}: select with attrs" )) {
};
}
- system( _prepare_system_args( qw|--op=delete --where={"name":"Trout"}| ) );
+ test_exec( default_args(), qw|--op=delete --where={"name":"Trout"}| );
ok( ($employees->count()==1), "$ENV{JSON_ANY_ORDER}: delete" );
}
+sub default_args {
+ return (
+ qw|--quiet --schema=DBICTest::Schema --class=Employee|,
+ q|--connect=["dbi:SQLite:dbname=t/var/DBIxClass.db","","",{"AutoCommit":1}]|,
+ qw|--force -I testincludenoniterference|,
+ );
+}
+
# Why do we need this crap? Apparently MSWin32 can not pass through quotes properly
# (sometimes it will and sometimes not, depending on what compiler was used to build
# perl). So we go the extra mile to escape all the quotes. We can't also use ' instead
# of ", because JSON::XS (proudly) does not support "malformed JSON" as the author
# calls it. Bleh.
#
-sub _prepare_system_args {
- my $perl = $^X;
-
- my @args = (
- qw|script/dbicadmin --quiet --schema=DBICTest::Schema --class=Employee|,
- q|--connect=["dbi:SQLite:dbname=t/var/DBIxClass.db","","",{"AutoCommit":1}]|,
- qw|--force|,
- @_,
- );
-
- if ( $^O eq 'MSWin32' ) {
- $perl = qq|"$perl"|; # execution will fail if $^X contains paths
- for (@args) {
- $_ =~ s/"/\\"/g;
- }
+sub test_exec {
+ my $perl = $^X;
+
+ my @args = ('script/dbicadmin', @_);
+
+ if ( $^O eq 'MSWin32' ) {
+ $perl = qq|"$perl"|; # execution will fail if $^X contains paths
+ for (@args) {
+ $_ =~ s/"/\\"/g;
}
+ }
- return ($perl, @args);
+ system ($perl, @args);
}
use Test::More;
use Test::Exception;
+use Data::Dumper::Concise;
use lib qw(t/lib);
use DBICTest;
use DBIC::SqlMakerTest;
{
order_by => $args->{order_by},
having =>
- [ { read_count => { '>' => 5 } }, \[ 'read_count < ?', 8 ] ]
+ [ { read_count => { '>' => 5 } }, \[ 'read_count < ?', [ read_count => 8 ] ] ]
}
)->as_query,
"(
[
[qw(foo bar)],
[qw(read_count 5)],
- 8,
+ [qw(read_count 8)],
$args->{bind}
? @{ $args->{bind} }
: ()
],
- );
+ ) || diag Dumper $args->{order_by};
};
- fail('Fail the unfinished is_same_sql_bind') if $@;
}
}
bind => [],
},
{
- order_by => { -desc => \[ 'colA LIKE ?', 'test' ] },
+ order_by => { -desc => \[ 'colA LIKE ?', [ colA => 'test' ] ] },
order_req => 'colA LIKE ? DESC',
- bind => [qw(test)],
+ bind => [ [ colA => 'test' ] ],
},
{
- order_by => \[ 'colA LIKE ? DESC', 'test' ],
+ order_by => \[ 'colA LIKE ? DESC', [ colA => 'test' ] ],
order_req => 'colA LIKE ? DESC',
- bind => [qw(test)],
+ bind => [ [ colA => 'test' ] ],
},
{
order_by => [
{ -asc => \['colA'] },
- { -desc => \[ 'colB LIKE ?', 'test' ] },
- { -asc => \[ 'colC LIKE ?', 'tost' ] }
+ { -desc => \[ 'colB LIKE ?', [ colB => 'test' ] ] },
+ { -asc => \[ 'colC LIKE ?', [ colC => 'tost' ] ] },
],
order_req => 'colA ASC, colB LIKE ? DESC, colC LIKE ? ASC',
- bind => [qw(test tost)],
+ bind => [ [ colB => 'test' ], [ colC => 'tost' ] ],
},
-
- # (mo) this would be really really nice!
- # (ribasushi) I don't think so, not writing it - patches welcome
{
+ todo => 1,
order_by => [
{ -asc => 'colA' },
{ -desc => { colB => { 'LIKE' => 'test' } } },
{ -asc => { colC => { 'LIKE' => 'tost' } } }
],
order_req => 'colA ASC, colB LIKE ? DESC, colC LIKE ? ASC',
- bind => [ [ colB => 'test' ], [ colC => 'tost' ] ], # ???
- todo => 1,
+ bind => [ [ colB => 'test' ], [ colC => 'tost' ] ],
},
{
+ todo => 1,
order_by => { -desc => { colA => { LIKE => 'test' } } },
order_req => 'colA LIKE ? DESC',
- bind => [qw(test)],
- todo => 1,
+ bind => [ [ colA => 'test' ] ],
},
);
-plan( tests => scalar @tests * 2 );
-
test_order($_) for @tests;
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Exception;
my $schema;
+SKIP:
for my $connect_info (@connect_info) {
my ($dsn, $user, $pass) = @$connect_info;
on_connect_call => 'datetime_setup'
});
+ {
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ $schema->storage->ensure_connected;
+ if ($w =~ /Your DBD::Sybase is too old to support DBIx::Class::InflateColumn::DateTime/) {
+ skip "Skipping tests on old DBD::Sybase " . DBD::Sybase->VERSION, 1;
+ }
+ }
+
my $guard = Scope::Guard->new(\&cleanup);
# coltype, column, datehash
use Test::More;
use Test::Exception;
+use Scope::Guard ();
use lib qw(t/lib);
use DBICTest;
[ $dsn2, $user2, $pass2 ],
);
-my @handles_to_clean;
+my $schema;
foreach my $info (@info) {
my ($dsn, $user, $pass) = @$info;
next unless $dsn;
- my $schema = DBICTest::Schema->clone;
+ $schema = DBICTest::Schema->clone;
$schema->connection($dsn, $user, $pass, {
on_connect_call => [ 'datetime_setup' ],
});
- push @handles_to_clean, $schema->storage->dbh;
+ my $sg = Scope::Guard->new(\&cleanup);
# coltype, col, date
my @dt_types = (
->search({ trackid => $row->trackid }, { select => [$col] })
->first
);
- is( $row->$col, $dt, 'DateTime roundtrip' );
+ is( $row->$col, $dt, "$type roundtrip" );
is $row->$col->nanosecond, $dt->nanosecond,
'nanoseconds survived' if 0+$dt->nanosecond;
done_testing;
# clean up our mess
-END {
- foreach my $dbh (@handles_to_clean) {
+sub cleanup {
+ if (my $dbh = $schema->storage->dbh) {
eval { $dbh->do("DROP TABLE $_") } for qw/track/;
}
}
# Under some versions of SQLite if the $rs is left hanging around it will lock
# So we create a scope here cos I'm lazy
{
- my $rs = $schema->resultset('CD')->search ({}, { order_by => 'cdid' });
+ my $rs = $schema->resultset('CD')->search ({}, {
+ order_by => 'cdid',
+ # use the hashref inflator class as result class
+ result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+ });
# get the defined columns
my @dbic_cols = sort $rs->result_source->columns;
- # use the hashref inflator class as result class
- $rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
-
# fetch first record
my $datahashref1 = $rs->first;
my $cd2 = $rs->search({ cdid => 1 })->single;
is_deeply ( $cd2, $datahashref1, 'first/search+single return the same thing');
+
+ $rs->result_class('DBIx::Class::Row');
+
+ is( $rs->result_class, 'DBIx::Class::Row', 'result_class set' );
+
+ is(
+ $rs->search->result_class, 'DBIx::Class::ResultClass::HashRefInflator',
+ 'result_class set using accessor does not propagate over search'
+ );
+
}
sub check_cols_of {
sub query_end { }
-sub txn_start { }
+sub txn_begin { }
sub txn_commit { }
push @fail_reasons, "Missing ./inc directory";
}
- if (not $mf_mtime) {
+ if(not $mf_mtime) {
push @fail_reasons, "Missing ./Makefile";
}
- elsif($mf_mtime < $mf_pl_mtime) {
- push @fail_reasons, "./Makefile.PL is newer than ./Makefile";
- }
-
- if ($mf_mtime < $optdeps_mtime) {
- push @fail_reasons, "./$optdeps is newer than ./Makefile";
+ else {
+ if($mf_mtime < $mf_pl_mtime) {
+ push @fail_reasons, "./Makefile.PL is newer than ./Makefile";
+ }
+ if($mf_mtime < $optdeps_mtime) {
+ push @fail_reasons, "./$optdeps is newer than ./Makefile";
+ }
}
if (@fail_reasons) {
);
__PACKAGE__->set_primary_key('id');
+__PACKAGE__->add_unique_constraint (['title']);
+
__PACKAGE__->resultset_attributes({where => { source => "Library" } });
__PACKAGE__->belongs_to ( owner => 'DBICTest::Schema::Owners', 'owner' );
__PACKAGE__->register_class('Table', 'DBICVersion::Table');
__PACKAGE__->load_components('+DBIx::Class::Schema::Versioned');
-
-sub upgrade_directory
-{
- return 't/var/';
-}
+__PACKAGE__->upgrade_directory('t/var/');
sub ordered_schema_versions {
return('1.0','2.0','3.0');
__PACKAGE__->upgrade_directory('t/var/');
__PACKAGE__->backup_directory('t/var/backup/');
-#sub upgrade_directory
-#{
-# return 't/var/';
-#}
-
1;
--- /dev/null
+package DBICTestAdminInc;
+use base 'DBIx::Class::Schema';
+
+our $loaded = 1;
+sub connect { bless {}, __PACKAGE__ }
+
+sub deploy { exit 70 } # this is what the test will expect to see
+
+1;
use Test::More;
use Test::Exception;
use DBICTest;
-
-#plan tests => 5;
-plan 'no_plan';
+use DBIC::DebugObj;
+use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
);
$sub_rs->delete;
-
is ($tkfks->count, $tkfk_cnt -= 2, 'Only two rows deleted');
+
+# make sure limit-only deletion works
+cmp_ok ($tkfk_cnt, '>', 1, 'More than 1 row left');
+$tkfks->search ({}, { rows => 1 })->delete;
+is ($tkfks->count, $tkfk_cnt -= 1, 'Only one row deleted');
+
+
+# Make sure prefetch is properly stripped too
+# check with sql-equality, as sqlite will accept bad sql just fine
+my ($sql, @bind);
+my $orig_debugobj = $schema->storage->debugobj;
+my $orig_debug = $schema->storage->debug;
+
+$schema->storage->debugobj (DBIC::DebugObj->new (\$sql, \@bind) );
+$schema->storage->debug (1);
+$schema->resultset('CD')->search(
+ { year => { '!=' => 2010 } },
+ { prefetch => 'liner_notes' },
+)->delete;
+
+$schema->storage->debugobj ($orig_debugobj);
+$schema->storage->debug ($orig_debug);
+
+is_same_sql_bind (
+ $sql,
+ \@bind,
+ 'DELETE FROM cd WHERE ( cdid IN ( SELECT me.cdid FROM cd me WHERE ( year != ? ) GROUP BY me.cdid ) )',
+ ["'2010'"],
+ 'Update on prefetching resultset strips prefetch correctly'
+);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my $from_storage_ran = 0;
+my $to_storage_ran = 0;
+my $schema = DBICTest->init_schema();
+DBICTest::Schema::Artist->load_components(qw(FilterColumn InflateColumn));
+DBICTest::Schema::Artist->filter_column(rank => {
+ filter_from_storage => sub { $from_storage_ran++; $_[1] * 2 },
+ filter_to_storage => sub { $to_storage_ran++; $_[1] / 2 },
+});
+Class::C3->reinitialize();
+
+my $artist = $schema->resultset('Artist')->create( { rank => 20 } );
+
+# this should be using the cursor directly, no inflation/processing of any sort
+my ($raw_db_rank) = $schema->resultset('Artist')
+ ->search ($artist->ident_condition)
+ ->get_column('rank')
+ ->_resultset
+ ->cursor
+ ->next;
+
+is ($raw_db_rank, 10, 'INSERT: correctly unfiltered on insertion');
+
+for my $reloaded (0, 1) {
+ my $test = $reloaded ? 'reloaded' : 'stored';
+ $artist->discard_changes if $reloaded;
+
+ is( $artist->rank , 20, "got $test filtered rank" );
+}
+
+$artist->update;
+$artist->discard_changes;
+is( $artist->rank , 20, "got filtered rank" );
+
+$artist->update ({ rank => 40 });
+($raw_db_rank) = $schema->resultset('Artist')
+ ->search ($artist->ident_condition)
+ ->get_column('rank')
+ ->_resultset
+ ->cursor
+ ->next;
+is ($raw_db_rank, 20, 'UPDATE: correctly unflitered on update');
+
+$artist->discard_changes;
+$artist->rank(40);
+ok( !$artist->is_column_changed('rank'), 'column is not dirty after setting the same value' );
+
+MC: {
+ my $cd = $schema->resultset('CD')->create({
+ artist => { rank => 20 },
+ title => 'fun time city!',
+ year => 'forevertime',
+ });
+ ($raw_db_rank) = $schema->resultset('Artist')
+ ->search ($cd->artist->ident_condition)
+ ->get_column('rank')
+ ->_resultset
+ ->cursor
+ ->next;
+
+ is $raw_db_rank, 10, 'artist rank gets correctly unfiltered w/ MC';
+ is $cd->artist->rank, 20, 'artist rank gets correctly filtered w/ MC';
+}
+
+CACHE_TEST: {
+ my $expected_from = $from_storage_ran;
+ my $expected_to = $to_storage_ran;
+
+ # ensure we are creating a fresh obj
+ $artist = $schema->resultset('Artist')->single($artist->ident_condition);
+
+ is $from_storage_ran, $expected_from, 'from has not run yet';
+ is $to_storage_ran, $expected_to, 'to has not run yet';
+
+ $artist->rank;
+ cmp_ok (
+ $artist->get_filtered_column('rank'),
+ '!=',
+ $artist->get_column('rank'),
+ 'filter/unfilter differ'
+ );
+ is $from_storage_ran, ++$expected_from, 'from ran once, therefor caches';
+ is $to_storage_ran, $expected_to, 'to did not run';
+
+ $artist->rank(6);
+ is $from_storage_ran, $expected_from, 'from did not run';
+ is $to_storage_ran, ++$expected_to, 'to ran once';
+
+ ok ($artist->is_column_changed ('rank'), 'Column marked as dirty');
+
+ $artist->rank;
+ is $from_storage_ran, $expected_from, 'from did not run';
+ is $to_storage_ran, $expected_to, 'to did not run';
+
+ $artist->update;
+
+ $artist->set_column(rank => 3);
+ ok (! $artist->is_column_changed ('rank'), 'Column not marked as dirty on same set_column value');
+ is ($artist->rank, '6', 'Column set properly (cache blown)');
+ is $from_storage_ran, ++$expected_from, 'from ran once (set_column blew cache)';
+ is $to_storage_ran, $expected_to, 'to did not run';
+
+ $artist->rank(6);
+ ok (! $artist->is_column_changed ('rank'), 'Column not marked as dirty on same accessor-set value');
+ is ($artist->rank, '6', 'Column set properly');
+ is $from_storage_ran, $expected_from, 'from did not run';
+ is $to_storage_ran, $expected_to, 'to did not run';
+
+ $artist->store_column(rank => 4);
+ ok (! $artist->is_column_changed ('rank'), 'Column not marked as dirty on differing store_column value');
+ is ($artist->rank, '8', 'Cache properly blown');
+ is $from_storage_ran, ++$expected_from, 'from did not run';
+ is $to_storage_ran, $expected_to, 'to did not run';
+}
+
+IC_DIE: {
+ dies_ok {
+ DBICTest::Schema::Artist->inflate_column(rank =>
+ { inflate => sub {}, deflate => sub {} }
+ );
+ } q(Can't inflate column after filter column);
+
+ DBICTest::Schema::Artist->inflate_column(name =>
+ { inflate => sub {}, deflate => sub {} }
+ );
+
+ dies_ok {
+ DBICTest::Schema::Artist->filter_column(name => {
+ filter_to_storage => sub {},
+ filter_from_storage => sub {}
+ });
+ } q(Can't filter column after inflate column);
+}
+
+done_testing;
my @tests = (
{
rs => $cdrs,
- search => \[ "title = ? AND year LIKE ?", 'buahaha', '20%' ],
+ search => \[ "title = ? AND year LIKE ?", [ title => 'buahaha' ], [ year => '20%' ] ],
attrs => { rows => 5 },
sqlbind => \[
"( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE (title = ? AND year LIKE ?) LIMIT 5)",
- 'buahaha',
- '20%',
+ [ title => 'buahaha' ],
+ [ year => '20%' ],
],
},
);
-plan tests => @tests * 2;
-
for my $i (0 .. $#tests) {
my $t = $tests[$i];
for my $p (1, 2) { # repeat everything twice, make sure we do not clobber search arguments
);
}
}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema;
+
+$schema->storage->_sql_maker->limit_dialect ('GenericSubQ');
+
+my $rs = $schema->resultset ('BooksInLibrary')->search ({}, {
+ '+columns' => [{ owner_name => 'owner.name' }],
+ join => 'owner',
+ rows => 2,
+ order_by => 'me.title',
+});
+
+is_same_sql_bind(
+ $rs->as_query,
+ '(
+ SELECT id, source, owner, title, price,
+ owner_name
+ FROM (
+ SELECT me.id, me.source, me.owner, me.title, me.price,
+ owner.name AS owner_name
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ORDER BY me.title
+ ) me
+ WHERE
+ (
+ SELECT COUNT(*)
+ FROM books rownum__emulation
+ WHERE rownum__emulation.title < me.title
+ ) < 2
+ )',
+ [ [ 'source', 'Library' ] ],
+);
+
+is_deeply (
+ [ $rs->get_column ('title')->all ],
+ ['Best Recipe Cookbook', 'Dynamical Systems'],
+ 'Correct columns selected with rows',
+);
+
+$schema->storage->_sql_maker->quote_char ('"');
+$schema->storage->_sql_maker->name_sep ('.');
+
+$rs = $schema->resultset ('BooksInLibrary')->search ({}, {
+ order_by => { -desc => 'title' },
+ '+select' => ['owner.name'],
+ '+as' => ['owner.name'],
+ join => 'owner',
+ rows => 3,
+ offset => 1,
+});
+
+is_same_sql_bind(
+ $rs->as_query,
+ '(
+ SELECT "id", "source", "owner", "title", "price",
+ "owner__name"
+ FROM (
+ SELECT "me"."id", "me"."source", "me"."owner", "me"."title", "me"."price",
+ "owner"."name" AS "owner__name"
+ FROM "books" "me"
+ JOIN "owners" "owner" ON "owner"."id" = "me"."owner"
+ WHERE ( "source" = ? )
+ ORDER BY "title" DESC
+ ) "me"
+ WHERE
+ (
+ SELECT COUNT(*)
+ FROM "books" "rownum__emulation"
+ WHERE "rownum__emulation"."title" > "me"."title"
+ ) BETWEEN 1 AND 3
+ )',
+ [ [ 'source', 'Library' ] ],
+);
+
+is_deeply (
+ [ $rs->get_column ('title')->all ],
+ [ 'Dynamical Systems', 'Best Recipe Cookbook' ],
+ 'Correct columns selected with rows',
+);
+
+$rs = $schema->resultset ('BooksInLibrary')->search ({}, {
+ order_by => 'title',
+ 'select' => ['owner.name'],
+ 'as' => ['owner_name'],
+ join => 'owner',
+ offset => 1,
+});
+
+is_same_sql_bind(
+ $rs->as_query,
+ '(
+ SELECT "owner_name"
+ FROM (
+ SELECT "owner"."name" AS "owner_name", "title"
+ FROM "books" "me"
+ JOIN "owners" "owner" ON "owner"."id" = "me"."owner"
+ WHERE ( "source" = ? )
+ ORDER BY "title"
+ ) "me"
+ WHERE
+ (
+ SELECT COUNT(*)
+ FROM "books" "rownum__emulation"
+ WHERE "rownum__emulation"."title" < "me"."title"
+ ) BETWEEN 1 AND 4294967295
+ )',
+ [ [ 'source', 'Library' ] ],
+);
+
+is_deeply (
+ [ $rs->get_column ('owner_name')->all ],
+ [ ('Newton') x 2 ],
+ 'Correct columns selected with rows',
+);
+
+done_testing;
SELECT TOP 2 id, source, owner, title, price
FROM (
SELECT TOP 2
- id, source, owner, title, price, ORDER__BY__1
+ id, source, owner, title, price
FROM (
SELECT TOP 5
- me.id, me.source, me.owner, me.title, me.price, title AS ORDER__BY__1
+ me.id, me.source, me.owner, me.title, me.price
FROM books me
JOIN owners owner ON owner.id = me.owner
WHERE ( source = ? )
GROUP BY title
ORDER BY title
) me
- ORDER BY ORDER__BY__1 DESC
+ ORDER BY title DESC
) me
- ORDER BY ORDER__BY__1
+ ORDER BY title
) me
JOIN owners owner ON owner.id = me.owner
WHERE ( source = ? )
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema();
+
+my $rs = $schema->resultset('CD')->search({}, {
+ 'join' => 'tracks',
+ order_by => {
+ -desc => {
+ count => 'tracks.track_id',
+ },
+ },
+ distinct => 1,
+ rows => 2,
+ page => 1,
+});
+my $match = q{
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me
+ GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
+ ORDER BY COUNT(tracks.trackid) DESC
+};
+
+TODO: {
+ todo_skip 'order_by using function', 2;
+ is_same_sql($rs->as_query, $match, 'order by with func query');
+
+ ok($rs->count == 2, 'amount of rows return in order by func query');
+}
+
+done_testing;
projects / dbsrgits/DBIx-Class.git / commitdiff