fixed SQLite dep and dir copy test failure
[dbsrgits/DBIx-Class-Fixtures.git] / lib / DBIx / Class / Fixtures.pm
CommitLineData
e5963c1b 1package DBIx::Class::Fixtures;
2
3use strict;
4use warnings;
5
6use DBIx::Class::Exception;
b099fee9 7use Class::Accessor::Grouped;
e5963c1b 8use Path::Class qw(dir file);
6116de11 9use File::Slurp;
0fc424b7 10use Config::Any::JSON;
11use Data::Dump::Streamer;
4fb695f4 12use Data::Visitor::Callback;
0fc424b7 13use File::Path;
4fb695f4 14use File::Copy::Recursive qw/dircopy/;
6116de11 15use File::Copy qw/move/;
0fc424b7 16use Hash::Merge qw( merge );
e5963c1b 17use Data::Dumper;
aa9f3cc7 18use Class::C3::Componentised;
e5963c1b 19
b099fee9 20use base qw(Class::Accessor::Grouped);
e5963c1b 21
aa9f3cc7 22our $namespace_counter = 0;
0566a82d 23
b099fee9 24__PACKAGE__->mk_group_accessors( 'simple' => qw/config_dir _inherited_attributes debug schema_class/);
e5963c1b 25
26=head1 VERSION
27
4d7408dd 28Version 1.000000
e5963c1b 29
30=cut
31
4d7408dd 32our $VERSION = '1.000000';
e5963c1b 33
34=head1 NAME
35
9f96b203 36DBIx::Class::Fixtures
37
e5963c1b 38=head1 SYNOPSIS
39
40 use DBIx::Class::Fixtures;
41
42 ...
43
44 my $fixtures = DBIx::Class::Fixtures->new({ config_dir => '/home/me/app/fixture_configs' });
45
46 $fixtures->dump({
47 config => 'set_config.json',
48 schema => $source_dbic_schema,
49 directory => '/home/me/app/fixtures'
50 });
51
52 $fixtures->populate({
53 directory => '/home/me/app/fixtures',
54 ddl => '/home/me/app/sql/ddl.sql',
55 connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password']
56 });
57
58=head1 DESCRIPTION
59
b099fee9 60Dump fixtures from source database to filesystem then import to another database (with same schema)
61at any time. Use as a constant dataset for running tests against or for populating development databases
62when impractical to use production clones. Describe fixture set using relations and conditions based
63on your DBIx::Class schema.
a5561f96 64
65=head1 DEFINE YOUR FIXTURE SET
66
b099fee9 67Fixture sets are currently defined in .json files which must reside in your config_dir
68(e.g. /home/me/app/fixture_configs/a_fixture_set.json). They describe which data to pull and dump
69from the source database.
a5561f96 70
71For example:
72
73 {
74 sets: [{
75 class: 'Artist',
76 ids: ['1', '3']
77 }, {
78 class: 'Producer',
79 ids: ['5'],
80 fetch: [{
81 rel: 'artists',
82 quantity: '2'
83 }]
84 }]
85 }
e5963c1b 86
b099fee9 87This will fetch artists with primary keys 1 and 3, the producer with primary key 5 and two of producer 5's
88artists where 'artists' is a has_many DBIx::Class rel from Producer to Artist.
a5561f96 89
95566320 90The top level attributes are as follows:
91
a5561f96 92=head2 sets
93
b099fee9 94Sets must be an array of hashes, as in the example given above. Each set defines a set of objects to be
95included in the fixtures. For details on valid set attributes see L</SET ATTRIBUTES> below.
a5561f96 96
97=head2 rules
98
b099fee9 99Rules place general conditions on classes. For example if whenever an artist was dumped you also wanted all
100of their cds dumped too, then you could use a rule to specify this. For example:
a5561f96 101
102 {
103 sets: [{
104 class: 'Artist',
105 ids: ['1', '3']
106 }, {
107 class: 'Producer',
108 ids: ['5'],
109 fetch: [{
110 rel: 'artists',
111 quantity: '2'
112 }]
113 }],
114 rules: {
115 Artist: {
116 fetch: [{
117 rel: 'cds',
118 quantity: 'all'
119 }]
120 }
121 }
122 }
6116de11 123
b099fee9 124In 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
125has_many DBIx::Class relation from Artist to CD. This is eqivalent to:
a5561f96 126
127 {
128 sets: [{
129 class: 'Artist',
130 ids: ['1', '3'],
131 fetch: [{
132 rel: 'cds',
133 quantity: 'all'
134 }]
135 }, {
136 class: 'Producer',
137 ids: ['5'],
138 fetch: [{
139 rel: 'artists',
140 quantity: '2',
141 fetch: [{
142 rel: 'cds',
143 quantity: 'all'
144 }]
145 }]
146 }]
147 }
148
149rules must be a hash keyed by class name.
150
95566320 151L</RULE ATTRIBUTES>
152
153=head2 datetime_relative
154
b099fee9 155Only available for MySQL and PostgreSQL at the moment, must be a value that DateTime::Format::*
156can parse. For example:
95566320 157
158 {
159 sets: [{
160 class: 'RecentItems',
161 ids: ['9']
162 }],
163 datetime_relative : "2007-10-30 00:00:00"
164 }
165
b099fee9 166This will work when dumping from a MySQL database and will cause any datetime fields (where datatype => 'datetime'
167in the column def of the schema class) to be dumped as a DateTime::Duration object relative to the date specified in
168the datetime_relative value. For example if the RecentItem object had a date field set to 2007-10-25, then when the
169fixture is imported the field will be set to 5 days in the past relative to the current time.
95566320 170
a5561f96 171=head2 might_have
172
173Specifies whether to automatically dump might_have relationships. Should be a hash with one attribute - fetch. Set fetch to 1 or 0.
174
175 {
176 might_have: [{
177 fetch: 1
178 },
179 sets: [{
180 class: 'Artist',
181 ids: ['1', '3']
182 }, {
183 class: 'Producer',
184 ids: ['5']
185 }]
186 }
187
b099fee9 188Note: belongs_to rels are automatically dumped whether you like it or not, this is to avoid FKs to nowhere when importing.
189General rules on has_many rels are not accepted at this top level, but you can turn them on for individual
190sets - see L</SET ATTRIBUTES>.
a5561f96 191
192=head1 SET ATTRIBUTES
193
194=head2 class
195
196Required attribute. Specifies the DBIx::Class object class you wish to dump.
197
198=head2 ids
199
b099fee9 200Array of primary key ids to fetch, basically causing an $rs->find($_) for each. If the id is not in the source db then it
201just won't get dumped, no warnings or death.
a5561f96 202
203=head2 quantity
204
b099fee9 205Must be either an integer or the string 'all'. Specifying an integer will effectively set the 'rows' attribute on the resultset clause,
206specifying 'all' will cause the rows attribute to be left off and for all matching rows to be dumped. There's no randomising
207here, it's just the first x rows.
a5561f96 208
209=head2 cond
210
211A hash specifying the conditions dumped objects must match. Essentially this is a JSON representation of a DBIx::Class search clause. For example:
212
213 {
214 sets: [{
215 class: 'Artist',
216 quantiy: 'all',
217 cond: { name: 'Dave' }
218 }]
219 }
220
221This will dump all artists whose name is 'dave'. Essentially $artist_rs->search({ name => 'Dave' })->all.
222
223Sometimes in a search clause it's useful to use scalar refs to do things like:
224
225$artist_rs->search({ no1_singles => \'> no1_albums' })
226
227This could be specified in the cond hash like so:
228
229 {
230 sets: [{
231 class: 'Artist',
232 quantiy: 'all',
233 cond: { no1_singles: '\> no1_albums' }
234 }]
235 }
236
237So if the value starts with a backslash the value is made a scalar ref before being passed to search.
238
239=head2 join
240
241An array of relationships to be used in the cond clause.
242
243 {
244 sets: [{
245 class: 'Artist',
246 quantiy: 'all',
247 cond: { 'cds.position': { '>': 4 } },
248 join: ['cds']
249 }]
250 }
251
252Fetch all artists who have cds with position greater than 4.
253
254=head2 fetch
255
256Must be an array of hashes. Specifies which rels to also dump. For example:
257
258 {
259 sets: [{
260 class: 'Artist',
261 ids: ['1', '3'],
262 fetch: [{
263 rel: 'cds',
264 quantity: '3',
265 cond: { position: '2' }
266 }]
267 }]
268 }
269
270Will cause the cds of artists 1 and 3 to be dumped where the cd position is 2.
271
b099fee9 272Valid attributes are: 'rel', 'quantity', 'cond', 'has_many', 'might_have' and 'join'. rel is the name of the DBIx::Class
273rel to follow, the rest are the same as in the set attributes. quantity is necessary for has_many relationships,
274but not if using for belongs_to or might_have relationships.
a5561f96 275
276=head2 has_many
277
278Specifies whether to fetch has_many rels for this set. Must be a hash containing keys fetch and quantity.
279
280Set fetch to 1 if you want to fetch them, and quantity to either 'all' or an integer.
281
95566320 282Be careful here, dumping has_many rels can lead to a lot of data being dumped.
283
a5561f96 284=head2 might_have
285
286As with has_many but for might_have relationships. Quantity doesn't do anything in this case.
287
288This value will be inherited by all fetches in this set. This is not true for the has_many attribute.
289
290=head1 RULE ATTRIBUTES
291
292=head2 cond
293
294Same as with L</SET ATTRIBUTES>
295
296=head2 fetch
297
298Same as with L</SET ATTRIBUTES>
299
300=head2 join
301
302Same as with L</SET ATTRIBUTES>
303
304=head2 has_many
305
306Same as with L</SET ATTRIBUTES>
307
308=head2 might_have
309
310Same as with L</SET ATTRIBUTES>
e5963c1b 311
0fc424b7 312=head1 METHODS
313
314=head2 new
e5963c1b 315
a5561f96 316=over 4
317
318=item Arguments: \%$attrs
319
320=item Return Value: $fixture_object
321
322=back
323
95566320 324Returns a new DBIx::Class::Fixture object. %attrs has only two valid keys at the
325moment - 'debug' which determines whether to be verbose and 'config_dir' which is required and much contain a valid path to
a5561f96 326the directory in which your .json configs reside.
327
328 my $fixtures = DBIx::Class::Fixtures->new({ config_dir => '/home/me/app/fixture_configs' });
329
0fc424b7 330=cut
e5963c1b 331
332sub new {
333 my $class = shift;
334
335 my ($params) = @_;
336 unless (ref $params eq 'HASH') {
337 return DBIx::Class::Exception->throw('first arg to DBIx::Class::Fixtures->new() must be hash ref');
338 }
339
340 unless ($params->{config_dir}) {
341 return DBIx::Class::Exception->throw('config_dir param not specified');
342 }
343
344 my $config_dir = dir($params->{config_dir});
345 unless (-e $params->{config_dir}) {
346 return DBIx::Class::Exception->throw('config_dir directory doesn\'t exist');
347 }
348
349 my $self = {
0fc424b7 350 config_dir => $config_dir,
351 _inherited_attributes => [qw/datetime_relative might_have rules/],
352 debug => $params->{debug}
e5963c1b 353 };
354
355 bless $self, $class;
356
357 return $self;
358}
359
0fc424b7 360=head2 dump
361
a5561f96 362=over 4
363
364=item Arguments: \%$attrs
365
366=item Return Value: 1
367
368=back
369
370 $fixtures->dump({
371 config => 'set_config.json', # config file to use. must be in the config directory specified in the constructor
372 schema => $source_dbic_schema,
373 directory => '/home/me/app/fixtures' # output directory
374 });
375
376In this case objects will be dumped to subdirectories in the specified directory. For example:
377
378 /home/me/app/fixtures/artist/1.fix
379 /home/me/app/fixtures/artist/3.fix
380 /home/me/app/fixtures/producer/5.fix
381
382config, schema and directory are all required attributes.
383
0fc424b7 384=cut
385
386sub dump {
387 my $self = shift;
388
389 my ($params) = @_;
390 unless (ref $params eq 'HASH') {
391 return DBIx::Class::Exception->throw('first arg to dump must be hash ref');
392 }
393
394 foreach my $param (qw/config schema directory/) {
395 unless ($params->{$param}) {
396 return DBIx::Class::Exception->throw($param . ' param not specified');
397 }
398 }
399
400 my $config_file = file($self->config_dir, $params->{config});
401 unless (-e $config_file) {
402 return DBIx::Class::Exception->throw('config does not exist at ' . $config_file);
403 }
404
405 my $config = Config::Any::JSON->load($config_file);
406 unless ($config && $config->{sets} && ref $config->{sets} eq 'ARRAY' && scalar(@{$config->{sets}})) {
407 return DBIx::Class::Exception->throw('config has no sets');
408 }
409
410 my $output_dir = dir($params->{directory});
411 unless (-e $output_dir) {
d85d888e 412 $output_dir->mkpath ||
0fc424b7 413 return DBIx::Class::Exception->throw('output directory does not exist at ' . $output_dir);
414 }
415
416 my $schema = $params->{schema};
417
9f96b203 418 $self->msg("generating fixtures");
f251ab7e 419 my $tmp_output_dir = dir($output_dir, '-~dump~-' . $<);
0fc424b7 420
6116de11 421 if (-e $tmp_output_dir) {
0fc424b7 422 $self->msg("- clearing existing $tmp_output_dir");
6116de11 423 $tmp_output_dir->rmtree;
0fc424b7 424 }
6116de11 425 $self->msg("- creating $tmp_output_dir");
426 $tmp_output_dir->mkpath;
0fc424b7 427
428 # write version file (for the potential benefit of populate)
429 my $version_file = file($tmp_output_dir, '_dumper_version');
430 write_file($version_file->stringify, $VERSION);
431
432 $config->{rules} ||= {};
433 my @sources = sort { $a->{class} cmp $b->{class} } @{delete $config->{sets}};
434 my %options = ( is_root => 1 );
435 foreach my $source (@sources) {
436 # apply rule to set if specified
437 my $rule = $config->{rules}->{$source->{class}};
438 $source = merge( $source, $rule ) if ($rule);
439
440 # fetch objects
441 my $rs = $schema->resultset($source->{class});
442 $rs = $rs->search($source->{cond}, { join => $source->{join} }) if ($source->{cond});
443 $self->msg("- dumping $source->{class}");
444 my @objects;
445 my %source_options = ( set => { %{$config}, %{$source} } );
446 if ($source->{quantity}) {
447 $rs = $rs->search({}, { order_by => $source->{order_by} }) if ($source->{order_by});
448 if ($source->{quantity} eq 'all') {
449 push (@objects, $rs->all);
450 } elsif ($source->{quantity} =~ /^\d+$/) {
451 push (@objects, $rs->search({}, { rows => $source->{quantity} }));
452 } else {
453 DBIx::Class::Exception->throw('invalid value for quantity - ' . $source->{quantity});
454 }
455 }
456 if ($source->{ids}) {
457 my @ids = @{$source->{ids}};
458 my @id_objects = grep { $_ } map { $rs->find($_) } @ids;
459 push (@objects, @id_objects);
460 }
461 unless ($source->{quantity} || $source->{ids}) {
462 DBIx::Class::Exception->throw('must specify either quantity or ids');
463 }
464
465 # dump objects
466 foreach my $object (@objects) {
467 $source_options{set_dir} = $tmp_output_dir;
468 $self->dump_object($object, { %options, %source_options } );
469 next;
470 }
471 }
472
473 foreach my $dir ($output_dir->children) {
474 next if ($dir eq $tmp_output_dir);
475 $dir->remove || $dir->rmtree;
476 }
477
478 $self->msg("- moving temp dir to $output_dir");
6116de11 479 move($_, dir($output_dir, $_->relative($_->parent)->stringify)) for $tmp_output_dir->children;
0fc424b7 480 if (-e $output_dir) {
481 $self->msg("- clearing tmp dir $tmp_output_dir");
482 # delete existing fixture set
483 $tmp_output_dir->remove;
484 }
485
486 $self->msg("done");
487
488 return 1;
489}
490
491sub dump_object {
492 my ($self, $object, $params, $rr_info) = @_;
493 my $set = $params->{set};
494 die 'no dir passed to dump_object' unless $params->{set_dir};
495 die 'no object passed to dump_object' unless $object;
496
497 my @inherited_attrs = @{$self->_inherited_attributes};
498
499 # write dir and gen filename
500 my $source_dir = dir($params->{set_dir}, lc($object->result_source->from));
501 mkdir($source_dir->stringify, 0777);
502 my $file = file($source_dir, join('-', map { $object->get_column($_) } sort $object->primary_columns) . '.fix');
503
504 # write file
505 my $exists = (-e $file->stringify) ? 1 : 0;
506 unless ($exists) {
507 $self->msg('-- dumping ' . $file->stringify, 2);
508 my %ds = $object->get_columns;
509
b099fee9 510 my $formatter= $object->result_source->schema->storage->datetime_parser;
0fc424b7 511 # mess with dates if specified
0566a82d 512 if ($set->{datetime_relative}) {
513 unless ($@ || !$formatter) {
514 my $dt;
515 if ($set->{datetime_relative} eq 'today') {
516 $dt = DateTime->today;
517 } else {
518 $dt = $formatter->parse_datetime($set->{datetime_relative}) unless ($@);
519 }
0fc424b7 520
0566a82d 521 while (my ($col, $value) = each %ds) {
522 my $col_info = $object->result_source->column_info($col);
0fc424b7 523
0566a82d 524 next unless $value
525 && $col_info->{_inflate_info}
526 && uc($col_info->{data_type}) eq 'DATETIME';
0fc424b7 527
0566a82d 528 $ds{$col} = $object->get_inflated_column($col)->subtract_datetime($dt);
529 }
530 } else {
b099fee9 531 warn "datetime_relative not supported for this db driver at the moment";
0fc424b7 532 }
533 }
534
535 # do the actual dumping
536 my $serialized = Dump(\%ds)->Out();
537 write_file($file->stringify, $serialized);
538 my $mode = 0777; chmod $mode, $file->stringify;
539 }
540
541 # dump rels of object
542 my $s = $object->result_source;
543 unless ($exists) {
544 foreach my $name (sort $s->relationships) {
545 my $info = $s->relationship_info($name);
546 my $r_source = $s->related_source($name);
547 # if belongs_to or might_have with might_have param set or has_many with has_many param set then
548 if (($info->{attrs}{accessor} eq 'single' && (!$info->{attrs}{join_type} || ($set->{might_have} && $set->{might_have}->{fetch}))) || $info->{attrs}{accessor} eq 'filter' || ($info->{attrs}{accessor} eq 'multi' && ($set->{has_many} && $set->{has_many}->{fetch}))) {
549 my $related_rs = $object->related_resultset($name);
550 my $rule = $set->{rules}->{$related_rs->result_source->source_name};
551 # these parts of the rule only apply to has_many rels
552 if ($rule && $info->{attrs}{accessor} eq 'multi') {
553 $related_rs = $related_rs->search($rule->{cond}, { join => $rule->{join} }) if ($rule->{cond});
554 $related_rs = $related_rs->search({}, { rows => $rule->{quantity} }) if ($rule->{quantity} && $rule->{quantity} ne 'all');
555 $related_rs = $related_rs->search({}, { order_by => $rule->{order_by} }) if ($rule->{order_by});
556 }
557 if ($set->{has_many}->{quantity} && $set->{has_many}->{quantity} =~ /^\d+$/) {
558 $related_rs = $related_rs->search({}, { rows => $set->{has_many}->{quantity} });
559 }
560 my %c_params = %{$params};
561 # inherit date param
562 my %mock_set = map { $_ => $set->{$_} } grep { $set->{$_} } @inherited_attrs;
563 $c_params{set} = \%mock_set;
564 # use Data::Dumper; print ' -- ' . Dumper($c_params{set}, $rule->{fetch}) if ($rule && $rule->{fetch});
565 $c_params{set} = merge( $c_params{set}, $rule) if ($rule && $rule->{fetch});
566 # use Data::Dumper; print ' -- ' . Dumper(\%c_params) if ($rule && $rule->{fetch});
5eab44a9 567 $self->dump_object($_, \%c_params) foreach $related_rs->all;
0fc424b7 568 }
569 }
570 }
571
572 return unless $set && $set->{fetch};
573 foreach my $fetch (@{$set->{fetch}}) {
574 # inherit date param
575 $fetch->{$_} = $set->{$_} foreach grep { !$fetch->{$_} && $set->{$_} } @inherited_attrs;
576 my $related_rs = $object->related_resultset($fetch->{rel});
577 my $rule = $set->{rules}->{$related_rs->result_source->source_name};
578 if ($rule) {
579 my $info = $object->result_source->relationship_info($fetch->{rel});
580 if ($info->{attrs}{accessor} eq 'multi') {
581 $fetch = merge( $fetch, $rule );
582 } elsif ($rule->{fetch}) {
583 $fetch = merge( $fetch, { fetch => $rule->{fetch} } );
584 }
585 }
586 die "relationship " . $fetch->{rel} . " does not exist for " . $s->source_name unless ($related_rs);
587 if ($fetch->{cond} and ref $fetch->{cond} eq 'HASH') {
588 # if value starts with / assume it's meant to be passed as a scalar ref to dbic
589 # ideally this would substitute deeply
590 $fetch->{cond} = { map { $_ => ($fetch->{cond}->{$_} =~ s/^\\//) ? \$fetch->{cond}->{$_} : $fetch->{cond}->{$_} } keys %{$fetch->{cond}} };
591 }
592 $related_rs = $related_rs->search($fetch->{cond}, { join => $fetch->{join} }) if ($fetch->{cond});
593 $related_rs = $related_rs->search({}, { rows => $fetch->{quantity} }) if ($fetch->{quantity} && $fetch->{quantity} ne 'all');
594 $related_rs = $related_rs->search({}, { order_by => $fetch->{order_by} }) if ($fetch->{order_by});
5eab44a9 595 $self->dump_object($_, { %{$params}, set => $fetch }) foreach $related_rs->all;
0fc424b7 596 }
597}
598
384c3f0c 599sub _generate_schema {
600 my $self = shift;
601 my $params = shift || {};
384c3f0c 602 require DBI;
603 $self->msg("\ncreating schema");
604 # die 'must pass version param to generate_schema_from_ddl' unless $params->{version};
605
c06f7b96 606 my $schema_class = $self->schema_class || "DBIx::Class::Fixtures::Schema";
9a9a7832 607 eval "require $schema_class";
608 die $@ if $@;
609
4fb695f4 610 my $pre_schema;
611 my $connection_details = $params->{connection_details};
aa9f3cc7 612 $namespace_counter++;
613 my $namespace = "DBIx::Class::Fixtures::GeneratedSchema_" . $namespace_counter;
614 Class::C3::Componentised->inject_base( $namespace => $schema_class );
615 $pre_schema = $namespace->connect(@{$connection_details});
616 unless( $pre_schema ) {
384c3f0c 617 return DBIx::Class::Exception->throw('connection details not valid');
618 }
aa9f3cc7 619 my @tables = map { $pre_schema->source($_)->from } $pre_schema->sources;
4fb695f4 620 my $dbh = $pre_schema->storage->dbh;
384c3f0c 621
622 # clear existing db
623 $self->msg("- clearing DB of existing tables");
4fb695f4 624 eval { $dbh->do('SET foreign_key_checks=0') };
625 $dbh->do('drop table ' . $_) for (@tables);
384c3f0c 626
627 # import new ddl file to db
628 my $ddl_file = $params->{ddl};
629 $self->msg("- deploying schema using $ddl_file");
630 my $fh;
631 open $fh, "<$ddl_file" or die ("Can't open DDL file, $ddl_file ($!)");
632 my @data = split(/\n/, join('', <$fh>));
633 @data = grep(!/^--/, @data);
634 @data = split(/;/, join('', @data));
635 close($fh);
636 @data = grep { $_ && $_ !~ /^-- / } @data;
637 for (@data) {
638 eval { $dbh->do($_) or warn "SQL was:\n $_"};
639 if ($@) { die "SQL was:\n $_\n$@"; }
640 }
384c3f0c 641 $self->msg("- finished importing DDL into DB");
642
643 # load schema object from our new DB
644 $self->msg("- loading fresh DBIC object from DB");
aa9f3cc7 645 my $schema = $namespace->connect(@{$connection_details});
384c3f0c 646 return $schema;
647}
648
a5561f96 649
650=head2 populate
651
652=over 4
653
654=item Arguments: \%$attrs
655
656=item Return Value: 1
657
658=back
659
660 $fixtures->populate({
661 directory => '/home/me/app/fixtures', # directory to look for fixtures in, as specified to dump
662 ddl => '/home/me/app/sql/ddl.sql', # DDL to deploy
663 connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password'] # database to clear, deploy and then populate
664 });
665
95566320 666In this case the database app_dev will be cleared of all tables, then the specified DDL deployed to it,
a5561f96 667then finally all fixtures found in /home/me/app/fixtures will be added to it. populate will generate
668its own DBIx::Class schema from the DDL rather than being passed one to use. This is better as
95566320 669custom insert methods are avoided which can to get in the way. In some cases you might not
a5561f96 670have a DDL, and so this method will eventually allow a $schema object to be passed instead.
671
672directory, dll and connection_details are all required attributes.
673
674=cut
675
384c3f0c 676sub populate {
677 my $self = shift;
678 my ($params) = @_;
679 unless (ref $params eq 'HASH') {
680 return DBIx::Class::Exception->throw('first arg to populate must be hash ref');
681 }
682
683 foreach my $param (qw/directory/) {
684 unless ($params->{$param}) {
685 return DBIx::Class::Exception->throw($param . ' param not specified');
686 }
687 }
9a9a7832 688 my $fixture_dir = dir(delete $params->{directory});
384c3f0c 689 unless (-e $fixture_dir) {
690 return DBIx::Class::Exception->throw('fixture directory does not exist at ' . $fixture_dir);
691 }
692
693 my $ddl_file;
694 my $dbh;
695 if ($params->{ddl} && $params->{connection_details}) {
9a9a7832 696 $ddl_file = file(delete $params->{ddl});
384c3f0c 697 unless (-e $ddl_file) {
698 return DBIx::Class::Exception->throw('DDL does not exist at ' . $ddl_file);
699 }
700 unless (ref $params->{connection_details} eq 'ARRAY') {
701 return DBIx::Class::Exception->throw('connection details must be an arrayref');
702 }
703 } elsif ($params->{schema}) {
704 return DBIx::Class::Exception->throw('passing a schema is not supported at the moment');
705 } else {
706 return DBIx::Class::Exception->throw('you must set the ddl and connection_details params');
707 }
708
9a9a7832 709 my $schema = $self->_generate_schema({ ddl => $ddl_file, connection_details => delete $params->{connection_details}, %{$params} });
4fb695f4 710 $self->msg("\nimporting fixtures");
384c3f0c 711 my $tmp_fixture_dir = dir($fixture_dir, "-~populate~-" . $<);
712
713 my $version_file = file($fixture_dir, '_dumper_version');
714 unless (-e $version_file) {
715# return DBIx::Class::Exception->throw('no version file found');
716 }
717
718 if (-e $tmp_fixture_dir) {
719 $self->msg("- deleting existing temp directory $tmp_fixture_dir");
4fb695f4 720 $tmp_fixture_dir->rmtree;
384c3f0c 721 }
722 $self->msg("- creating temp dir");
0caf5ad6 723 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;
384c3f0c 724
4fb695f4 725 eval { $schema->storage->dbh->do('SET foreign_key_checks=0') };
0566a82d 726
384c3f0c 727 my $fixup_visitor;
b099fee9 728 my $formatter= $schema->storage->datetime_parser;
0566a82d 729 unless ($@ || !$formatter) {
730 my %callbacks;
731 if ($params->{datetime_relative_to}) {
732 $callbacks{'DateTime::Duration'} = sub {
733 $params->{datetime_relative_to}->clone->add_duration($_);
734 };
735 } else {
736 $callbacks{'DateTime::Duration'} = sub {
737 $formatter->format_datetime(DateTime->today->add_duration($_))
738 };
739 }
740 $callbacks{object} ||= "visit_ref";
741 $fixup_visitor = new Data::Visitor::Callback(%callbacks);
384c3f0c 742 }
384c3f0c 743 foreach my $source (sort $schema->sources) {
744 $self->msg("- adding " . $source);
745 my $rs = $schema->resultset($source);
746 my $source_dir = dir($tmp_fixture_dir, lc($rs->result_source->from));
747 next unless (-e $source_dir);
748 while (my $file = $source_dir->next) {
749 next unless ($file =~ /\.fix$/);
750 next if $file->is_dir;
751 my $contents = $file->slurp;
752 my $HASH1;
753 eval($contents);
754 $HASH1 = $fixup_visitor->visit($HASH1) if $fixup_visitor;
0566a82d 755 $rs->create($HASH1);
384c3f0c 756 }
757 }
758
759 $self->msg("- fixtures imported");
760 $self->msg("- cleaning up");
761 $tmp_fixture_dir->rmtree;
4fb695f4 762 eval { $schema->storage->dbh->do('SET foreign_key_checks=1') };
b099fee9 763
764 return 1;
384c3f0c 765}
766
0fc424b7 767sub msg {
768 my $self = shift;
769 my $subject = shift || return;
9a9a7832 770 my $level = shift || 1;
771
772 return unless $self->debug >= $level;
0fc424b7 773 if (ref $subject) {
774 print Dumper($subject);
775 } else {
776 print $subject . "\n";
777 }
778}
a5561f96 779
780=head1 AUTHOR
781
782 Luke Saunders <luke@shadowcatsystems.co.uk>
783
3b4f6e76 784 Initial development sponsored by and (c) Takkle, Inc. 2007
785
a5561f96 786=head1 CONTRIBUTORS
787
788 Ash Berlin <ash@shadowcatsystems.co.uk>
789 Matt S. Trout <mst@shadowcatsystems.co.uk>
790
3b4f6e76 791=head1 LICENSE
792
793 This library is free software under the same license as perl itself
794
a5561f96 795=cut
796
e5963c1b 7971;