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