use warnings;
use DBIx::Class::Exception;
-use Class::Accessor;
+use Class::Accessor::Grouped;
use Path::Class qw(dir file);
use File::Slurp;
use Config::Any::JSON;
use File::Copy qw/move/;
use Hash::Merge qw( merge );
use Data::Dumper;
+use Class::C3::Componentised;
-use base qw(Class::Accessor);
+use base qw(Class::Accessor::Grouped);
-__PACKAGE__->mk_accessors(qw(config_dir _inherited_attributes debug schema_class ));
+our $namespace_counter = 0;
+
+__PACKAGE__->mk_group_accessors( 'simple' => qw/config_dir _inherited_attributes debug schema_class/);
=head1 VERSION
-Version 1.000
+Version 1.000001
=cut
-our $VERSION = '1.000';
+our $VERSION = '1.000001';
=head1 NAME
$fixtures->populate({
directory => '/home/me/app/fixtures',
ddl => '/home/me/app/sql/ddl.sql',
- connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password']
+ connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password'],
+ post_ddl => '/home/me/app/sql/post_ddl.sql',
});
=head1 DESCRIPTION
-=head1 AUTHOR
+Dump fixtures from source database to filesystem then import to another database (with same schema)
+at any time. Use as a constant dataset for running tests against or for populating development databases
+when impractical to use production clones. Describe fixture set using relations and conditions based
+on your DBIx::Class schema.
+
+=head1 DEFINE YOUR FIXTURE SET
+
+Fixture sets are currently defined in .json files which must reside in your config_dir
+(e.g. /home/me/app/fixture_configs/a_fixture_set.json). They describe which data to pull and dump
+from the source database.
+
+For example:
+
+ {
+ sets: [{
+ class: 'Artist',
+ ids: ['1', '3']
+ }, {
+ class: 'Producer',
+ ids: ['5'],
+ fetch: [{
+ rel: 'artists',
+ quantity: '2'
+ }]
+ }]
+ }
+
+This will fetch artists with primary keys 1 and 3, the producer with primary key 5 and two of producer 5's
+artists where 'artists' is a has_many DBIx::Class rel from Producer to Artist.
+
+The top level attributes are as follows:
+
+=head2 sets
+
+Sets must be an array of hashes, as in the example given above. Each set defines a set of objects to be
+included in the fixtures. For details on valid set attributes see L</SET ATTRIBUTES> below.
+
+=head2 rules
+
+Rules place general conditions on classes. For example if whenever an artist was dumped you also wanted all
+of their cds dumped too, then you could use a rule to specify this. For example:
+
+ {
+ sets: [{
+ class: 'Artist',
+ ids: ['1', '3']
+ }, {
+ class: 'Producer',
+ ids: ['5'],
+ fetch: [{
+ rel: 'artists',
+ quantity: '2'
+ }]
+ }],
+ rules: {
+ Artist: {
+ fetch: [{
+ rel: 'cds',
+ quantity: 'all'
+ }]
+ }
+ }
+ }
-Luke Saunders <luke@shadowcatsystems.co.uk>
+In this case all the cds of artists 1, 3 and all producer 5's artists will be dumped as well. Note that 'cds' is a
+has_many DBIx::Class relation from Artist to CD. This is eqivalent to:
+
+ {
+ sets: [{
+ class: 'Artist',
+ ids: ['1', '3'],
+ fetch: [{
+ rel: 'cds',
+ quantity: 'all'
+ }]
+ }, {
+ class: 'Producer',
+ ids: ['5'],
+ fetch: [{
+ rel: 'artists',
+ quantity: '2',
+ fetch: [{
+ rel: 'cds',
+ quantity: 'all'
+ }]
+ }]
+ }]
+ }
-=head1 CONTRIBUTORS
+rules must be a hash keyed by class name.
+
+L</RULE ATTRIBUTES>
+
+=head2 includes
+
+To prevent repetition between configs you can include other configs. For example:
+
+ {
+ sets: [{
+ class: 'Producer',
+ ids: ['5']
+ }],
+ includes: [{
+ file: 'base.json'
+ }]
+ }
+
+Includes must be an arrayref of hashrefs where the hashrefs have key 'file' which is the name of another config
+file in the same directory. The original config is merged with its includes using Hash::Merge.
+
+=head2 datetime_relative
+
+Only available for MySQL and PostgreSQL at the moment, must be a value that DateTime::Format::*
+can parse. For example:
+
+ {
+ sets: [{
+ class: 'RecentItems',
+ ids: ['9']
+ }],
+ datetime_relative : "2007-10-30 00:00:00"
+ }
+
+This will work when dumping from a MySQL database and will cause any datetime fields (where datatype => 'datetime'
+in the column def of the schema class) to be dumped as a DateTime::Duration object relative to the date specified in
+the datetime_relative value. For example if the RecentItem object had a date field set to 2007-10-25, then when the
+fixture is imported the field will be set to 5 days in the past relative to the current time.
+
+=head2 might_have
+
+Specifies whether to automatically dump might_have relationships. Should be a hash with one attribute - fetch. Set fetch to 1 or 0.
+
+ {
+ might_have: [{
+ fetch: 1
+ },
+ sets: [{
+ class: 'Artist',
+ ids: ['1', '3']
+ }, {
+ class: 'Producer',
+ ids: ['5']
+ }]
+ }
+
+Note: belongs_to rels are automatically dumped whether you like it or not, this is to avoid FKs to nowhere when importing.
+General rules on has_many rels are not accepted at this top level, but you can turn them on for individual
+sets - see L</SET ATTRIBUTES>.
+
+=head1 SET ATTRIBUTES
+
+=head2 class
+
+Required attribute. Specifies the DBIx::Class object class you wish to dump.
+
+=head2 ids
+
+Array of primary key ids to fetch, basically causing an $rs->find($_) for each. If the id is not in the source db then it
+just won't get dumped, no warnings or death.
+
+=head2 quantity
+
+Must be either an integer or the string 'all'. Specifying an integer will effectively set the 'rows' attribute on the resultset clause,
+specifying 'all' will cause the rows attribute to be left off and for all matching rows to be dumped. There's no randomising
+here, it's just the first x rows.
+
+=head2 cond
+
+A hash specifying the conditions dumped objects must match. Essentially this is a JSON representation of a DBIx::Class search clause. For example:
+
+ {
+ sets: [{
+ class: 'Artist',
+ quantiy: 'all',
+ cond: { name: 'Dave' }
+ }]
+ }
+
+This will dump all artists whose name is 'dave'. Essentially $artist_rs->search({ name => 'Dave' })->all.
+
+Sometimes in a search clause it's useful to use scalar refs to do things like:
+
+$artist_rs->search({ no1_singles => \'> no1_albums' })
+
+This could be specified in the cond hash like so:
+
+ {
+ sets: [{
+ class: 'Artist',
+ quantiy: 'all',
+ cond: { no1_singles: '\> no1_albums' }
+ }]
+ }
+
+So if the value starts with a backslash the value is made a scalar ref before being passed to search.
+
+=head2 join
+
+An array of relationships to be used in the cond clause.
+
+ {
+ sets: [{
+ class: 'Artist',
+ quantiy: 'all',
+ cond: { 'cds.position': { '>': 4 } },
+ join: ['cds']
+ }]
+ }
+
+Fetch all artists who have cds with position greater than 4.
+
+=head2 fetch
+
+Must be an array of hashes. Specifies which rels to also dump. For example:
+
+ {
+ sets: [{
+ class: 'Artist',
+ ids: ['1', '3'],
+ fetch: [{
+ rel: 'cds',
+ quantity: '3',
+ cond: { position: '2' }
+ }]
+ }]
+ }
+
+Will cause the cds of artists 1 and 3 to be dumped where the cd position is 2.
+
+Valid attributes are: 'rel', 'quantity', 'cond', 'has_many', 'might_have' and 'join'. rel is the name of the DBIx::Class
+rel to follow, the rest are the same as in the set attributes. quantity is necessary for has_many relationships,
+but not if using for belongs_to or might_have relationships.
+
+=head2 has_many
+
+Specifies whether to fetch has_many rels for this set. Must be a hash containing keys fetch and quantity.
+
+Set fetch to 1 if you want to fetch them, and quantity to either 'all' or an integer.
+
+Be careful here, dumping has_many rels can lead to a lot of data being dumped.
+
+=head2 might_have
+
+As with has_many but for might_have relationships. Quantity doesn't do anything in this case.
+
+This value will be inherited by all fetches in this set. This is not true for the has_many attribute.
+
+=head1 RULE ATTRIBUTES
+
+=head2 cond
+
+Same as with L</SET ATTRIBUTES>
+
+=head2 fetch
+
+Same as with L</SET ATTRIBUTES>
+
+=head2 join
+
+Same as with L</SET ATTRIBUTES>
+
+=head2 has_many
+
+Same as with L</SET ATTRIBUTES>
+
+=head2 might_have
+
+Same as with L</SET ATTRIBUTES>
=head1 METHODS
=head2 new
+=over 4
+
+=item Arguments: \%$attrs
+
+=item Return Value: $fixture_object
+
+=back
+
+Returns a new DBIx::Class::Fixture object. %attrs has only two valid keys at the
+moment - 'debug' which determines whether to be verbose and 'config_dir' which is required and much contain a valid path to
+the directory in which your .json configs reside.
+
+ my $fixtures = DBIx::Class::Fixtures->new({ config_dir => '/home/me/app/fixture_configs' });
+
=cut
sub new {
=head2 dump
+=over 4
+
+=item Arguments: \%$attrs
+
+=item Return Value: 1
+
+=back
+
+ $fixtures->dump({
+ config => 'set_config.json', # config file to use. must be in the config directory specified in the constructor
+ schema => $source_dbic_schema,
+ directory => '/home/me/app/fixtures' # output directory
+ });
+
+ or
+
+ $fixtures->dump({
+ all => 1, # just dump everything that's in the schema
+ schema => $source_dbic_schema,
+ directory => '/home/me/app/fixtures' # output directory
+ });
+
+In this case objects will be dumped to subdirectories in the specified directory. For example:
+
+ /home/me/app/fixtures/artist/1.fix
+ /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 be specified.
+
=cut
sub dump {
return DBIx::Class::Exception->throw('first arg to dump must be hash ref');
}
- foreach my $param (qw/config schema directory/) {
+ foreach my $param (qw/schema directory/) {
unless ($params->{$param}) {
return DBIx::Class::Exception->throw($param . ' param not specified');
}
}
- my $config_file = file($self->config_dir, $params->{config});
- unless (-e $config_file) {
- return DBIx::Class::Exception->throw('config does not exist at ' . $config_file);
- }
+ my $schema = $params->{schema};
+ my $config_file;
+ my $config;
+ if ($params->{config}) {
+ #read config
+ $config_file = file($self->config_dir, $params->{config});
+ unless (-e $config_file) {
+ return DBIx::Class::Exception->throw('config does not exist at ' . $config_file);
+ }
+ $config = Config::Any::JSON->load($config_file);
- my $config = Config::Any::JSON->load($config_file);
- unless ($config && $config->{sets} && ref $config->{sets} eq 'ARRAY' && scalar(@{$config->{sets}})) {
- return DBIx::Class::Exception->throw('config has no sets');
+ #process includes
+ if ($config->{includes}) {
+ $self->msg($config->{includes});
+ unless (ref $config->{includes} eq 'ARRAY') {
+ return DBIx::Class::Exception->throw('includes params of config must be an array ref of hashrefs');
+ }
+ foreach my $include_config (@{$config->{includes}}) {
+ unless ((ref $include_config eq 'HASH') && $include_config->{file}) {
+ return DBIx::Class::Exception->throw('includes params of config must be an array ref of hashrefs');
+ }
+
+ my $include_file = file($self->config_dir, $include_config->{file});
+ unless (-e $include_file) {
+ return DBIx::Class::Exception->throw('config does not exist at ' . $include_file);
+ }
+ my $include = Config::Any::JSON->load($include_file);
+ $self->msg($include);
+ $config = merge( $config, $include );
+ }
+ delete $config->{includes};
+ }
+
+ # validate config
+ unless ($config && $config->{sets} && ref $config->{sets} eq 'ARRAY' && scalar(@{$config->{sets}})) {
+ return DBIx::Class::Exception->throw('config has no sets');
+ }
+
+ $config->{might_have} = { fetch => 0 } unless (exists $config->{might_have});
+ $config->{has_many} = { fetch => 0 } unless (exists $config->{has_many});
+ $config->{belongs_to} = { fetch => 1 } unless (exists $config->{belongs_to});
+ } elsif ($params->{all}) {
+ $config = { might_have => { fetch => 0 }, has_many => { fetch => 0 }, belongs_to => { fetch => 0 }, sets => [map {{ class => $_, quantity => 'all' }} $schema->sources] };
+ print Dumper($config);
+ } else {
+ return DBIx::Class::Exception->throw('must pass config or set all');
}
my $output_dir = dir($params->{directory});
unless (-e $output_dir) {
- return DBIx::Class::Exception->throw('output directory does not exist at ' . $output_dir);
+ $output_dir->mkpath ||
+ return DBIx::Class::Exception->throw('output directory does not exist at ' . $output_dir);
}
- my $schema = $params->{schema};
-
$self->msg("generating fixtures");
- my $tmp_output_dir = dir($output_dir, '-~dump~-');
+ my $tmp_output_dir = dir($output_dir, '-~dump~-' . $<);
if (-e $tmp_output_dir) {
$self->msg("- clearing existing $tmp_output_dir");
$source = merge( $source, $rule ) if ($rule);
# fetch objects
- my $rs = $schema->resultset($source->{class});
- $rs = $rs->search($source->{cond}, { join => $source->{join} }) if ($source->{cond});
+ my $rs = $schema->resultset($source->{class});
+ $rs = $rs->search($source->{cond}, { join => $source->{join} }) if ($source->{cond});
$self->msg("- dumping $source->{class}");
my @objects;
my %source_options = ( set => { %{$config}, %{$source} } );
$self->msg('-- dumping ' . $file->stringify, 2);
my %ds = $object->get_columns;
+ my $formatter= $object->result_source->schema->storage->datetime_parser;
# mess with dates if specified
- if ($set->{datetime_relative}) {
- my $dt;
- if ($set->{datetime_relative} eq 'today') {
- $dt = DateTime->today;
- } else {
- require DateTime::Format::MySQL;
- $dt = DateTime::Format::MySQL->parse_datetime($set->{datetime_relative});
- }
+ if ($set->{datetime_relative}) {
+ unless ($@ || !$formatter) {
+ my $dt;
+ if ($set->{datetime_relative} eq 'today') {
+ $dt = DateTime->today;
+ } else {
+ $dt = $formatter->parse_datetime($set->{datetime_relative}) unless ($@);
+ }
- while (my ($col, $value) = each %ds) {
- my $col_info = $object->result_source->column_info($col);
+ while (my ($col, $value) = each %ds) {
+ my $col_info = $object->result_source->column_info($col);
- next unless $value
- && $col_info->{_inflate_info}
- && uc($col_info->{data_type}) eq 'DATETIME';
+ next unless $value
+ && $col_info->{_inflate_info}
+ && uc($col_info->{data_type}) eq 'DATETIME';
- $ds{$col} = $object->get_inflated_column($col)->subtract_datetime($dt);
+ $ds{$col} = $object->get_inflated_column($col)->subtract_datetime($dt);
+ }
+ } else {
+ warn "datetime_relative not supported for this db driver at the moment";
}
}
my $mode = 0777; chmod $mode, $file->stringify;
}
+ # don't bother looking at rels unless we are actually planning to dump at least one type
+ return unless ($set->{might_have}->{fetch} || $set->{belongs_to}->{fetch} || $set->{has_many}->{fetch} || $set->{fetch});
+
# dump rels of object
my $s = $object->result_source;
unless ($exists) {
my $pre_schema;
my $connection_details = $params->{connection_details};
- unless( $pre_schema = $schema_class->connect(@{$connection_details}) ) {
+ $namespace_counter++;
+ my $namespace = "DBIx::Class::Fixtures::GeneratedSchema_" . $namespace_counter;
+ Class::C3::Componentised->inject_base( $namespace => $schema_class );
+ $pre_schema = $namespace->connect(@{$connection_details});
+ unless( $pre_schema ) {
return DBIx::Class::Exception->throw('connection details not valid');
}
- my @tables = map { $pre_schema->source($_)->from }$pre_schema->sources;
+ my @tables = map { $pre_schema->source($_)->from } $pre_schema->sources;
+ $self->msg("Tables to drop: [". join(', ', sort @tables) . "]");
my $dbh = $pre_schema->storage->dbh;
# clear existing db
$self->msg("- clearing DB of existing tables");
eval { $dbh->do('SET foreign_key_checks=0') };
- $dbh->do('drop table ' . $_) for (@tables);
+ foreach my $table (@tables) {
+ eval { $dbh->do('drop table ' . $table . ($params->{cascade} ? ' cascade' : '') ) };
+ }
# import new ddl file to db
my $ddl_file = $params->{ddl};
$self->msg("- deploying schema using $ddl_file");
+ my $data = _read_sql($ddl_file);
+ foreach (@$data) {
+ eval { $dbh->do($_) or warn "SQL was:\n $_"};
+ if ($@) { die "SQL was:\n $_\n$@"; }
+ }
+ $self->msg("- finished importing DDL into DB");
+
+ # load schema object from our new DB
+ $namespace_counter++;
+ my $namespace2 = "DBIx::Class::Fixtures::GeneratedSchema_" . $namespace_counter;
+ Class::C3::Componentised->inject_base( $namespace2 => $schema_class );
+ my $schema = $namespace2->connect(@{$connection_details});
+ return $schema;
+}
+
+sub _read_sql {
+ my $ddl_file = shift;
my $fh;
open $fh, "<$ddl_file" or die ("Can't open DDL file, $ddl_file ($!)");
my @data = split(/\n/, join('', <$fh>));
@data = split(/;/, join('', @data));
close($fh);
@data = grep { $_ && $_ !~ /^-- / } @data;
- for (@data) {
- eval { $dbh->do($_) or warn "SQL was:\n $_"};
- if ($@) { die "SQL was:\n $_\n$@"; }
- }
- $self->msg("- finished importing DDL into DB");
-
- # load schema object from our new DB
- $self->msg("- loading fresh DBIC object from DB");
- my $schema = $schema_class->connect(@{$connection_details});
- return $schema;
+ return \@data;
}
+=head2 populate
+
+=over 4
+
+=item Arguments: \%$attrs
+
+=item Return Value: 1
+
+=back
+
+ $fixtures->populate({
+ directory => '/home/me/app/fixtures', # directory to look for fixtures in, as specified to dump
+ ddl => '/home/me/app/sql/ddl.sql', # DDL to deploy
+ connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password'], # database to clear, deploy and then populate
+ post_ddl => '/home/me/app/sql/post_ddl.sql', # DDL to deploy after populating records, ie. FK constraints
+ cascade => 1, # use CASCADE option when dropping tables
+ });
+
+In this case the database app_dev will be cleared of all tables, then the specified DDL deployed to it,
+then finally all fixtures found in /home/me/app/fixtures will be added to it. populate will generate
+its own DBIx::Class schema from the DDL rather than being passed one to use. This is better as
+custom insert methods are avoided which can to get in the way. In some cases you might not
+have a DDL, and so this method will eventually allow a $schema object to be passed instead.
+
+If needed, you can specify a post_ddl attribute which is a DDL to be applied after all the fixtures
+have been added to the database. A good use of this option would be to add foreign key constraints
+since databases like Postgresql cannot disable foreign key checks.
+
+If your tables have foreign key constraints you may want to use the cascade attribute which will
+make the drop table functionality cascade, ie 'DROP TABLE $table CASCADE'.
+
+directory, dll and connection_details are all required attributes.
+
+=cut
+
sub populate {
my $self = shift;
my ($params) = @_;
$tmp_fixture_dir->rmtree;
}
$self->msg("- creating temp dir");
- dircopy(dir($fixture_dir, $schema->source($_)->from), dir($tmp_fixture_dir, $schema->source($_)->from)) for $schema->sources;
+ dircopy(dir($fixture_dir, $schema->source($_)->from), dir($tmp_fixture_dir, $schema->source($_)->from)) for grep { -e dir($fixture_dir, $schema->source($_)->from) } $schema->sources;
eval { $schema->storage->dbh->do('SET foreign_key_checks=0') };
+
my $fixup_visitor;
- my %callbacks;
- if ($params->{datetime_relative_to}) {
- $callbacks{'DateTime::Duration'} = sub {
- $params->{datetime_relative_to}->clone->add_duration($_);
- };
- } else {
- $callbacks{'DateTime::Duration'} = sub {
- DateTime->today->add_duration($_)
- };
+ my $formatter= $schema->storage->datetime_parser;
+ unless ($@ || !$formatter) {
+ my %callbacks;
+ if ($params->{datetime_relative_to}) {
+ $callbacks{'DateTime::Duration'} = sub {
+ $params->{datetime_relative_to}->clone->add_duration($_);
+ };
+ } else {
+ $callbacks{'DateTime::Duration'} = sub {
+ $formatter->format_datetime(DateTime->today->add_duration($_))
+ };
+ }
+ $callbacks{object} ||= "visit_ref";
+ $fixup_visitor = new Data::Visitor::Callback(%callbacks);
}
- $callbacks{object} ||= "visit_ref";
- $fixup_visitor = new Data::Visitor::Callback(%callbacks);
-
foreach my $source (sort $schema->sources) {
$self->msg("- adding " . $source);
my $rs = $schema->resultset($source);
my $HASH1;
eval($contents);
$HASH1 = $fixup_visitor->visit($HASH1) if $fixup_visitor;
- $rs->find_or_create($HASH1);
+ $rs->create($HASH1);
+ }
+ }
+
+ if ($params->{post_ddl}) {
+ my $data = _read_sql($params->{post_ddl});
+ foreach (@$data) {
+ eval { $schema->storage->dbh->do($_) or warn "SQL was:\n $_"};
+ if ($@) { die "SQL was:\n $_\n$@"; }
}
+ $self->msg("- finished importing post-populate DDL into DB");
}
$self->msg("- fixtures imported");
$self->msg("- cleaning up");
$tmp_fixture_dir->rmtree;
eval { $schema->storage->dbh->do('SET foreign_key_checks=1') };
+
+ return 1;
}
sub msg {
my $self = shift;
my $subject = shift || return;
my $level = shift || 1;
-
return unless $self->debug >= $level;
if (ref $subject) {
print Dumper($subject);
print $subject . "\n";
}
}
+
+=head1 AUTHOR
+
+ Luke Saunders <luke@shadowcatsystems.co.uk>
+
+ Initial development sponsored by and (c) Takkle, Inc. 2007
+
+=head1 CONTRIBUTORS
+
+ Ash Berlin <ash@shadowcatsystems.co.uk>
+ Matt S. Trout <mst@shadowcatsystems.co.uk>
+
+=head1 LICENSE
+
+ This library is free software under the same license as perl itself
+
+=cut
+
1;
projects / dbsrgits/DBIx-Class-Fixtures.git / blobdiff