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