Revision history for DBIx::Class
+ - Fix storage to copy scalar conds before regexping to avoid
+ trying to modify a constant in odd edge cases
+ - Related resultsets on uninserted objects are now empty
- Fixed up related resultsets and multi-create
- Fixed superfluous connection in ODBC::_rebless
- Fixed undef PK for first insert in ODBC::Microsoft_SQL_Server
path across multiple versions (jgoulah)
- Better (and marginally faster) implementation of the HashRefInflator
hash construction algorithm
- - Added the ability to instantiate HashRefInflator so options can be
- passed to the constructor
- - Additional recursive function to optionally inflate any inflatable
- values in the hashref generated by HashRefInflator
- Allow explicit specification of ON DELETE/ON UPDATE constraints
when using the SQLT parser
=head1 DESCRIPTION
-Exception objects of this class are used in internally by
-he default error handling of L<DBIx::Class::Schema/throw_exception>
+Exception objects of this class are used internally by
+the default error handling of L<DBIx::Class::Schema/throw_exception>
to prevent confusing and/or redundant re-application of L<Carp>'s
stack trace information.
my $fs_file = $self->_file_column_file($column, $value->{filename});
mkpath [$fs_file->dir];
-
- File::Copy::copy($value->{handle}, $fs_file->stringify); # File::Copy doesn't like Path::Class (or any for that matter) objects
+
+ # File::Copy doesn't like Path::Class (or any for that matter) objects,
+ # thus ->stringify (http://rt.perl.org/rt3/Public/Bug/Display.html?id=59650)
+ File::Copy::copy($value->{handle}, $fs_file->stringify);
$self->_file_column_callback($value, $self, $column);
For more information on generating complex queries, see
L<SQL::Abstract/WHERE CLAUSES>.
+=head2 Retrieve one and only one row from a resultset
+
+Sometimes you need only the first "top" row of a resultset. While this can be
+easily done with L<< $rs->first|DBIx::Class::ResultSet/first >>, it is suboptimal,
+as a full blown cursor for the resultset will be created and then immediately
+destroyed after fetching the first row object.
+L<< $rs->single|DBIx::Class::ResultSet/single >> is
+designed specifically for this case - it will grab the first returned result
+without even instantiating a cursor.
+
+Before replacing all your calls to C<first()> with C<single()> please observe the
+following CAVEATS:
+
+=over
+
+=item *
+While single() takes a search condition just like search() does, it does
+_not_ accept search attributes. However one can always chain a single() to
+a search():
+
+ my $top_cd = $cd_rs -> search({}, { order_by => 'rating' }) -> single;
+
+
+=item *
+Since single() is the engine behind find(), it is designed to fetch a
+single row per database query. Thus a warning will be issued when the
+underlying SELECT returns more than one row. Sometimes however this usage
+is valid: i.e. we have an arbitrary number of cd's but only one of them is
+at the top of the charts at any given time. If you know what you are doing,
+you can silence the warning by explicitly limiting the resultset size:
+
+ my $top_cd = $cd_rs -> search ({}, { order_by => 'rating', rows => 1 }) -> single;
+
+=back
+
=head2 Arbitrary SQL through a custom ResultSource
Sometimes you have to run arbitrary SQL because your query is too complex
Wasn't that easy?
-=head2 Skip row object creation for faster results, but still inflate
-column values to the corresponding objects
-
- my $rs = $schema->resultset('CD');
-
- $rs->result_class(DBIx::Class::ResultClass::HashRefInflator->new (
- inflate_columns => 1
- ));
-
- my $hash_ref = $rs->find(1);
-
=head2 Get raw data for blindingly fast results
If the L<HashRefInflator|DBIx::Class::ResultClass::HashRefInflator> solution
__PACKAGE__->has_many('pages' => 'Page', 'book', { order_by => \'page_number DESC'} );
+=head2 Filtering a relationship result set
+
+If you want to get a filtered result set, you can just add add to $attr as follows:
+
+ __PACKAGE__->has_many('pages' => 'Page', 'book', { where => { scrap => 0 } } );
+
=head2 Many-to-many relationships
This is straightforward using L<ManyToMany|DBIx::Class::Relationship/many_to_many>:
L<DBIx::Class::Manual::Cookbook>, try looking in the SQL::Abstract
documentation.
+=item .. make searches in Oracle (10gR2 and newer) case-insensitive?
+
+To make Oracle behave like most RDBMS use on_connect_do to issue
+alter session statements on database connection establishment:
+
+ ->on_connect_do("ALTER SESSION SET NLS_COMP = 'LINGUISTIC'");
+ ->on_connect_do("ALTER SESSION SET NLS_SORT = '<NLS>_CI'");
+ e.g.
+ ->on_connect_do("ALTER SESSION SET NLS_SORT = 'BINARY_CI'");
+ ->on_connect_do("ALTER SESSION SET NLS_SORT = 'GERMAN_CI'");
+
+
=back
=head2 Fetching data
MyDB::Schema::Actor->many_to_many('roles' => 'actorroles', 'role');
## Using relationships
- $schema->resultset('Actor')->roles();
- $schema->resultset('Role')->search_related('actors', { Name => 'Fred' });
- $schema->resultset('ActorRole')->add_to_roles({ Name => 'Sherlock Holmes'});
+ $schema->resultset('Actor')->find({ id => 1})->roles();
+ $schema->resultset('Role')->find({ id => 1 })->actorroles->search_related('actor', { Name => 'Fred' });
+ $schema->resultset('Actor')->add_to_roles({ Name => 'Sherlock Holmes'});
See L<DBIx::Class::Manual::Cookbook> for more.
if (@_ > 1 && (@_ % 2 == 1));
my $query = ((@_ > 1) ? {@_} : shift);
- my $cond = $self->result_source->resolve_condition(
+ my $source = $self->result_source;
+ my $cond = $source->resolve_condition(
$rel_obj->{cond}, $rel, $self
);
+ if ($cond eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) {
+ my $reverse = $source->reverse_relationship_info($rel);
+ foreach my $rev_rel (keys %$reverse) {
+ if ($reverse->{$rev_rel}{attrs}{accessor} eq 'multi') {
+ $attrs->{related_objects}{$rev_rel} = [ $self ];
+ Scalar::Util::weaken($attrs->{related_object}{$rev_rel}[0]);
+ } else {
+ $attrs->{related_objects}{$rev_rel} = $self;
+ Scalar::Util::weaken($attrs->{related_object}{$rev_rel});
+ }
+ }
+ }
if (ref $cond eq 'ARRAY') {
$cond = [ map {
if (ref $_ eq 'HASH') {
$_;
}
} @$cond ];
- } else {
+ } elsif (ref $cond eq 'HASH') {
foreach my $key (grep { ! /\./ } keys %$cond) {
$cond->{"me.$key"} = delete $cond->{$key};
}
use DBIx::Class::ResultClass::HashRefInflator;
my $rs = $schema->resultset('CD');
-
$rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
- or
- $rs->result_class(DBIx::Class::ResultClass::HashRefInflator->new (%args));
-
while (my $hashref = $rs->next) {
...
}
Specifying this class as a C<result_class> for a resultset will change C<< $rs->next >>
to return a plain data hash-ref (or a list of such hash-refs if C<< $rs->all >> is used).
-There are two ways of using this class:
-
-=over
-
-=item *
-
-Supply an instance of DBIx::Class::ResultClass::HashRefInflator to
-C<< $rs->result_class >>. See L</ARGUMENTS> for a list of valid
-arguments to new().
-
-=item *
-
-Another way is to simply supply the class name as a string to
-C<< $rs->result_class >>. Equivalent to passing
-DBIx::Class::ResultClass::HashRefInflator->new().
-
-=back
-
There are two ways of applying this class to a resultset:
=over
}
};
-# This is the inflator
-my $inflate_hash;
-$inflate_hash = sub {
- my ($hri_instance, $schema, $rc, $data) = @_;
-
- foreach my $column (keys %{$data}) {
-
- if (ref $data->{$column} eq 'HASH') {
- $inflate_hash->($hri_instance, $schema, $schema->source ($rc)->related_class ($column), $data->{$column});
- }
- elsif (ref $data->{$column} eq 'ARRAY') {
- foreach my $rel (@{$data->{$column}}) {
- $inflate_hash->($hri_instance, $schema, $schema->source ($rc)->related_class ($column), $rel);
- }
- }
- else {
- # "null is null is null"
- next if not defined $data->{$column};
-
- # cache the inflator coderef
- unless (exists $hri_instance->{_inflator_cache}{$rc}{$column}) {
- $hri_instance->{_inflator_cache}{$rc}{$column} = exists $schema->source ($rc)->_relationships->{$column}
- ? undef # currently no way to inflate a column sharing a name with a rel
- : $rc->column_info($column)->{_inflate_info}{inflate}
- ;
- }
-
- if ($hri_instance->{_inflator_cache}{$rc}{$column}) {
- $data->{$column} = $hri_instance->{_inflator_cache}{$rc}{$column}->($data->{$column});
- }
- }
- }
-};
-
-
=head1 METHODS
-=head2 new
-
- $class->new( %args );
- $class->new({ %args });
-
-Creates a new DBIx::Class::ResultClass::HashRefInflator object. Takes the following
-arguments:
-
-=over
-
-=item inflate_columns
-
-Sometimes you still want all your data to be inflated to the corresponding
-objects according to the rules you defined in your table classes (e.g. you
-want all dates in the resulting hash to be replaced with the equivalent
-DateTime objects). Supplying C<< inflate_columns => 1 >> to the constructor will
-interrogate the processed columns and apply any inflation methods declared
-via L<DBIx::Class::InflateColumn/inflate_column> to the contents of the
-resulting hash-ref.
-
-=back
-
-=cut
-
-sub new {
- my $self = shift;
- my $args = { (ref $_[0] eq 'HASH') ? %{$_[0]} : @_ };
- return bless ($args, $self)
-}
-
=head2 inflate_result
Inflates the result and prefetched data into a hash-ref (invoked by L<DBIx::Class::ResultSet>)
=cut
-
+##################################################################################
+# inflate_result is invoked as:
+# HRI->inflate_result ($resultsource_instance, $main_data_hashref, $prefetch_data_hashref)
sub inflate_result {
- my ($self, $source, $me, $prefetch) = @_;
-
- my $hashref = $mk_hash->($me, $prefetch);
-
- # if $self is an instance and inflate_columns is set
- if ( (ref $self) and $self->{inflate_columns} ) {
- $inflate_hash->($self, $source->schema, $source->result_class, $hashref);
- }
-
- return $hashref;
+ return $mk_hash->($_[2], $_[3]);
}
HashRefInflator only affects resultsets at inflation time, and prefetch causes
relations to be inflated when the master C<$artist> row is inflated.
-=item *
-
-When using C<inflate_columns>, the inflation method lookups are cached in the
-HashRefInflator object for additional speed. If you modify column inflators at run
-time, make sure to grab a new instance of this class to avoid cached surprises.
-
=back
=cut
my $cd = $schema->resultset('CD')->single({ year => 2001 });
Inflates the first result without creating a cursor if the resultset has
-any records in it; if not returns nothing. Used by L</find> as an optimisation.
+any records in it; if not returns nothing. Used by L</find> as a lean version of
+L</search>.
-Can optionally take an additional condition B<only> - this is a fast-code-path
-method; if you need to add extra joins or similar call L</search> and then
-L</single> without a condition on the L<DBIx::Class::ResultSet> returned from
-that.
+While this method can take an optional search condition (just like L</search>)
+being a fast-code-path it does not recognize search attributes. If you need to
+add extra joins or similar, call L</search> and then chain-call L</single> on the
+L<DBIx::Class::ResultSet> returned.
-B<Note>: As of 0.08100, this method assumes that the query returns only one
-row. If more than one row is returned, you will receive a warning:
+=over
+
+=item B<Note>
+
+As of 0.08100, this method enforces the assumption that the preceeding
+query returns only one row. If more than one row is returned, you will receive
+a warning:
Query returned more than one row
-In this case, you should be using L</first> or L</find> instead.
+In this case, you should be using L</first> or L</find> instead, or if you really
+know what you are doing, use the L</rows> attribute to explicitly limit the size
+of the resultset.
+
+=back
=cut
my ($self, $values) = @_;
$self->throw_exception( "new_result needs a hash" )
unless (ref $values eq 'HASH');
- $self->throw_exception(
- "Can't abstract implicit construct, condition not a hash"
- ) if ($self->{cond} && !(ref $self->{cond} eq 'HASH'));
+ my %new;
my $alias = $self->{attrs}{alias};
- my $collapsed_cond = $self->{cond} ? $self->_collapse_cond($self->{cond}) : {};
- # precendence must be given to passed values over values inherited from the cond,
- # so the order here is important.
- my %new;
- my %implied = %{$self->_remove_alias($collapsed_cond, $alias)};
- while( my($col,$value) = each %implied ){
- if(ref($value) eq 'HASH' && keys(%$value) && (keys %$value)[0] eq '='){
- $new{$col} = $value->{'='};
- next;
+ if (
+ defined $self->{cond}
+ && $self->{cond} eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION
+ ) {
+ %new = %{$self->{attrs}{related_objects}};
+ } else {
+ $self->throw_exception(
+ "Can't abstract implicit construct, condition not a hash"
+ ) if ($self->{cond} && !(ref $self->{cond} eq 'HASH'));
+
+ my $collapsed_cond = (
+ $self->{cond}
+ ? $self->_collapse_cond($self->{cond})
+ : {}
+ );
+
+ # precendence must be given to passed values over values inherited from
+ # the cond, so the order here is important.
+ my %implied = %{$self->_remove_alias($collapsed_cond, $alias)};
+ while( my($col,$value) = each %implied ){
+ if(ref($value) eq 'HASH' && keys(%$value) && (keys %$value)[0] eq '='){
+ $new{$col} = $value->{'='};
+ next;
+ }
+ $new{$col} = $value if $self->_is_deterministic_value($value);
}
- $new{$col} = $value if $self->_is_deterministic_value($value);
}
%new = (
}
sub _merge_attr {
- my ($self, $a, $b) = @_;
+ my ($self, $orig, $import) = @_;
- return $b unless defined($a);
- return $a unless defined($b);
+ return $import unless defined($orig);
+ return $orig unless defined($import);
- $a = $self->_rollout_attr($a);
- $b = $self->_rollout_attr($b);
+ $orig = $self->_rollout_attr($orig);
+ $import = $self->_rollout_attr($import);
my $seen_keys;
- foreach my $b_element ( @{$b} ) {
- # find best candidate from $a to merge $b_element into
+ foreach my $import_element ( @{$import} ) {
+ # find best candidate from $orig to merge $b_element into
my $best_candidate = { position => undef, score => 0 }; my $position = 0;
- foreach my $a_element ( @{$a} ) {
- my $score = $self->_calculate_score( $a_element, $b_element );
+ foreach my $orig_element ( @{$orig} ) {
+ my $score = $self->_calculate_score( $orig_element, $import_element );
if ($score > $best_candidate->{score}) {
$best_candidate->{position} = $position;
$best_candidate->{score} = $score;
}
$position++;
}
- my ($b_key) = ( ref $b_element eq 'HASH' ) ? keys %{$b_element} : ($b_element);
+ my ($import_key) = ( ref $import_element eq 'HASH' ) ? keys %{$import_element} : ($import_element);
- if ($best_candidate->{score} == 0 || exists $seen_keys->{$b_key}) {
- push( @{$a}, $b_element );
+ if ($best_candidate->{score} == 0 || exists $seen_keys->{$import_key}) {
+ push( @{$orig}, $import_element );
} else {
- my $a_best = $a->[$best_candidate->{position}];
- # merge a_best and b_element together and replace original with merged
- if (ref $a_best ne 'HASH') {
- $a->[$best_candidate->{position}] = $b_element;
- } elsif (ref $b_element eq 'HASH') {
- my ($key) = keys %{$a_best};
- $a->[$best_candidate->{position}] = { $key => $self->_merge_attr($a_best->{$key}, $b_element->{$key}) };
+ my $orig_best = $orig->[$best_candidate->{position}];
+ # merge orig_best and b_element together and replace original with merged
+ if (ref $orig_best ne 'HASH') {
+ $orig->[$best_candidate->{position}] = $import_element;
+ } elsif (ref $import_element eq 'HASH') {
+ my ($key) = keys %{$orig_best};
+ $orig->[$best_candidate->{position}] = { $key => $self->_merge_attr($orig_best->{$key}, $import_element->{$key}) };
}
}
- $seen_keys->{$b_key} = 1; # don't merge the same key twice
+ $seen_keys->{$import_key} = 1; # don't merge the same key twice
}
- return $a;
+ return $orig;
}
sub result_source {
=cut
+our $UNRESOLVABLE_CONDITION = \'1 = 0';
+
sub resolve_condition {
my ($self, $cond, $as, $for) = @_;
#warn %$cond;
if ($for->in_storage) {
$self->throw_exception("Column ${v} not loaded on ${for} trying to reolve relationship");
}
- return [ \'1 = 0' ];
+ return $UNRESOLVABLE_CONDITION;
}
$ret{$k} = $for->get_column($v);
#$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
$self->_do_connection_actions($connection_do) if ref($connection_do);
$self->_dbh->rollback unless $self->_dbh_autocommit;
-
- # SQLite is evil/brainded and must be DESTROYed without disconnecting: http://www.perlmonks.org/?node_id=666210
- $self->_dbh->disconnect if $self->_dbh->get_info(17) ne 'SQLite';
-
+ $self->_dbh->disconnect;
$self->_dbh(undef);
$self->{_dbh_gen}++;
}
my $order = $attrs->{order_by};
if (ref $condition eq 'SCALAR') {
- $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
+ my $unwrap = ${$condition};
+ if ($unwrap =~ s/ORDER BY (.*)$//i) {
+ $order = $1;
+ $condition = \$unwrap;
+ }
}
my $for = delete $attrs->{for};
}
}
+sub _dbh_last_insert_id {
+ my ($self, $dbh, $source, $col) = @_;
+
+ # punt: if there is no derived class for the specific backend, attempt
+ # to use the DBI->last_insert_id, which may not be sufficient (see the
+ # discussion of last_insert_id in perldoc DBI)
+ return $dbh->last_insert_id(undef, undef, $source->from, $col);
+}
1;
use lib qw(t/lib);
use DBICTest;
-plan tests => 22;
+plan tests => 21;
# perl -le'my $letter = 'a'; for my $i (4..10000) { $letter++; print "[ $i, \"$letter\" ]," }' > tests.txt
is($link7->url, undef, 'Link 7 url');
is($link7->title, 'gtitle', 'Link 7 title');
-
-ok(-f "t/var/DBIxClass.db", 'Database created');
plan tests => 1;
# Set up the "usual" sqlite for DBICTest
-my $normal_schema = DBICTest->init_schema;
+my $normal_schema = DBICTest->init_schema( sqlite_use_file => 1 );
# Steal the dsn, which should be like 'dbi:SQLite:t/var/DBIxClass.db'
my $normal_dsn = $normal_schema->storage->connect_info->[0];
use lib qw(t/lib);
use DBICTest;
-plan tests => 6;
+plan tests => 5;
my $db_orig = "$FindBin::Bin/var/DBIxClass.db";
my $db_tmp = "$db_orig.tmp";
# Set up the "usual" sqlite for DBICTest
-my $schema = DBICTest->init_schema;
+my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
# Make sure we're connected by doing something
my @art = $schema->resultset("Artist")->search({ }, { order_by => 'name DESC'});
cmp_ok(@art, '==', 3, "Three artists returned");
# Disconnect the dbh, and be sneaky about it
-# Also test if DBD::SQLite finaly knows how to ->disconnect properly
-TODO: {
- local $TODO = 'SQLite is evil/braindead. Once this test starts passing, remove the related atrocity from DBIx::Class::Storage::DBI::disconnect()';
- my $w;
- local $SIG{__WARN__} = sub { $w = shift };
- $schema->storage->_dbh->disconnect;
- ok ($w !~ /active statement handles/, 'SQLite can disconnect properly \o/');
-}
+$schema->storage->_dbh->disconnect;
# Try the operation again - What should happen here is:
# 1. S::DBI blindly attempts the SELECT, which throws an exception
chmod 0000, $db_orig;
### Try the operation again... it should fail, since there's no db
-{
- # Catch the DBI connection error (disabling PrintError entirely is unwise)
- local $SIG{__WARN__} = sub {};
- eval {
- my @art_three = $schema->resultset("Artist")->search( {}, { order_by => 'name DESC' } );
- };
- ok( $@, 'The operation failed' );
-}
+eval {
+ my @art_three = $schema->resultset("Artist")->search( {}, { order_by => 'name DESC' } );
+};
+ok( $@, 'The operation failed' );
### Now, move the db file back to the correct name
unlink($db_orig);
my $schema = DBICTest->init_schema();
-plan tests => 63;
+plan tests => 65;
# has_a test
my $cd = $schema->resultset("CD")->find(4);
my $undef_artist_cd = $schema->resultset("CD")->new_result({ 'title' => 'badgers', 'year' => 2007 });
is($undef_artist_cd->has_column_loaded('artist'), '', 'FK not loaded');
is($undef_artist_cd->search_related('artist')->count, 0, '0=1 search when FK does not exist and object not yet in db');
-
+eval{
+ $undef_artist_cd->related_resultset('artist')->new({name => 'foo'});
+};
+is( $@, '', "Object created on a resultset related to not yet inserted object");
+
my $def_artist_cd = $schema->resultset("CD")->new_result({ 'title' => 'badgers', 'year' => 2007, artist => undef });
is($def_artist_cd->has_column_loaded('artist'), 1, 'FK loaded');
is($def_artist_cd->search_related('artist')->count, 0, 'closed search on null FK');
cmp_ok($artist->cds->count, '==', 0, "Correct new #cds for artist");
cmp_ok($nartist->cds->count, '==', 2, "Correct new #cds for artist");
+my $new_artist = $schema->resultset("Artist")->new_result({ 'name' => 'Depeche Mode' });
+# why must i tell him: make a new related from me and me is me? that works!
+# my $new_related_cd = $new_artist->new_related('cds', { 'title' => 'Leave in Silence', 'year' => 1982, 'artist' => $new_artist });
+my $new_related_cd = $new_artist->new_related('cds', { 'title' => 'Leave in Silence', 'year' => 1982});
+eval {
+ $new_artist->insert;
+ $new_related_cd->insert;
+};
+$@ && diag($@);
+ok($new_related_cd->in_storage, 'new_related_cd insert ok');
use Test::More qw(no_plan);
use lib qw(t/lib);
-use Scalar::Util qw/blessed/;
-use DateTime;
use DBICTest;
use DBIx::Class::ResultClass::HashRefInflator;
my $schema = DBICTest->init_schema();
is ($track->get_column ($col), $datahashref->{cds}{tracks}{$col}, "Correct track '$col'");
}
}
-
-# Test the data inflator
-
-is_deeply (
- DBIx::Class::ResultClass::HashRefInflator->new (inflate_columns => 1),
- DBIx::Class::ResultClass::HashRefInflator->new ({inflate_columns => 1}),
- 'Make sure arguments as list and as hashref work identically'
-);
-
-$schema->class('CD')->inflate_column( 'year',
- { inflate => sub { DateTime->new( year => shift ) },
- deflate => sub { shift->year } }
-);
-
-my $cd_rs = $schema->resultset("CD")->search ({cdid => 3});
-$cd_rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
-
-my $cd = $cd_rs->first;
-ok ( (not blessed $cd->{year}), "Plain string returned for year");
-is ( $cd->{year}, '1997', "We are looking at the right year");
-
-# try again with a HRI instance
-$cd_rs->reset;
-$cd_rs->result_class(DBIx::Class::ResultClass::HashRefInflator->new);
-my $cd2 = $cd_rs->first;
-is_deeply ($cd, $cd2, "HRI used as instance returns the same hashref as the old result_class ('class')");
-
-# try it again with inflation requested
-$cd_rs->reset;
-$cd_rs->result_class(DBIx::Class::ResultClass::HashRefInflator->new (inflate_columns => 1));
-my $cd3 = $cd_rs->first;
-isa_ok ($cd3->{year}, 'DateTime', "Inflated object");
-is ($cd3->{year}, DateTime->new ( year => 1997 ), "Correct year was inflated");
use lib qw(t/lib);
use DBICTest;
-my $schema = DBICTest->init_schema();
+my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
eval 'require JSON::Any';
plan skip_all => 'Install JSON::Any to run this test' if ($@);
plan tests => 6;
-my $schema = DBICTest->init_schema();
+my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
is( ref($schema->storage), 'DBIx::Class::Storage::DBI::SQLite',
'Storage reblessed correctly into DBIx::Class::Storage::DBI::SQLite' );
## Get the Schema and set the replication storage type
sub init_schema {
+ # current SQLT SQLite producer does not handle DROP TABLE IF EXISTS, trap warnings here
+ local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /no such table.+DROP TABLE/ };
+
my $class = shift @_;
-
+
my $schema = DBICTest->init_schema(
+ sqlite_use_file => 1,
storage_type=>{
'::DBI::Replicated' => {
balancer_type=>'::Random',
use Test::More;
use File::Spec;
use File::Copy;
+use Time::HiRes qw/time sleep/;
#warn "$dsn $user $pass";
my ($dsn, $user, $pass);
eval "use DBD::mysql; use SQL::Translator 0.09;";
plan $@
? ( skip_all => 'needs DBD::mysql and SQL::Translator 0.09 for testing' )
- : ( tests => 17 );
+ : ( tests => 23 );
}
my $version_table_name = 'dbix_class_schema_versions';
my $old_table_name = 'SchemaVersions';
+my $ddl_dir = File::Spec->catdir ('t', 'var');
+my $fn = {
+ v1 => File::Spec->catfile($ddl_dir, 'DBICVersion-Schema-1.0-MySQL.sql'),
+ v2 => File::Spec->catfile($ddl_dir, 'DBICVersion-Schema-2.0-MySQL.sql'),
+ trans => File::Spec->catfile($ddl_dir, 'DBICVersion-Schema-1.0-2.0-MySQL.sql'),
+};
+
use lib qw(t/lib);
use_ok('DBICVersionOrig');
eval { $schema_orig->storage->dbh->do('drop table ' . $version_table_name) };
eval { $schema_orig->storage->dbh->do('drop table ' . $old_table_name) };
-is($schema_orig->ddl_filename('MySQL', '1.0', 't/var'), File::Spec->catfile('t', 'var', 'DBICVersion-Schema-1.0-MySQL.sql'), 'Filename creation working');
-unlink('t/var/DBICVersion-Schema-1.0-MySQL.sql') if (-e 't/var/DBICVersion-Schema-1.0-MySQL.sql');
-$schema_orig->create_ddl_dir('MySQL', undef, 't/var');
+is($schema_orig->ddl_filename('MySQL', '1.0', $ddl_dir), $fn->{v1}, 'Filename creation working');
+unlink( $fn->{v1} ) if ( -e $fn->{v1} );
+$schema_orig->create_ddl_dir('MySQL', undef, $ddl_dir);
-ok(-f 't/var/DBICVersion-Schema-1.0-MySQL.sql', 'Created DDL file');
+ok(-f $fn->{v1}, 'Created DDL file');
$schema_orig->deploy({ add_drop_table => 1 });
my $tvrs = $schema_orig->{vschema}->resultset('Table');
DBICVersion::Schema->_unregister_source ('Table');
eval "use DBICVersionNew";
+my $schema_upgrade = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 });
{
- unlink('t/var/DBICVersion-Schema-2.0-MySQL.sql');
- unlink('t/var/DBICVersion-Schema-1.0-2.0-MySQL.sql');
+ unlink($fn->{v2});
+ unlink($fn->{trans});
- my $schema_upgrade = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 });
is($schema_upgrade->get_db_version(), '1.0', 'get_db_version ok');
is($schema_upgrade->schema_version, '2.0', 'schema version ok');
- $schema_upgrade->create_ddl_dir('MySQL', '2.0', 't/var', '1.0');
- ok(-f 't/var/DBICVersion-Schema-1.0-2.0-MySQL.sql', 'Created DDL file');
+ $schema_upgrade->create_ddl_dir('MySQL', '2.0', $ddl_dir, '1.0');
+ ok(-f $fn->{trans}, 'Created DDL file');
+
+ {
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ $schema_upgrade->upgrade();
+ like ($w, qr/Attempting upgrade\.$/, 'Warn before upgrade');
+ }
- $schema_upgrade->upgrade();
is($schema_upgrade->get_db_version(), '2.0', 'db version number upgraded');
eval {
};
is($@, '', 'new column created');
- # should overwrite files
- $schema_upgrade->create_ddl_dir('MySQL', '2.0', 't/var', '1.0');
+ # should overwrite files and warn about it
+ my @w;
+ local $SIG{__WARN__} = sub { push @w, shift };
+ $schema_upgrade->create_ddl_dir('MySQL', '2.0', $ddl_dir, '1.0');
+
+ is (2, @w, 'A warning generated for both the DDL and the diff');
+ like ($w[0], qr/^Overwriting existing DDL file - $fn->{v2}/, 'New version DDL overwrite warning');
+ like ($w[1], qr/^Overwriting existing diff file - $fn->{trans}/, 'Upgrade diff overwrite warning');
}
{
is($warn, '', 'warning not detected with attr set');
# should not warn
- $ENV{DBIC_NO_VERSION_CHECK} = 1;
+ local $ENV{DBIC_NO_VERSION_CHECK} = 1;
$warn = '';
$schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
is($warn, '', 'warning not detected with env var set');
like($warn, qr/Your DB is currently unversioned/, 'warning detected without env var or attr');
# should warn
}
+
+# attempt a deploy/upgrade cycle within one second
+{
+ eval { $schema_orig->storage->dbh->do('drop table ' . $version_table_name) };
+ eval { $schema_orig->storage->dbh->do('drop table ' . $old_table_name) };
+ eval { $schema_orig->storage->dbh->do('drop table TestVersion') };
+
+ # this attempts to sleep until the turn of the second
+ my $t = time();
+ sleep (int ($t) + 1 - $t);
+ diag ('Fast deploy/upgrade start: ', time() );
+
+ {
+ local $DBICVersion::Schema::VERSION = '1.0';
+ $schema_orig->deploy;
+ }
+
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ $schema_upgrade->upgrade();
+ like ($w, qr/Attempting upgrade\.$/, 'Warn before upgrade');
+
+ is($schema_upgrade->get_db_version(), '2.0', 'Fast deploy/upgrade');
+}
+
+unless ($ENV{DBICTEST_KEEP_VERSIONING_DDL}) {
+ unlink $_ for (values %$fn);
+}
my $schema = DBICTest->init_schema();
-plan tests => 11;
+plan tests => 10;
my $rs = $schema->resultset('FileColumn');
my $fname = '96file_column.t';
ok ( ! -e $storage, 'storage deleted' );
-TODO: {
- local $TODO = 'need resultset delete override to delete_all';
-
- $fh = $source_file->openr or die "failed to open $source_file: $!\n";
- $fc = $rs->create({ file => { handle => $fh, filename => $fname } });
+$fh = $source_file->openr or die "failed to open $source_file: $!\n";
+$fc = $rs->create({ file => { handle => $fh, filename => $fname } });
- # read it back
- $fc->discard_changes;
+# read it back
+$fc->discard_changes;
- $storage = file(
- $fc->column_info('file')->{file_column_path},
- $fc->id,
- $fc->file->{filename},
- );
- ok ( -e $storage, 'storage exists (2)' );
+$storage = file(
+ $fc->column_info('file')->{file_column_path},
+ $fc->id,
+ $fc->file->{filename},
+);
+TODO: {
+ local $TODO = 'need resultset delete override to delete_all';
$rs->delete;
ok ( ! -e $storage, 'storage does not exist after $rs->delete' );
};
}
sub _sqlite_dbfilename {
- return "t/var/DBIxClass.db";
+ return "t/var/DBIxClass.db";
+}
+
+sub _sqlite_dbname {
+ my $self = shift;
+ my %args = @_;
+ return $self->_sqlite_dbfilename if $args{sqlite_use_file} or $ENV{"DBICTEST_SQLITE_USE_FILE"};
+ return ":memory:";
}
sub _database {
my $self = shift;
- my $db_file = $self->_sqlite_dbfilename;
+ my %args = @_;
+ my $db_file = $self->_sqlite_dbname(%args);
unlink($db_file) if -e $db_file;
unlink($db_file . "-journal") if -e $db_file . "-journal";
my %args = @_;
my $schema;
-
+
if ($args{compose_connection}) {
$schema = DBICTest::Schema->compose_connection(
- 'DBICTest', $self->_database
+ 'DBICTest', $self->_database(%args)
);
} else {
$schema = DBICTest::Schema->compose_namespace('DBICTest');
$schema->storage_type($args{storage_type});
}
if ( !$args{no_connect} ) {
- $schema = $schema->connect($self->_database);
+ $schema = $schema->connect($self->_database(%args));
$schema->storage->on_connect_do(['PRAGMA synchronous = OFF'])
unless $self->has_custom_dsn;
}
projects / dbsrgits/DBIx-Class.git / commitdiff