__PACKAGE__->mk_group_accessors( 'simple' => qw/config_dir
_inherited_attributes debug schema_class dumped_objects config_attrs/);
-our $VERSION = '1.001028';
+our $VERSION = '1.001036';
$VERSION = eval $VERSION;
$tmp_output_dir->file('_config_set')->print( Dumper $config );
$config->{rules} ||= {};
- my @sources = sort { $a->{class} cmp $b->{class} } @{delete $config->{sets}};
+ my @sources = @{delete $config->{sets}};
while ( my ($k,$v) = each %{ $config->{rules} } ) {
if ( my $source = eval { $schema->source($k) } ) {
# do the actual dumping
my $serialized = Dump(\%ds)->Out();
+
$file->print($serialized);
}
$fixup_visitor = new Data::Visitor::Callback(%callbacks);
}
+ my @sorted_source_names = $self->_get_sorted_sources( $schema );
$schema->storage->txn_do(sub {
$schema->storage->with_deferred_fk_checks(sub {
- foreach my $source (sort $schema->sources) {
+ foreach my $source (@sorted_source_names) {
$self->msg("- adding " . $source);
my $rs = $schema->resultset($source);
my $source_dir = io->catdir($tmp_fixture_dir, $self->_name_for_source($rs->result_source));
## Now we need to do some db specific cleanup
## this probably belongs in a more isolated space. Right now this is
## to just handle postgresql SERIAL types that use Sequences
+ ## Will completely ignore sequences in Oracle due to having to drop
+ ## and recreate them
my $table = $rs->result_source->name;
for my $column(my @columns = $rs->result_source->columns) {
$self->msg("- updating sequence $sequence");
$rs->result_source->storage->dbh_do(sub {
my ($storage, $dbh, @cols) = @_;
- $self->msg(my $sql = "SELECT setval('${sequence}', (SELECT max($column) FROM ${table}));");
- my $sth = $dbh->prepare($sql);
- my $rv = $sth->execute or die $sth->errstr;
- $self->msg("- $sql");
+ if ( $dbh->{Driver}->{Name} eq "Oracle" ) {
+ $self->msg("- Cannot change sequence values in Oracle");
+ } else {
+ $self->msg(
+ my $sql = sprintf("SELECT setval(?, (SELECT max(%s) FROM %s));",$dbh->quote_identifier($column),$dbh->quote_identifier($table))
+ );
+ my $sth = $dbh->prepare($sql);
+ $sth->bind_param(1,$sequence);
+
+ my $rv = $sth->execute or die $sth->errstr;
+ $self->msg("- $sql");
+ }
});
}
}
return 1;
}
+# the overall logic is modified from SQL::Translator::Parser::DBIx::Class->parse
+sub _get_sorted_sources {
+ my ( $self, $dbicschema ) = @_;
+
+
+ my %table_monikers = map { $_ => 1 } $dbicschema->sources;
+
+ my %tables;
+ foreach my $moniker (sort keys %table_monikers) {
+ my $source = $dbicschema->source($moniker);
+
+ my $table_name = $source->name;
+ my @primary = $source->primary_columns;
+ my @rels = $source->relationships();
+
+ my %created_FK_rels;
+ foreach my $rel (sort @rels) {
+ my $rel_info = $source->relationship_info($rel);
+
+ # Ignore any rel cond that isn't a straight hash
+ next unless ref $rel_info->{cond} eq 'HASH';
+
+ my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} keys(%{$rel_info->{cond}});
+
+ # determine if this relationship is a self.fk => foreign.pk (i.e. belongs_to)
+ my $fk_constraint;
+ if ( exists $rel_info->{attrs}{is_foreign_key_constraint} ) {
+ $fk_constraint = $rel_info->{attrs}{is_foreign_key_constraint};
+ } elsif ( $rel_info->{attrs}{accessor}
+ && $rel_info->{attrs}{accessor} eq 'multi' ) {
+ $fk_constraint = 0;
+ } else {
+ $fk_constraint = not $source->_compare_relationship_keys(\@keys, \@primary);
+ }
+
+ # Dont add a relation if its not constraining
+ next unless $fk_constraint;
+
+ my $rel_table = $source->related_source($rel)->source_name;
+ # Make sure we don't create the same relation twice
+ my $key_test = join("\x00", sort @keys);
+ next if $created_FK_rels{$rel_table}->{$key_test};
+
+ if (scalar(@keys)) {
+ $created_FK_rels{$rel_table}->{$key_test} = 1;
+
+ # calculate dependencies: do not consider deferrable constraints and
+ # self-references for dependency calculations
+ if (! $rel_info->{attrs}{is_deferrable} and $rel_table ne $table_name) {
+ $tables{$moniker}{$rel_table}++;
+ }
+ }
+ }
+ $tables{$moniker} = {} unless exists $tables{$moniker};
+ }
+
+ # resolve entire dep tree
+ my $dependencies = {
+ map { $_ => _resolve_deps ($_, \%tables) } (keys %tables)
+ };
+
+ # return the sorted result
+ return sort {
+ keys %{$dependencies->{$a} || {} } <=> keys %{ $dependencies->{$b} || {} }
+ ||
+ $a cmp $b
+ } (keys %tables);
+}
+
+sub _resolve_deps {
+ my ( $question, $answers, $seen ) = @_;
+ my $ret = {};
+ $seen ||= {};
+
+ my %seen = map { $_ => $seen->{$_} + 1 } ( keys %$seen );
+ $seen{$question} = 1;
+
+ for my $dep (keys %{ $answers->{$question} }) {
+ return {} if $seen->{$dep};
+ my $subdeps = _resolve_deps( $dep, $answers, \%seen );
+ $ret->{$_} += $subdeps->{$_} for ( keys %$subdeps );
+ ++$ret->{$dep};
+ }
+ return $ret;
+}
+
sub do_post_ddl {
my ($self, $params) = @_;
Matt S. Trout <mst@shadowcatsystems.co.uk>
+ John Napiorkowski <jjnapiork@cpan.org>
+
Drew Taylor <taylor.andrew.j@gmail.com>
Frank Switalski <fswitalski@gmail.com>
Chris Akins <chris.hexx@gmail.com>
+ Tom Bloor <t.bloor@shadowcat.co.uk>
+
+ Samuel Kaufman <skaufman@cpan.org>
+
=head1 LICENSE
This library is free software under the same license as perl itself
projects / dbsrgits/DBIx-Class-Fixtures.git / blobdiff