__PACKAGE__->mk_group_accessors( 'simple' => qw/config_dir
_inherited_attributes debug schema_class dumped_objects config_attrs/);
-our $VERSION = '1.001_029';
+our $VERSION = '1.001037';
$VERSION = eval $VERSION;
$fixtures->dump({
all => 1, # just dump everything that's in the schema
schema => $source_dbic_schema,
- directory => '/home/me/app/fixtures' # output directory
+ directory => '/home/me/app/fixtures', # output directory
+ #excludes => [ qw/Foo MyView/ ], # optionally exclude certain sources
});
In this case objects will be dumped to subdirectories in the specified
/home/me/app/fixtures/artist/3.fix
/home/me/app/fixtures/producer/5.fix
-schema and directory are required attributes. also, one of config or all must
+C<schema> and C<directory> are required attributes. also, one of C<config> or C<all> must
be specified.
+The optional parameter C<excludes> takes an array ref of source names and can be
+used to exclue those sources when dumping the whole schema. This is useful if
+you have views in there, since those do not need fixtures and will currently result
+in an error when they are created and then used with C<populate>.
+
Lastly, the C<config> parameter can be a Perl HashRef instead of a file name.
If this form is used your HashRef should conform to the structure rules defined
for the JSON representations.
# write file
unless ($exists) {
$self->msg('-- dumping ' . "$file", 2);
- my %ds = $object->get_columns;
+
+ # get_columns will return virtual columns; we just want stored columns.
+ # columns_info keys seems to be the actual storage column names, so we'll
+ # use that.
+ my $col_info = $src->columns_info;
+ my @column_names = keys %$col_info;
+ my %columns = $object->get_columns;
+ my %ds; @ds{@column_names} = @columns{@column_names};
if($set->{external}) {
foreach my $field (keys %{$set->{external}}) {
$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 {
-
- use SQL::Translator;
-
- # parse the schema with SQL::Translator
- my $sqlt = SQL::Translator->new(
- parser => 'SQL::Translator::Parser::DBIx::Class',
- parser_args => {
- dbic_schema => $schema,
- },
- );
- $sqlt->translate;
-
- # pull out the SQLT Schema, and create a hash with the correct order for tables
- my $sqlt_schema = $sqlt->schema;
- my %table_order = map +($_->name => $_->order - 1), $sqlt_schema->get_tables;
-
- # create an array using the correct table order
- my @sorted_source_names;
- for my $source ( $schema->sources ) {
- next unless $source; # somehow theres an undef one
- my $table = $schema->source( $source )->name;
- $sorted_source_names[ $table_order{ $table } ] = $source;
- }
-
foreach my $source (@sorted_source_names) {
$self->msg("- adding " . $source);
my $rs = $schema->resultset($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
=cut
-1;
+1;
\ No newline at end of file
projects / dbsrgits/DBIx-Class-Fixtures.git / blobdiff