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