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::Grouped;
   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 use Class::C3::Componentised;
  19
  20 use base qw(Class::Accessor::Grouped);
  21
  22 our $namespace_counter = 0;
  23
  24 __PACKAGE__->mk_group_accessors( 'simple' => qw/config_dir _inherited_attributes debug schema_class/);
  25
  26 =head1 VERSION
  27
  28 Version 1.000
  29
  30 =cut
  31
  32 our $VERSION = '1.000';
  33
  34 =head1 NAME
  35
  36 DBIx::Class::Fixtures
  37
  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
  60 Dump fixtures from source database to filesystem then import to another database (with same schema)
  61 at any time. Use as a constant dataset for running tests against or for populating development databases
  62 when impractical to use production clones. Describe fixture set using relations and conditions based
  63 on your DBIx::Class schema.
  64
  65 =head1 DEFINE YOUR FIXTURE SET
  66
  67 Fixture 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
  69 from the source database.
  70
  71 For 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     }
  86
  87 This will fetch artists with primary keys 1 and 3, the producer with primary key 5 and two of producer 5's
  88 artists where 'artists' is a has_many DBIx::Class rel from Producer to Artist.
  89
  90 The top level attributes are as follows:
  91
  92 =head2 sets
  93
  94 Sets must be an array of hashes, as in the example given above. Each set defines a set of objects to be
  95 included in the fixtures. For details on valid set attributes see L</SET ATTRIBUTES> below.
  96
  97 =head2 rules
  98
  99 Rules place general conditions on classes. For example if whenever an artist was dumped you also wanted all
 100 of their cds dumped too, then you could use a rule to specify this. For example:
 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     }
 123
 124 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
 125 has_many DBIx::Class relation from Artist to CD. This is eqivalent to:
 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
 149 rules must be a hash keyed by class name.
 150
 151 L</RULE ATTRIBUTES>
 152
 153 =head2 datetime_relative
 154
 155 Only available for MySQL and PostgreSQL at the moment, must be a value that DateTime::Format::*
 156 can parse. For example:
 157
 158     {
 159         sets: [{
 160             class: 'RecentItems',
 161             ids: ['9']
 162         }],
 163         datetime_relative : "2007-10-30 00:00:00"
 164     }
 165
 166 This will work when dumping from a MySQL database and will cause any datetime fields (where datatype => 'datetime'
 167 in the column def of the schema class) to be dumped as a DateTime::Duration object relative to the date specified in
 168 the datetime_relative value. For example if the RecentItem object had a date field set to 2007-10-25, then when the
 169 fixture is imported the field will be set to 5 days in the past relative to the current time.
 170
 171 =head2 might_have
 172
 173 Specifies 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
 188 Note: belongs_to rels are automatically dumped whether you like it or not, this is to avoid FKs to nowhere when importing.
 189 General rules on has_many rels are not accepted at this top level, but you can turn them on for individual
 190 sets - see L</SET ATTRIBUTES>.
 191
 192 =head1 SET ATTRIBUTES
 193
 194 =head2 class
 195
 196 Required attribute. Specifies the DBIx::Class object class you wish to dump.
 197
 198 =head2 ids
 199
 200 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
 201 just won't get dumped, no warnings or death.
 202
 203 =head2 quantity
 204
 205 Must be either an integer or the string 'all'. Specifying an integer will effectively set the 'rows' attribute on the resultset clause,
 206 specifying 'all' will cause the rows attribute to be left off and for all matching rows to be dumped. There's no randomising
 207 here, it's just the first x rows.
 208
 209 =head2 cond
 210
 211 A 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
 221 This will dump all artists whose name is 'dave'. Essentially $artist_rs->search({ name => 'Dave' })->all.
 222
 223 Sometimes 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
 227 This 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
 237 So if the value starts with a backslash the value is made a scalar ref before being passed to search.
 238
 239 =head2 join
 240
 241 An 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
 252 Fetch all artists who have cds with position greater than 4.
 253
 254 =head2 fetch
 255
 256 Must 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
 270 Will cause the cds of artists 1 and 3 to be dumped where the cd position is 2.
 271
 272 Valid attributes are: 'rel', 'quantity', 'cond', 'has_many', 'might_have' and 'join'. rel is the name of the DBIx::Class
 273 rel to follow, the rest are the same as in the set attributes. quantity is necessary for has_many relationships,
 274 but not if using for belongs_to or might_have relationships.
 275
 276 =head2 has_many
 277
 278 Specifies whether to fetch has_many rels for this set. Must be a hash containing keys fetch and quantity.
 279
 280 Set fetch to 1 if you want to fetch them, and quantity to either 'all' or an integer.
 281
 282 Be careful here, dumping has_many rels can lead to a lot of data being dumped.
 283
 284 =head2 might_have
 285
 286 As with has_many but for might_have relationships. Quantity doesn't do anything in this case.
 287
 288 This 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
 294 Same as with L</SET ATTRIBUTES>
 295
 296 =head2 fetch
 297
 298 Same as with L</SET ATTRIBUTES>
 299
 300 =head2 join
 301
 302 Same as with L</SET ATTRIBUTES>
 303
 304 =head2 has_many
 305
 306 Same as with L</SET ATTRIBUTES>
 307
 308 =head2 might_have
 309
 310 Same as with L</SET ATTRIBUTES>
 311
 312 =head1 METHODS
 313
 314 =head2 new
 315
 316 =over 4
 317
 318 =item Arguments: \%$attrs
 319
 320 =item Return Value: $fixture_object
 321
 322 =back
 323
 324 Returns a new DBIx::Class::Fixture object. %attrs has only two valid keys at the
 325 moment - 'debug' which determines whether to be verbose and 'config_dir' which is required and much contain a valid path to
 326 the directory in which your .json configs reside.
 327
 328   my $fixtures = DBIx::Class::Fixtures->new({ config_dir => '/home/me/app/fixture_configs' });
 329
 330 =cut
 331
 332 sub 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 = {
 350               config_dir => $config_dir,
 351               _inherited_attributes => [qw/datetime_relative might_have rules/],
 352               debug => $params->{debug}
 353   };
 354
 355   bless $self, $class;
 356
 357   return $self;
 358 }
 359
 360 =head2 dump
 361
 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
 376 In 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
 382 config, schema and directory are all required attributes.
 383
 384 =cut
 385
 386 sub 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) {
 412     return DBIx::Class::Exception->throw('output directory does not exist at ' . $output_dir);
 413   }
 414
 415   my $schema = $params->{schema};
 416
 417   $self->msg("generating  fixtures");
 418   my $tmp_output_dir = dir($output_dir, '-~dump~-');
 419
 420   if (-e $tmp_output_dir) {
 421     $self->msg("- clearing existing $tmp_output_dir");
 422     $tmp_output_dir->rmtree;
 423   }
 424   $self->msg("- creating $tmp_output_dir");
 425   $tmp_output_dir->mkpath;
 426
 427   # write version file (for the potential benefit of populate)
 428   my $version_file = file($tmp_output_dir, '_dumper_version');
 429   write_file($version_file->stringify, $VERSION);
 430
 431   $config->{rules} ||= {};
 432   my @sources = sort { $a->{class} cmp $b->{class} } @{delete $config->{sets}};
 433   my %options = ( is_root => 1 );
 434   foreach my $source (@sources) {
 435     # apply rule to set if specified
 436     my $rule = $config->{rules}->{$source->{class}};
 437     $source = merge( $source, $rule ) if ($rule);
 438
 439     # fetch objects
 440     my $rs = $schema->resultset($source->{class});
 441         $rs = $rs->search($source->{cond}, { join => $source->{join} }) if ($source->{cond});
 442     $self->msg("- dumping $source->{class}");
 443     my @objects;
 444     my %source_options = ( set => { %{$config}, %{$source} } );
 445     if ($source->{quantity}) {
 446       $rs = $rs->search({}, { order_by => $source->{order_by} }) if ($source->{order_by});
 447       if ($source->{quantity} eq 'all') {
 448         push (@objects, $rs->all);
 449       } elsif ($source->{quantity} =~ /^\d+$/) {
 450         push (@objects, $rs->search({}, { rows => $source->{quantity} }));
 451       } else {
 452         DBIx::Class::Exception->throw('invalid value for quantity - ' . $source->{quantity});
 453       }
 454     }
 455     if ($source->{ids}) {
 456       my @ids = @{$source->{ids}};
 457       my @id_objects = grep { $_ } map { $rs->find($_) } @ids;
 458       push (@objects, @id_objects);
 459     }
 460     unless ($source->{quantity} || $source->{ids}) {
 461       DBIx::Class::Exception->throw('must specify either quantity or ids');
 462     }
 463
 464     # dump objects
 465     foreach my $object (@objects) {
 466       $source_options{set_dir} = $tmp_output_dir;
 467       $self->dump_object($object, { %options, %source_options } );
 468       next;
 469     }
 470   }
 471
 472   foreach my $dir ($output_dir->children) {
 473     next if ($dir eq $tmp_output_dir);
 474     $dir->remove || $dir->rmtree;
 475   }
 476
 477   $self->msg("- moving temp dir to $output_dir");
 478   move($_, dir($output_dir, $_->relative($_->parent)->stringify)) for $tmp_output_dir->children;
 479   if (-e $output_dir) {
 480     $self->msg("- clearing tmp dir $tmp_output_dir");
 481     # delete existing fixture set
 482     $tmp_output_dir->remove;
 483   }
 484
 485   $self->msg("done");
 486
 487   return 1;
 488 }
 489
 490 sub dump_object {
 491   my ($self, $object, $params, $rr_info) = @_;
 492   my $set = $params->{set};
 493   die 'no dir passed to dump_object' unless $params->{set_dir};
 494   die 'no object passed to dump_object' unless $object;
 495
 496   my @inherited_attrs = @{$self->_inherited_attributes};
 497
 498   # write dir and gen filename
 499   my $source_dir = dir($params->{set_dir}, lc($object->result_source->from));
 500   mkdir($source_dir->stringify, 0777);
 501   my $file = file($source_dir, join('-', map { $object->get_column($_) } sort $object->primary_columns) . '.fix');
 502
 503   # write file
 504   my $exists = (-e $file->stringify) ? 1 : 0;
 505   unless ($exists) {
 506     $self->msg('-- dumping ' . $file->stringify, 2);
 507     my %ds = $object->get_columns;
 508
 509     my $formatter= $object->result_source->schema->storage->datetime_parser;
 510     # mess with dates if specified
 511     if ($set->{datetime_relative}) {
 512       unless ($@ || !$formatter) {
 513         my $dt;
 514         if ($set->{datetime_relative} eq 'today') {
 515           $dt = DateTime->today;
 516         } else {
 517           $dt = $formatter->parse_datetime($set->{datetime_relative}) unless ($@);
 518         }
 519
 520         while (my ($col, $value) = each %ds) {
 521           my $col_info = $object->result_source->column_info($col);
 522
 523           next unless $value
 524             && $col_info->{_inflate_info}
 525               && uc($col_info->{data_type}) eq 'DATETIME';
 526
 527           $ds{$col} = $object->get_inflated_column($col)->subtract_datetime($dt);
 528         }
 529       } else {
 530         warn "datetime_relative not supported for this db driver at the moment";
 531       }
 532     }
 533
 534     # do the actual dumping
 535     my $serialized = Dump(\%ds)->Out();
 536     write_file($file->stringify, $serialized);
 537     my $mode = 0777; chmod $mode, $file->stringify;
 538   }
 539
 540   # dump rels of object
 541   my $s = $object->result_source;
 542   unless ($exists) {
 543     foreach my $name (sort $s->relationships) {
 544       my $info = $s->relationship_info($name);
 545       my $r_source = $s->related_source($name);
 546       # if belongs_to or might_have with might_have param set or has_many with has_many param set then
 547       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}))) {
 548         my $related_rs = $object->related_resultset($name);
 549         my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 550         # these parts of the rule only apply to has_many rels
 551         if ($rule && $info->{attrs}{accessor} eq 'multi') {
 552           $related_rs = $related_rs->search($rule->{cond}, { join => $rule->{join} }) if ($rule->{cond});
 553           $related_rs = $related_rs->search({}, { rows => $rule->{quantity} }) if ($rule->{quantity} && $rule->{quantity} ne 'all');
 554           $related_rs = $related_rs->search({}, { order_by => $rule->{order_by} }) if ($rule->{order_by});
 555         }
 556         if ($set->{has_many}->{quantity} && $set->{has_many}->{quantity} =~ /^\d+$/) {
 557           $related_rs = $related_rs->search({}, { rows => $set->{has_many}->{quantity} });
 558         }
 559         my %c_params = %{$params};
 560         # inherit date param
 561         my %mock_set = map { $_ => $set->{$_} } grep { $set->{$_} } @inherited_attrs;
 562         $c_params{set} = \%mock_set;
 563         #               use Data::Dumper; print ' -- ' . Dumper($c_params{set}, $rule->{fetch}) if ($rule && $rule->{fetch});
 564         $c_params{set} = merge( $c_params{set}, $rule) if ($rule && $rule->{fetch});
 565         #               use Data::Dumper; print ' -- ' . Dumper(\%c_params) if ($rule && $rule->{fetch});
 566         $self->dump_object($_, \%c_params) foreach $related_rs->all;
 567       }
 568     }
 569   }
 570
 571   return unless $set && $set->{fetch};
 572   foreach my $fetch (@{$set->{fetch}}) {
 573     # inherit date param
 574     $fetch->{$_} = $set->{$_} foreach grep { !$fetch->{$_} && $set->{$_} } @inherited_attrs;
 575     my $related_rs = $object->related_resultset($fetch->{rel});
 576     my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 577     if ($rule) {
 578       my $info = $object->result_source->relationship_info($fetch->{rel});
 579       if ($info->{attrs}{accessor} eq 'multi') {
 580         $fetch = merge( $fetch, $rule );
 581       } elsif ($rule->{fetch}) {
 582         $fetch = merge( $fetch, { fetch => $rule->{fetch} } );
 583       }
 584     }
 585     die "relationship " . $fetch->{rel} . " does not exist for " . $s->source_name unless ($related_rs);
 586     if ($fetch->{cond} and ref $fetch->{cond} eq 'HASH') {
 587       # if value starts with / assume it's meant to be passed as a scalar ref to dbic
 588       # ideally this would substitute deeply
 589       $fetch->{cond} = { map { $_ => ($fetch->{cond}->{$_} =~ s/^\\//) ? \$fetch->{cond}->{$_} : $fetch->{cond}->{$_} } keys %{$fetch->{cond}} };
 590     }
 591     $related_rs = $related_rs->search($fetch->{cond}, { join => $fetch->{join} }) if ($fetch->{cond});
 592     $related_rs = $related_rs->search({}, { rows => $fetch->{quantity} }) if ($fetch->{quantity} && $fetch->{quantity} ne 'all');
 593     $related_rs = $related_rs->search({}, { order_by => $fetch->{order_by} }) if ($fetch->{order_by});
 594     $self->dump_object($_, { %{$params}, set => $fetch }) foreach $related_rs->all;
 595   }
 596 }
 597
 598 sub _generate_schema {
 599   my $self = shift;
 600   my $params = shift || {};
 601   require DBI;
 602   $self->msg("\ncreating schema");
 603   #   die 'must pass version param to generate_schema_from_ddl' unless $params->{version};
 604
 605   my $schema_class = $self->schema_class || "DBIx::Class::Fixtures::Schema";
 606   eval "require $schema_class";
 607   die $@ if $@;
 608
 609   my $pre_schema;
 610   my $connection_details = $params->{connection_details};
 611   $namespace_counter++;
 612   my $namespace = "DBIx::Class::Fixtures::GeneratedSchema_" . $namespace_counter;
 613   Class::C3::Componentised->inject_base( $namespace => $schema_class );
 614   $pre_schema = $namespace->connect(@{$connection_details});
 615   unless( $pre_schema ) {
 616     return DBIx::Class::Exception->throw('connection details not valid');
 617   }
 618   my @tables = map { $pre_schema->source($_)->from } $pre_schema->sources;
 619   my $dbh = $pre_schema->storage->dbh;
 620
 621   # clear existing db
 622   $self->msg("- clearing DB of existing tables");
 623   eval { $dbh->do('SET foreign_key_checks=0') };
 624   $dbh->do('drop table ' . $_) for (@tables);
 625
 626   # import new ddl file to db
 627   my $ddl_file = $params->{ddl};
 628   $self->msg("- deploying schema using $ddl_file");
 629   my $fh;
 630   open $fh, "<$ddl_file" or die ("Can't open DDL file, $ddl_file ($!)");
 631   my @data = split(/\n/, join('', <$fh>));
 632   @data = grep(!/^--/, @data);
 633   @data = split(/;/, join('', @data));
 634   close($fh);
 635   @data = grep { $_ && $_ !~ /^-- / } @data;
 636   for (@data) {
 637       eval { $dbh->do($_) or warn "SQL was:\n $_"};
 638           if ($@) { die "SQL was:\n $_\n$@"; }
 639   }
 640   $self->msg("- finished importing DDL into DB");
 641
 642   # load schema object from our new DB
 643   $self->msg("- loading fresh DBIC object from DB");
 644   my $schema = $namespace->connect(@{$connection_details});
 645   return $schema;
 646 }
 647
 648
 649 =head2 populate
 650
 651 =over 4
 652
 653 =item Arguments: \%$attrs
 654
 655 =item Return Value: 1
 656
 657 =back
 658
 659   $fixtures->populate({
 660     directory => '/home/me/app/fixtures', # directory to look for fixtures in, as specified to dump
 661     ddl => '/home/me/app/sql/ddl.sql', # DDL to deploy
 662     connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password'] # database to clear, deploy and then populate
 663   });
 664
 665 In this case the database app_dev will be cleared of all tables, then the specified DDL deployed to it,
 666 then finally all fixtures found in /home/me/app/fixtures will be added to it. populate will generate
 667 its own DBIx::Class schema from the DDL rather than being passed one to use. This is better as
 668 custom insert methods are avoided which can to get in the way. In some cases you might not
 669 have a DDL, and so this method will eventually allow a $schema object to be passed instead.
 670
 671 directory, dll and connection_details are all required attributes.
 672
 673 =cut
 674
 675 sub populate {
 676   my $self = shift;
 677   my ($params) = @_;
 678   unless (ref $params eq 'HASH') {
 679     return DBIx::Class::Exception->throw('first arg to populate must be hash ref');
 680   }
 681
 682   foreach my $param (qw/directory/) {
 683     unless ($params->{$param}) {
 684       return DBIx::Class::Exception->throw($param . ' param not specified');
 685     }
 686   }
 687   my $fixture_dir = dir(delete $params->{directory});
 688   unless (-e $fixture_dir) {
 689     return DBIx::Class::Exception->throw('fixture directory does not exist at ' . $fixture_dir);
 690   }
 691
 692   my $ddl_file;
 693   my $dbh;
 694   if ($params->{ddl} && $params->{connection_details}) {
 695     $ddl_file = file(delete $params->{ddl});
 696     unless (-e $ddl_file) {
 697       return DBIx::Class::Exception->throw('DDL does not exist at ' . $ddl_file);
 698     }
 699     unless (ref $params->{connection_details} eq 'ARRAY') {
 700       return DBIx::Class::Exception->throw('connection details must be an arrayref');
 701     }
 702   } elsif ($params->{schema}) {
 703     return DBIx::Class::Exception->throw('passing a schema is not supported at the moment');
 704   } else {
 705     return DBIx::Class::Exception->throw('you must set the ddl and connection_details params');
 706   }
 707
 708   my $schema = $self->_generate_schema({ ddl => $ddl_file, connection_details => delete $params->{connection_details}, %{$params} });
 709   $self->msg("\nimporting fixtures");
 710   my $tmp_fixture_dir = dir($fixture_dir, "-~populate~-" . $<);
 711
 712   my $version_file = file($fixture_dir, '_dumper_version');
 713   unless (-e $version_file) {
 714 #     return DBIx::Class::Exception->throw('no version file found');
 715   }
 716
 717   if (-e $tmp_fixture_dir) {
 718     $self->msg("- deleting existing temp directory $tmp_fixture_dir");
 719     $tmp_fixture_dir->rmtree;
 720   }
 721   $self->msg("- creating temp dir");
 722   dircopy(dir($fixture_dir, $schema->source($_)->from), dir($tmp_fixture_dir, $schema->source($_)->from)) for $schema->sources;
 723
 724   eval { $schema->storage->dbh->do('SET foreign_key_checks=0') };
 725
 726   my $fixup_visitor;
 727   my $formatter= $schema->storage->datetime_parser;
 728   unless ($@ || !$formatter) {
 729     my %callbacks;
 730     if ($params->{datetime_relative_to}) {
 731       $callbacks{'DateTime::Duration'} = sub {
 732         $params->{datetime_relative_to}->clone->add_duration($_);
 733       };
 734     } else {
 735       $callbacks{'DateTime::Duration'} = sub {
 736         $formatter->format_datetime(DateTime->today->add_duration($_))
 737       };
 738     }
 739     $callbacks{object} ||= "visit_ref";
 740     $fixup_visitor = new Data::Visitor::Callback(%callbacks);
 741   }
 742   foreach my $source (sort $schema->sources) {
 743     $self->msg("- adding " . $source);
 744     my $rs = $schema->resultset($source);
 745     my $source_dir = dir($tmp_fixture_dir, lc($rs->result_source->from));
 746     next unless (-e $source_dir);
 747     while (my $file = $source_dir->next) {
 748       next unless ($file =~ /\.fix$/);
 749       next if $file->is_dir;
 750       my $contents = $file->slurp;
 751       my $HASH1;
 752       eval($contents);
 753       $HASH1 = $fixup_visitor->visit($HASH1) if $fixup_visitor;
 754       $rs->create($HASH1);
 755     }
 756   }
 757
 758   $self->msg("- fixtures imported");
 759   $self->msg("- cleaning up");
 760   $tmp_fixture_dir->rmtree;
 761   eval { $schema->storage->dbh->do('SET foreign_key_checks=1') };
 762
 763   return 1;
 764 }
 765
 766 sub msg {
 767   my $self = shift;
 768   my $subject = shift || return;
 769   my $level = shift || 1;
 770
 771   return unless $self->debug >= $level;
 772   if (ref $subject) {
 773         print Dumper($subject);
 774   } else {
 775         print $subject . "\n";
 776   }
 777 }
 778
 779 =head1 AUTHOR
 780
 781   Luke Saunders <luke@shadowcatsystems.co.uk>
 782
 783 =head1 CONTRIBUTORS
 784
 785   Ash Berlin <ash@shadowcatsystems.co.uk>
 786   Matt S. Trout <mst@shadowcatsystems.co.uk>
 787
 788 =cut
 789
 790 1;