lib/DBIx/Class/Fixtures.pm

   1 package DBIx::Class::Fixtures;
   2
   3 use strict;
   4 use warnings;
   5
   6 use DBIx::Class 0.08100;
   7 use DBIx::Class::Exception;
   8 use Class::Accessor::Grouped;
   9 use Path::Class qw(dir file);
  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
  25     _inherited_attributes debug schema_class dumped_objects/);
  26
  27 =head1 VERSION
  28
  29 Version 1.001013
  30
  31 =cut
  32
  33 our $VERSION = '1.001013';
  34
  35 =head1 NAME
  36
  37 DBIx::Class::Fixtures - Dump data and repopulate a database using rules
  38
  39 =head1 SYNOPSIS
  40
  41  use DBIx::Class::Fixtures;
  42
  43  ...
  44
  45  my $fixtures = DBIx::Class::Fixtures->new({
  46      config_dir => '/home/me/app/fixture_configs'
  47  });
  48
  49  $fixtures->dump({
  50    config => 'set_config.json',
  51    schema => $source_dbic_schema,
  52    directory => '/home/me/app/fixtures'
  53  });
  54
  55  $fixtures->populate({
  56    directory => '/home/me/app/fixtures',
  57    ddl => '/home/me/app/sql/ddl.sql',
  58    connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password'],
  59    post_ddl => '/home/me/app/sql/post_ddl.sql',
  60  });
  61
  62 =head1 DESCRIPTION
  63
  64 Dump fixtures from source database to filesystem then import to another
  65 database (with same schema) at any time. Use as a constant dataset for running
  66 tests against or for populating development databases when impractical to use
  67 production clones. Describe fixture set using relations and conditions based on
  68 your DBIx::Class schema.
  69
  70 =head1 DEFINE YOUR FIXTURE SET
  71
  72 Fixture sets are currently defined in .json files which must reside in your
  73 config_dir (e.g. /home/me/app/fixture_configs/a_fixture_set.json). They
  74 describe which data to pull and dump from the source database.
  75
  76 For example:
  77
  78  {
  79    "sets": [
  80      {
  81        "class": "Artist",
  82        "ids": ["1", "3"]
  83      },
  84      {
  85        "class": "Producer",
  86        "ids": ["5"],
  87        "fetch": [
  88          {
  89            "rel": "artists",
  90            "quantity": "2"
  91          }
  92        ]
  93      }
  94    ]
  95  }
  96
  97 This will fetch artists with primary keys 1 and 3, the producer with primary
  98 key 5 and two of producer 5's artists where 'artists' is a has_many DBIx::Class
  99 rel from Producer to Artist.
 100
 101 The top level attributes are as follows:
 102
 103 =head2 sets
 104
 105 Sets must be an array of hashes, as in the example given above. Each set
 106 defines a set of objects to be included in the fixtures. For details on valid
 107 set attributes see L</SET ATTRIBUTES> below.
 108
 109 =head2 rules
 110
 111 Rules place general conditions on classes. For example if whenever an artist
 112 was dumped you also wanted all of their cds dumped too, then you could use a
 113 rule to specify this. For example:
 114
 115  {
 116    "sets": [
 117      {
 118        "class": "Artist",
 119        "ids": ["1", "3"]
 120      },
 121      {
 122        "class": "Producer",
 123        "ids": ["5"],
 124        "fetch": [
 125          {
 126            "rel": "artists",
 127            "quantity": "2"
 128          }
 129        ]
 130      }
 131    ],
 132    "rules": {
 133      "Artist": {
 134        "fetch": [ {
 135          "rel": "cds",
 136          "quantity": "all"
 137        } ]
 138      }
 139    }
 140  }
 141
 142 In this case all the cds of artists 1, 3 and all producer 5's artists will be
 143 dumped as well. Note that 'cds' is a has_many DBIx::Class relation from Artist
 144 to CD. This is eqivalent to:
 145
 146  {
 147    "sets": [
 148     {
 149        "class": "Artist",
 150        "ids": ["1", "3"],
 151        "fetch": [ {
 152          "rel": "cds",
 153          "quantity": "all"
 154        } ]
 155      },
 156      {
 157        "class": "Producer",
 158        "ids": ["5"],
 159        "fetch": [ {
 160          "rel": "artists",
 161          "quantity": "2",
 162          "fetch": [ {
 163            "rel": "cds",
 164            "quantity": "all"
 165          } ]
 166        } ]
 167      }
 168    ]
 169  }
 170
 171 rules must be a hash keyed by class name.
 172
 173 L</RULE ATTRIBUTES>
 174
 175 =head2 includes
 176
 177 To prevent repetition between configs you can include other configs. For
 178 example:
 179
 180  {
 181    "sets": [ {
 182      "class": "Producer",
 183      "ids": ["5"]
 184    } ],
 185    "includes": [
 186      { "file": "base.json" }
 187    ]
 188  }
 189
 190 Includes must be an arrayref of hashrefs where the hashrefs have key 'file'
 191 which is the name of another config file in the same directory. The original
 192 config is merged with its includes using L<Hash::Merge>.
 193
 194 =head2 datetime_relative
 195
 196 Only available for MySQL and PostgreSQL at the moment, must be a value that
 197 DateTime::Format::* can parse. For example:
 198
 199  {
 200    "sets": [ {
 201      "class": "RecentItems",
 202      "ids": ["9"]
 203    } ],
 204    "datetime_relative": "2007-10-30 00:00:00"
 205  }
 206
 207 This will work when dumping from a MySQL database and will cause any datetime
 208 fields (where datatype => 'datetime' in the column def of the schema class) to
 209 be dumped as a DateTime::Duration object relative to the date specified in the
 210 datetime_relative value. For example if the RecentItem object had a date field
 211 set to 2007-10-25, then when the fixture is imported the field will be set to 5
 212 days in the past relative to the current time.
 213
 214 =head2 might_have
 215
 216 Specifies whether to automatically dump might_have relationships. Should be a
 217 hash with one attribute - fetch. Set fetch to 1 or 0.
 218
 219  {
 220    "might_have": { "fetch": 1 },
 221    "sets": [
 222      {
 223        "class": "Artist",
 224        "ids": ["1", "3"]
 225      },
 226      {
 227        "class": "Producer",
 228        "ids": ["5"]
 229      }
 230    ]
 231  }
 232
 233 Note: belongs_to rels are automatically dumped whether you like it or not, this
 234 is to avoid FKs to nowhere when importing.  General rules on has_many rels are
 235 not accepted at this top level, but you can turn them on for individual sets -
 236 see L</SET ATTRIBUTES>.
 237
 238 =head1 SET ATTRIBUTES
 239
 240 =head2 class
 241
 242 Required attribute. Specifies the DBIx::Class object class you wish to dump.
 243
 244 =head2 ids
 245
 246 Array of primary key ids to fetch, basically causing an $rs->find($_) for each.
 247 If the id is not in the source db then it just won't get dumped, no warnings or
 248 death.
 249
 250 =head2 quantity
 251
 252 Must be either an integer or the string 'all'. Specifying an integer will
 253 effectively set the 'rows' attribute on the resultset clause, specifying 'all'
 254 will cause the rows attribute to be left off and for all matching rows to be
 255 dumped. There's no randomising here, it's just the first x rows.
 256
 257 =head2 cond
 258
 259 A hash specifying the conditions dumped objects must match. Essentially this is
 260 a JSON representation of a DBIx::Class search clause. For example:
 261
 262  {
 263    "sets": [{
 264      "class": "Artist",
 265      "quantiy": "all",
 266      "cond": { "name": "Dave" }
 267    }]
 268  }
 269
 270 This will dump all artists whose name is 'dave'. Essentially
 271 $artist_rs->search({ name => 'Dave' })->all.
 272
 273 Sometimes in a search clause it's useful to use scalar refs to do things like:
 274
 275  $artist_rs->search({ no1_singles => \'> no1_albums' })
 276
 277 This could be specified in the cond hash like so:
 278
 279  {
 280    "sets": [ {
 281      "class": "Artist",
 282      "quantiy": "all",
 283      "cond": { "no1_singles": "\> no1_albums" }
 284    } ]
 285  }
 286
 287 So if the value starts with a backslash the value is made a scalar ref before
 288 being passed to search.
 289
 290 =head2 join
 291
 292 An array of relationships to be used in the cond clause.
 293
 294  {
 295    "sets": [ {
 296      "class": "Artist",
 297      "quantiy": "all",
 298      "cond": { "cds.position": { ">": 4 } },
 299      "join": ["cds"]
 300    } ]
 301  }
 302
 303 Fetch all artists who have cds with position greater than 4.
 304
 305 =head2 fetch
 306
 307 Must be an array of hashes. Specifies which rels to also dump. For example:
 308
 309  {
 310    "sets": [ {
 311      "class": "Artist",
 312      "ids": ["1", "3"],
 313      "fetch": [ {
 314        "rel": "cds",
 315        "quantity": "3",
 316        "cond": { "position": "2" }
 317      } ]
 318    } ]
 319  }
 320
 321 Will cause the cds of artists 1 and 3 to be dumped where the cd position is 2.
 322
 323 Valid attributes are: 'rel', 'quantity', 'cond', 'has_many', 'might_have' and
 324 'join'. rel is the name of the DBIx::Class rel to follow, the rest are the same
 325 as in the set attributes. quantity is necessary for has_many relationships, but
 326 not if using for belongs_to or might_have relationships.
 327
 328 =head2 has_many
 329
 330 Specifies whether to fetch has_many rels for this set. Must be a hash
 331 containing keys fetch and quantity.
 332
 333 Set fetch to 1 if you want to fetch them, and quantity to either 'all' or an
 334 integer.
 335
 336 Be careful here, dumping has_many rels can lead to a lot of data being dumped.
 337
 338 =head2 might_have
 339
 340 As with has_many but for might_have relationships. Quantity doesn't do anything
 341 in this case.
 342
 343 This value will be inherited by all fetches in this set. This is not true for
 344 the has_many attribute.
 345
 346 =head1 RULE ATTRIBUTES
 347
 348 =head2 cond
 349
 350 Same as with L</SET ATTRIBUTES>
 351
 352 =head2 fetch
 353
 354 Same as with L</SET ATTRIBUTES>
 355
 356 =head2 join
 357
 358 Same as with L</SET ATTRIBUTES>
 359
 360 =head2 has_many
 361
 362 Same as with L</SET ATTRIBUTES>
 363
 364 =head2 might_have
 365
 366 Same as with L</SET ATTRIBUTES>
 367
 368 =head1 METHODS
 369
 370 =head2 new
 371
 372 =over 4
 373
 374 =item Arguments: \%$attrs
 375
 376 =item Return Value: $fixture_object
 377
 378 =back
 379
 380 Returns a new DBIx::Class::Fixture object. %attrs can have the following
 381 parameters:
 382
 383 =over
 384
 385 =item config_dir:
 386
 387 required. must contain a valid path to the directory in which your .json
 388 configs reside.
 389
 390 =item debug:
 391
 392 determines whether to be verbose
 393
 394 =item ignore_sql_errors:
 395
 396 ignore errors on import of DDL etc
 397
 398 =back
 399
 400  my $fixtures = DBIx::Class::Fixtures->new( {
 401    config_dir => '/home/me/app/fixture_configs'
 402  } );
 403
 404 =cut
 405
 406 sub new {
 407   my $class = shift;
 408
 409   my ($params) = @_;
 410   unless (ref $params eq 'HASH') {
 411     return DBIx::Class::Exception->throw('first arg to DBIx::Class::Fixtures->new() must be hash ref');
 412   }
 413
 414   unless ($params->{config_dir}) {
 415     return DBIx::Class::Exception->throw('config_dir param not specified');
 416   }
 417
 418   my $config_dir = dir($params->{config_dir});
 419   unless (-e $params->{config_dir}) {
 420     return DBIx::Class::Exception->throw('config_dir directory doesn\'t exist');
 421   }
 422
 423   my $self = {
 424               config_dir => $config_dir,
 425               _inherited_attributes => [qw/datetime_relative might_have rules belongs_to/],
 426               debug => $params->{debug} || 0,
 427               ignore_sql_errors => $params->{ignore_sql_errors},
 428               dumped_objects => {},
 429               use_create => $params->{use_create} || 0
 430   };
 431
 432   bless $self, $class;
 433
 434   return $self;
 435 }
 436
 437 =head2 available_config_sets
 438
 439 Returns a list of all the config sets found in the L</config_dir>.  These will
 440 be a list of the json based files containing dump rules.
 441
 442 =cut
 443
 444 my @config_sets;
 445 sub available_config_sets {
 446   @config_sets = scalar(@config_sets) ? @config_sets : map {
 447     $_->basename;
 448   } grep {
 449     -f $_ && $_=~/json$/;
 450   } dir((shift)->config_dir)->children;
 451 }
 452
 453 =head2 dump
 454
 455 =over 4
 456
 457 =item Arguments: \%$attrs
 458
 459 =item Return Value: 1
 460
 461 =back
 462
 463  $fixtures->dump({
 464    config => 'set_config.json', # config file to use. must be in the config
 465                                 # directory specified in the constructor
 466    schema => $source_dbic_schema,
 467    directory => '/home/me/app/fixtures' # output directory
 468  });
 469
 470 or
 471
 472  $fixtures->dump({
 473    all => 1, # just dump everything that's in the schema
 474    schema => $source_dbic_schema,
 475    directory => '/home/me/app/fixtures' # output directory
 476  });
 477
 478 In this case objects will be dumped to subdirectories in the specified
 479 directory. For example:
 480
 481  /home/me/app/fixtures/artist/1.fix
 482  /home/me/app/fixtures/artist/3.fix
 483  /home/me/app/fixtures/producer/5.fix
 484
 485 schema and directory are required attributes. also, one of config or all must
 486 be specified.
 487
 488 Lastly, the C<config> parameter can be a Perl HashRef instead of a file name.
 489 If this form is used your HashRef should conform to the structure rules defined
 490 for the JSON representations.
 491
 492 =cut
 493
 494 sub dump {
 495   my $self = shift;
 496
 497   my ($params) = @_;
 498   unless (ref $params eq 'HASH') {
 499     return DBIx::Class::Exception->throw('first arg to dump must be hash ref');
 500   }
 501
 502   foreach my $param (qw/schema directory/) {
 503     unless ($params->{$param}) {
 504       return DBIx::Class::Exception->throw($param . ' param not specified');
 505     }
 506   }
 507
 508   if($params->{excludes} && !$params->{all}) {
 509     return DBIx::Class::Exception->throw("'excludes' param only works when using the 'all' param");
 510   }
 511
 512   my $schema = $params->{schema};
 513   my $config;
 514   if ($params->{config}) {
 515     $config = ref $params->{config} eq 'HASH' ?
 516       $params->{config} :
 517       do {
 518         #read config
 519         my $config_file = $self->config_dir->file($params->{config});
 520         $self->load_config_file($config_file);
 521       };
 522   } elsif ($params->{all}) {
 523     my %excludes = map {$_=>1} @{$params->{excludes}||[]};
 524     $config = {
 525       might_have => { fetch => 0 },
 526       has_many => { fetch => 0 },
 527       belongs_to => { fetch => 0 },
 528       sets => [
 529         map {
 530           { class => $_, quantity => 'all' };
 531         } grep {
 532           !$excludes{$_}
 533         } $schema->sources],
 534     };
 535   } else {
 536     DBIx::Class::Exception->throw('must pass config or set all');
 537   }
 538
 539   my $output_dir = dir($params->{directory});
 540   unless (-e $output_dir) {
 541     $output_dir->mkpath ||
 542     DBIx::Class::Exception->throw("output directory does not exist at $output_dir");
 543   }
 544
 545   $self->msg("generating  fixtures");
 546   my $tmp_output_dir = dir($output_dir, '-~dump~-' . $<);
 547
 548   if (-e $tmp_output_dir) {
 549     $self->msg("- clearing existing $tmp_output_dir");
 550     $tmp_output_dir->rmtree;
 551   }
 552   $self->msg("- creating $tmp_output_dir");
 553   $tmp_output_dir->mkpath;
 554
 555   # write version file (for the potential benefit of populate)
 556   $tmp_output_dir->file('_dumper_version')
 557                  ->openw
 558                  ->print($VERSION);
 559
 560   $config->{rules} ||= {};
 561   my @sources = sort { $a->{class} cmp $b->{class} } @{delete $config->{sets}};
 562
 563   while ( my ($k,$v) = each %{ $config->{rules} } ) {
 564     if ( my $source = eval { $schema->source($k) } ) {
 565       $config->{rules}{$source->source_name} = $v;
 566     }
 567   }
 568
 569   foreach my $source (@sources) {
 570     # apply rule to set if specified
 571     my $rule = $config->{rules}->{$source->{class}};
 572     $source = merge( $source, $rule ) if ($rule);
 573
 574     # fetch objects
 575     my $rs = $schema->resultset($source->{class});
 576
 577     if ($source->{cond} and ref $source->{cond} eq 'HASH') {
 578       # if value starts with \ assume it's meant to be passed as a scalar ref
 579       # to dbic. ideally this would substitute deeply
 580       $source->{cond} = {
 581         map {
 582           $_ => ($source->{cond}->{$_} =~ s/^\\//) ? \$source->{cond}->{$_}
 583                                                    : $source->{cond}->{$_}
 584         } keys %{$source->{cond}}
 585       };
 586     }
 587
 588     $rs = $rs->search($source->{cond}, { join => $source->{join} })
 589       if $source->{cond};
 590
 591     $self->msg("- dumping $source->{class}");
 592
 593     my %source_options = ( set => { %{$config}, %{$source} } );
 594     if ($source->{quantity}) {
 595       $rs = $rs->search({}, { order_by => $source->{order_by} })
 596         if $source->{order_by};
 597
 598       if ($source->{quantity} =~ /^\d+$/) {
 599         $rs = $rs->search({}, { rows => $source->{quantity} });
 600       } elsif ($source->{quantity} ne 'all') {
 601         DBIx::Class::Exception->throw("invalid value for quantity - $source->{quantity}");
 602       }
 603     }
 604     elsif ($source->{ids} && @{$source->{ids}}) {
 605       my @ids = @{$source->{ids}};
 606       my (@pks) = $rs->result_source->primary_columns;
 607       die "Can't dump multiple col-pks using 'id' option" if @pks > 1;
 608       $rs = $rs->search_rs( { $pks[0] => { -in => \@ids } } );
 609     }
 610     else {
 611       DBIx::Class::Exception->throw('must specify either quantity or ids');
 612     }
 613
 614     $source_options{set_dir} = $tmp_output_dir;
 615     $self->dump_rs($rs, \%source_options );
 616   }
 617
 618   # clear existing output dir
 619   foreach my $child ($output_dir->children) {
 620     if ($child->is_dir) {
 621       next if ($child eq $tmp_output_dir);
 622       if (grep { $_ =~ /\.fix/ } $child->children) {
 623         $child->rmtree;
 624       }
 625     } elsif ($child =~ /_dumper_version$/) {
 626       $child->remove;
 627     }
 628   }
 629
 630   $self->msg("- moving temp dir to $output_dir");
 631   move($_, dir($output_dir, $_->relative($_->parent)->stringify))
 632     for $tmp_output_dir->children;
 633
 634   if (-e $output_dir) {
 635     $self->msg("- clearing tmp dir $tmp_output_dir");
 636     # delete existing fixture set
 637     $tmp_output_dir->remove;
 638   }
 639
 640   $self->msg("done");
 641
 642   return 1;
 643 }
 644
 645 sub load_config_file {
 646   my ($self, $config_file) = @_;
 647   DBIx::Class::Exception->throw("config does not exist at $config_file")
 648     unless -e $config_file;
 649
 650   my $config = Config::Any::JSON->load($config_file);
 651
 652   #process includes
 653   if (my $incs = $config->{includes}) {
 654     $self->msg($incs);
 655     DBIx::Class::Exception->throw(
 656       'includes params of config must be an array ref of hashrefs'
 657     ) unless ref $incs eq 'ARRAY';
 658
 659     foreach my $include_config (@$incs) {
 660       DBIx::Class::Exception->throw(
 661         'includes params of config must be an array ref of hashrefs'
 662       ) unless (ref $include_config eq 'HASH') && $include_config->{file};
 663
 664       my $include_file = $self->config_dir->file($include_config->{file});
 665
 666       DBIx::Class::Exception->throw("config does not exist at $include_file")
 667         unless -e $include_file;
 668
 669       my $include = Config::Any::JSON->load($include_file);
 670       $self->msg($include);
 671       $config = merge( $config, $include );
 672     }
 673     delete $config->{includes};
 674   }
 675
 676   # validate config
 677   return DBIx::Class::Exception->throw('config has no sets')
 678     unless $config && $config->{sets} &&
 679            ref $config->{sets} eq 'ARRAY' && scalar @{$config->{sets}};
 680
 681   $config->{might_have} = { fetch => 0 } unless exists $config->{might_have};
 682   $config->{has_many} = { fetch => 0 }   unless exists $config->{has_many};
 683   $config->{belongs_to} = { fetch => 1 } unless exists $config->{belongs_to};
 684
 685   return $config;
 686 }
 687
 688 sub dump_rs {
 689     my ($self, $rs, $params) = @_;
 690
 691     while (my $row = $rs->next) {
 692         $self->dump_object($row, $params);
 693     }
 694 }
 695
 696 sub dump_object {
 697   my ($self, $object, $params) = @_;
 698   my $set = $params->{set};
 699   die 'no dir passed to dump_object' unless $params->{set_dir};
 700   die 'no object passed to dump_object' unless $object;
 701
 702   my @inherited_attrs = @{$self->_inherited_attributes};
 703
 704   my @pk_vals = map {
 705     $object->get_column($_)
 706   } $object->primary_columns;
 707
 708   my $key = join("\0", @pk_vals);
 709
 710   my $src = $object->result_source;
 711   my $exists = $self->dumped_objects->{$src->name}{$key}++;
 712
 713
 714   # write dir and gen filename
 715   my $source_dir = $params->{set_dir}->subdir($src->from);
 716   $source_dir->mkpath(0, 0777);
 717
 718   # strip dir separators from file name
 719   my $file = $source_dir->file(
 720       join('-', map { s|[/\\]|_|g; $_; } @pk_vals) . '.fix'
 721   );
 722
 723
 724   # write file
 725   unless ($exists) {
 726     $self->msg('-- dumping ' . $file->stringify, 2);
 727     my %ds = $object->get_columns;
 728
 729     # mess with dates if specified
 730     if ($set->{datetime_relative}) {
 731       my $formatter= $object->result_source->schema->storage->datetime_parser;
 732       unless ($@ || !$formatter) {
 733         my $dt;
 734         if ($set->{datetime_relative} eq 'today') {
 735           $dt = DateTime->today;
 736         } else {
 737           $dt = $formatter->parse_datetime($set->{datetime_relative}) unless ($@);
 738         }
 739
 740         while (my ($col, $value) = each %ds) {
 741           my $col_info = $object->result_source->column_info($col);
 742
 743           next unless $value
 744             && $col_info->{_inflate_info}
 745               && uc($col_info->{data_type}) eq 'DATETIME';
 746
 747           $ds{$col} = $object->get_inflated_column($col)->subtract_datetime($dt);
 748         }
 749       } else {
 750         warn "datetime_relative not supported for this db driver at the moment";
 751       }
 752     }
 753
 754     # do the actual dumping
 755     my $serialized = Dump(\%ds)->Out();
 756     $file->openw->print($serialized);
 757   }
 758
 759   # don't bother looking at rels unless we are actually planning to dump at least one type
 760   my ($might_have, $belongs_to, $has_many) = map {
 761     $set->{$_}{fetch} || $set->{rules}{$src->source_name}{$_}{fetch}
 762   } qw/might_have belongs_to has_many/;
 763
 764   return unless $might_have
 765              || $belongs_to
 766              || $has_many
 767              || $set->{fetch};
 768
 769   # dump rels of object
 770   unless ($exists) {
 771     foreach my $name (sort $src->relationships) {
 772       my $info = $src->relationship_info($name);
 773       my $r_source = $src->related_source($name);
 774       # if belongs_to or might_have with might_have param set or has_many with
 775       # has_many param set then
 776       if (
 777             ( $info->{attrs}{accessor} eq 'single' &&
 778               (!$info->{attrs}{join_type} || $might_have)
 779             )
 780          || $info->{attrs}{accessor} eq 'filter'
 781          ||
 782             ($info->{attrs}{accessor} eq 'multi' && $has_many)
 783       ) {
 784         my $related_rs = $object->related_resultset($name);
 785         my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 786         # these parts of the rule only apply to has_many rels
 787         if ($rule && $info->{attrs}{accessor} eq 'multi') {
 788           $related_rs = $related_rs->search(
 789             $rule->{cond},
 790             { join => $rule->{join} }
 791           ) if ($rule->{cond});
 792
 793           $related_rs = $related_rs->search(
 794             {},
 795             { rows => $rule->{quantity} }
 796           ) if ($rule->{quantity} && $rule->{quantity} ne 'all');
 797
 798           $related_rs = $related_rs->search(
 799             {},
 800             { order_by => $rule->{order_by} }
 801           ) if ($rule->{order_by});
 802
 803         }
 804         if ($set->{has_many}{quantity} &&
 805             $set->{has_many}{quantity} =~ /^\d+$/) {
 806           $related_rs = $related_rs->search(
 807             {},
 808             { rows => $set->{has_many}->{quantity} }
 809           );
 810         }
 811
 812         my %c_params = %{$params};
 813         # inherit date param
 814         my %mock_set = map {
 815           $_ => $set->{$_}
 816         } grep { $set->{$_} } @inherited_attrs;
 817
 818         $c_params{set} = \%mock_set;
 819         $c_params{set} = merge( $c_params{set}, $rule)
 820           if $rule && $rule->{fetch};
 821
 822         $self->dump_rs($related_rs, \%c_params);
 823       }
 824     }
 825   }
 826
 827   return unless $set && $set->{fetch};
 828   foreach my $fetch (@{$set->{fetch}}) {
 829     # inherit date param
 830     $fetch->{$_} = $set->{$_} foreach
 831       grep { !$fetch->{$_} && $set->{$_} } @inherited_attrs;
 832     my $related_rs = $object->related_resultset($fetch->{rel});
 833     my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 834
 835     if ($rule) {
 836       my $info = $object->result_source->relationship_info($fetch->{rel});
 837       if ($info->{attrs}{accessor} eq 'multi') {
 838         $fetch = merge( $fetch, $rule );
 839       } elsif ($rule->{fetch}) {
 840         $fetch = merge( $fetch, { fetch => $rule->{fetch} } );
 841       }
 842     }
 843
 844     die "relationship $fetch->{rel} does not exist for " . $src->source_name
 845       unless ($related_rs);
 846
 847     if ($fetch->{cond} and ref $fetch->{cond} eq 'HASH') {
 848       # if value starts with \ assume it's meant to be passed as a scalar ref
 849       # to dbic.  ideally this would substitute deeply
 850       $fetch->{cond} = { map {
 851           $_ => ($fetch->{cond}->{$_} =~ s/^\\//) ? \$fetch->{cond}->{$_}
 852                                                   : $fetch->{cond}->{$_}
 853       } keys %{$fetch->{cond}} };
 854     }
 855
 856     $related_rs = $related_rs->search(
 857       $fetch->{cond},
 858       { join => $fetch->{join} }
 859     ) if $fetch->{cond};
 860
 861     $related_rs = $related_rs->search(
 862       {},
 863       { rows => $fetch->{quantity} }
 864     ) if $fetch->{quantity} && $fetch->{quantity} ne 'all';
 865     $related_rs = $related_rs->search(
 866       {},
 867       { order_by => $fetch->{order_by} }
 868     ) if $fetch->{order_by};
 869
 870     $self->dump_rs($related_rs, { %{$params}, set => $fetch });
 871   }
 872 }
 873
 874 sub _generate_schema {
 875   my $self = shift;
 876   my $params = shift || {};
 877   require DBI;
 878   $self->msg("\ncreating schema");
 879
 880   my $schema_class = $self->schema_class || "DBIx::Class::Fixtures::Schema";
 881   eval "require $schema_class";
 882   die $@ if $@;
 883
 884   my $pre_schema;
 885   my $connection_details = $params->{connection_details};
 886
 887   $namespace_counter++;
 888
 889   my $namespace = "DBIx::Class::Fixtures::GeneratedSchema_$namespace_counter";
 890   Class::C3::Componentised->inject_base( $namespace => $schema_class );
 891
 892   $pre_schema = $namespace->connect(@{$connection_details});
 893   unless( $pre_schema ) {
 894     return DBIx::Class::Exception->throw('connection details not valid');
 895   }
 896   my @tables = map { $pre_schema->source($_)->from } $pre_schema->sources;
 897   $self->msg("Tables to drop: [". join(', ', sort @tables) . "]");
 898   my $dbh = $pre_schema->storage->dbh;
 899
 900   # clear existing db
 901   $self->msg("- clearing DB of existing tables");
 902   $pre_schema->storage->txn_do(sub {
 903     $pre_schema->storage->with_deferred_fk_checks(sub {
 904       foreach my $table (@tables) {
 905         eval {
 906           $dbh->do("drop table $table" . ($params->{cascade} ? ' cascade' : '') )
 907         };
 908       }
 909     });
 910   });
 911
 912   # import new ddl file to db
 913   my $ddl_file = $params->{ddl};
 914   $self->msg("- deploying schema using $ddl_file");
 915   my $data = _read_sql($ddl_file);
 916   foreach (@$data) {
 917     eval { $dbh->do($_) or warn "SQL was:\n $_"};
 918           if ($@ && !$self->{ignore_sql_errors}) { die "SQL was:\n $_\n$@"; }
 919   }
 920   $self->msg("- finished importing DDL into DB");
 921
 922   # load schema object from our new DB
 923   $namespace_counter++;
 924   my $namespace2 = "DBIx::Class::Fixtures::GeneratedSchema_$namespace_counter";
 925   Class::C3::Componentised->inject_base( $namespace2 => $schema_class );
 926   my $schema = $namespace2->connect(@{$connection_details});
 927   return $schema;
 928 }
 929
 930 sub _read_sql {
 931   my $ddl_file = shift;
 932   my $fh;
 933   open $fh, "<$ddl_file" or die ("Can't open DDL file, $ddl_file ($!)");
 934   my @data = split(/\n/, join('', <$fh>));
 935   @data = grep(!/^--/, @data);
 936   @data = split(/;/, join('', @data));
 937   close($fh);
 938   @data = grep { $_ && $_ !~ /^-- / } @data;
 939   return \@data;
 940 }
 941
 942 =head2 dump_config_sets
 943
 944 Works just like L</dump> but instead of specifying a single json config set
 945 located in L</config_dir> we dump each set named in the C<configs> parameter.
 946
 947 The parameters are the same as for L</dump> except instead of a C<directory>
 948 parameter we have a C<directory_template> which is a coderef expected to return
 949 a scalar that is a root directory where we will do the actual dumping.  This
 950 coderef get three arguments: C<$self>, C<$params> and C<$set_name>.  For
 951 example:
 952
 953     $fixture->dump_all_config_sets({
 954       schema => $schema,
 955       configs => [qw/one.json other.json/],
 956       directory_template => sub {
 957         my ($fixture, $params, $set) = @_;
 958         return File::Spec->catdir('var', 'fixtures', $params->{schema}->version, $set);
 959       },
 960     });
 961
 962 =cut
 963
 964 sub dump_config_sets {
 965   my ($self, $params) = @_;
 966   my $available_config_sets = delete $params->{configs};
 967   my $directory_template = delete $params->{directory_template} ||
 968     DBIx::Class::Exception->throw("'directory_template is required parameter");
 969
 970   for my $set (@$available_config_sets) {
 971     my $localparams = $params;
 972     $localparams->{directory} = $directory_template->($self, $localparams, $set);
 973     $localparams->{config} = $set;
 974     $self->dump($localparams);
 975     $self->dumped_objects({}); ## Clear dumped for next go, if there is one!
 976   }
 977 }
 978
 979 =head2 dump_all_config_sets
 980
 981     my %local_params = %$params;
 982     my $local_self = bless { %$self }, ref($self);
 983     $local_params{directory} = $directory_template->($self, \%local_params, $set);
 984     $local_params{config} = $set;
 985     $self->dump(\%local_params);
 986
 987
 988 Works just like L</dump> but instead of specifying a single json config set
 989 located in L</config_dir> we dump each set in turn to the specified directory.
 990
 991 The parameters are the same as for L</dump> except instead of a C<directory>
 992 parameter we have a C<directory_template> which is a coderef expected to return
 993 a scalar that is a root directory where we will do the actual dumping.  This
 994 coderef get three arguments: C<$self>, C<$params> and C<$set_name>.  For
 995 example:
 996
 997     $fixture->dump_all_config_sets({
 998       schema => $schema,
 999       directory_template => sub {
1000         my ($fixture, $params, $set) = @_;
1001         return File::Spec->catdir('var', 'fixtures', $params->{schema}->version, $set);
1002       },
1003     });
1004
1005 =cut
1006
1007 sub dump_all_config_sets {
1008   my ($self, $params) = @_;
1009   $self->dump_config_sets({
1010     %$params,
1011     configs=>[$self->available_config_sets],
1012   });
1013 }
1014
1015 =head2 populate
1016
1017 =over 4
1018
1019 =item Arguments: \%$attrs
1020
1021 =item Return Value: 1
1022
1023 =back
1024
1025  $fixtures->populate( {
1026    # directory to look for fixtures in, as specified to dump
1027    directory => '/home/me/app/fixtures',
1028
1029    # DDL to deploy
1030    ddl => '/home/me/app/sql/ddl.sql',
1031
1032    # database to clear, deploy and then populate
1033    connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password'],
1034
1035    # DDL to deploy after populating records, ie. FK constraints
1036    post_ddl => '/home/me/app/sql/post_ddl.sql',
1037
1038    # use CASCADE option when dropping tables
1039    cascade => 1,
1040
1041    # optional, set to 1 to run ddl but not populate
1042    no_populate => 0,
1043
1044         # optional, set to 1 to run each fixture through ->create rather than have
1045    # each $rs populated using $rs->populate. Useful if you have overridden new() logic
1046         # that effects the value of column(s).
1047         use_create => 0,
1048
1049    # Dont try to clean the database, just populate over whats there. Requires
1050    # schema option. Use this if you want to handle removing old data yourself
1051    # no_deploy => 1
1052    # schema => $schema
1053  } );
1054
1055 In this case the database app_dev will be cleared of all tables, then the
1056 specified DDL deployed to it, then finally all fixtures found in
1057 /home/me/app/fixtures will be added to it. populate will generate its own
1058 DBIx::Class schema from the DDL rather than being passed one to use. This is
1059 better as custom insert methods are avoided which can to get in the way. In
1060 some cases you might not have a DDL, and so this method will eventually allow a
1061 $schema object to be passed instead.
1062
1063 If needed, you can specify a post_ddl attribute which is a DDL to be applied
1064 after all the fixtures have been added to the database. A good use of this
1065 option would be to add foreign key constraints since databases like Postgresql
1066 cannot disable foreign key checks.
1067
1068 If your tables have foreign key constraints you may want to use the cascade
1069 attribute which will make the drop table functionality cascade, ie 'DROP TABLE
1070 $table CASCADE'.
1071
1072 C<directory> is a required attribute.
1073
1074 If you wish for DBIx::Class::Fixtures to clear the database for you pass in
1075 C<dll> (path to a DDL sql file) and C<connection_details> (array ref  of DSN,
1076 user and pass).
1077
1078 If you wish to deal with cleaning the schema yourself, then pass in a C<schema>
1079 attribute containing the connected schema you wish to operate on and set the
1080 C<no_deploy> attribute.
1081
1082 =cut
1083
1084 sub populate {
1085   my $self = shift;
1086   my ($params) = @_;
1087   DBIx::Class::Exception->throw('first arg to populate must be hash ref')
1088     unless ref $params eq 'HASH';
1089
1090   DBIx::Class::Exception->throw('directory param not specified')
1091     unless $params->{directory};
1092
1093   my $fixture_dir = dir(delete $params->{directory});
1094   DBIx::Class::Exception->throw("fixture directory '$fixture_dir' does not exist")
1095     unless -d $fixture_dir;
1096
1097   my $ddl_file;
1098   my $dbh;
1099   my $schema;
1100   if ($params->{ddl} && $params->{connection_details}) {
1101     $ddl_file = file(delete $params->{ddl});
1102     unless (-e $ddl_file) {
1103       return DBIx::Class::Exception->throw('DDL does not exist at ' . $ddl_file);
1104     }
1105     unless (ref $params->{connection_details} eq 'ARRAY') {
1106       return DBIx::Class::Exception->throw('connection details must be an arrayref');
1107     }
1108     $schema = $self->_generate_schema({
1109       ddl => $ddl_file,
1110       connection_details => delete $params->{connection_details},
1111       %{$params}
1112     });
1113   } elsif ($params->{schema} && $params->{no_deploy}) {
1114     $schema = $params->{schema};
1115   } else {
1116     DBIx::Class::Exception->throw('you must set the ddl and connection_details params');
1117   }
1118
1119
1120   return 1 if $params->{no_populate};
1121
1122   $self->msg("\nimporting fixtures");
1123   my $tmp_fixture_dir = dir($fixture_dir, "-~populate~-" . $<);
1124   my $version_file = file($fixture_dir, '_dumper_version');
1125 #  DBIx::Class::Exception->throw('no version file found');
1126 #    unless -e $version_file;
1127
1128   if (-e $tmp_fixture_dir) {
1129     $self->msg("- deleting existing temp directory $tmp_fixture_dir");
1130     $tmp_fixture_dir->rmtree;
1131   }
1132   $self->msg("- creating temp dir");
1133   $tmp_fixture_dir->mkpath();
1134   for ( map { $schema->source($_)->from } $schema->sources) {
1135     my $from_dir = $fixture_dir->subdir($_);
1136     next unless -e $from_dir;
1137     dircopy($from_dir, $tmp_fixture_dir->subdir($_) );
1138   }
1139
1140   unless (-d $tmp_fixture_dir) {
1141     DBIx::Class::Exception->throw("Unable to create temporary fixtures dir: $tmp_fixture_dir: $!");
1142   }
1143
1144   my $fixup_visitor;
1145   my $formatter = $schema->storage->datetime_parser;
1146   unless ($@ || !$formatter) {
1147     my %callbacks;
1148     if ($params->{datetime_relative_to}) {
1149       $callbacks{'DateTime::Duration'} = sub {
1150         $params->{datetime_relative_to}->clone->add_duration($_);
1151       };
1152     } else {
1153       $callbacks{'DateTime::Duration'} = sub {
1154         $formatter->format_datetime(DateTime->today->add_duration($_))
1155       };
1156     }
1157     $callbacks{object} ||= "visit_ref";
1158     $fixup_visitor = new Data::Visitor::Callback(%callbacks);
1159   }
1160
1161   $schema->storage->txn_do(sub {
1162     $schema->storage->with_deferred_fk_checks(sub {
1163       foreach my $source (sort $schema->sources) {
1164         $self->msg("- adding " . $source);
1165         my $rs = $schema->resultset($source);
1166         my $source_dir = $tmp_fixture_dir->subdir( $rs->result_source->from );
1167         next unless (-e $source_dir);
1168         my @rows;
1169         while (my $file = $source_dir->next) {
1170           next unless ($file =~ /\.fix$/);
1171           next if $file->is_dir;
1172           my $contents = $file->slurp;
1173           my $HASH1;
1174           eval($contents);
1175           $HASH1 = $fixup_visitor->visit($HASH1) if $fixup_visitor;
1176           if ( $params->{use_create} ) {
1177             $rs->create( $HASH1 );
1178           } else {
1179             push(@rows, $HASH1);
1180           }
1181         }
1182         $rs->populate(\@rows) if scalar(@rows);
1183       }
1184     });
1185   });
1186   $self->do_post_ddl( {
1187     schema=>$schema,
1188     post_ddl=>$params->{post_ddl}
1189   } ) if $params->{post_ddl};
1190
1191   $self->msg("- fixtures imported");
1192   $self->msg("- cleaning up");
1193   $tmp_fixture_dir->rmtree;
1194   return 1;
1195 }
1196
1197 sub do_post_ddl {
1198   my ($self, $params) = @_;
1199
1200   my $schema = $params->{schema};
1201   my $data = _read_sql($params->{post_ddl});
1202   foreach (@$data) {
1203     eval { $schema->storage->dbh->do($_) or warn "SQL was:\n $_"};
1204           if ($@ && !$self->{ignore_sql_errors}) { die "SQL was:\n $_\n$@"; }
1205   }
1206   $self->msg("- finished importing post-populate DDL into DB");
1207 }
1208
1209 sub msg {
1210   my $self = shift;
1211   my $subject = shift || return;
1212   my $level = shift || 1;
1213   return unless $self->debug >= $level;
1214   if (ref $subject) {
1215         print Dumper($subject);
1216   } else {
1217         print $subject . "\n";
1218   }
1219 }
1220
1221 =head1 AUTHOR
1222
1223   Luke Saunders <luke@shadowcatsystems.co.uk>
1224
1225   Initial development sponsored by and (c) Takkle, Inc. 2007
1226
1227 =head1 CONTRIBUTORS
1228
1229   Ash Berlin <ash@shadowcatsystems.co.uk>
1230
1231   Matt S. Trout <mst@shadowcatsystems.co.uk>
1232
1233   Drew Taylor <taylor.andrew.j@gmail.com>
1234
1235   Frank Switalski <fswitalski@gmail.com>
1236
1237 =head1 LICENSE
1238
1239   This library is free software under the same license as perl itself
1240
1241 =cut
1242
1243 1;