lib/DBIx/Class/Fixtures.pm

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