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.001011
  30
  31 =cut
  32
  33 our $VERSION = '1.001011';
  34
  35 =head1 NAME
  36
  37 DBIx::Class::Fixtures
  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 dump
 438
 439 =over 4
 440
 441 =item Arguments: \%$attrs
 442
 443 =item Return Value: 1
 444
 445 =back
 446
 447  $fixtures->dump({
 448    config => 'set_config.json', # config file to use. must be in the config
 449                                 # directory specified in the constructor
 450    schema => $source_dbic_schema,
 451    directory => '/home/me/app/fixtures' # output directory
 452  });
 453
 454 or
 455
 456  $fixtures->dump({
 457    all => 1, # just dump everything that's in the schema
 458    schema => $source_dbic_schema,
 459    directory => '/home/me/app/fixtures' # output directory
 460  });
 461
 462 In this case objects will be dumped to subdirectories in the specified
 463 directory. For example:
 464
 465  /home/me/app/fixtures/artist/1.fix
 466  /home/me/app/fixtures/artist/3.fix
 467  /home/me/app/fixtures/producer/5.fix
 468
 469 schema and directory are required attributes. also, one of config or all must
 470 be specified.
 471
 472 Lastly, the C<config> parameter can be a Perl HashRef instead of a file name.
 473 If this form is used your HashRef should conform to the structure rules defined
 474 for the JSON representations.
 475
 476 =cut
 477
 478 sub dump {
 479   my $self = shift;
 480
 481   my ($params) = @_;
 482   unless (ref $params eq 'HASH') {
 483     return DBIx::Class::Exception->throw('first arg to dump must be hash ref');
 484   }
 485
 486   foreach my $param (qw/schema directory/) {
 487     unless ($params->{$param}) {
 488       return DBIx::Class::Exception->throw($param . ' param not specified');
 489     }
 490   }
 491
 492   if($params->{excludes} && !$params->{all}) {
 493     return DBIx::Class::Exception->throw("'excludes' param only works when using the 'all' param");
 494   }
 495
 496   my $schema = $params->{schema};
 497   my $config;
 498   if ($params->{config}) {
 499     $config = ref $params->{config} eq 'HASH' ?
 500       $params->{config} :
 501       do {
 502         #read config
 503         my $config_file = $self->config_dir->file($params->{config});
 504         $self->load_config_file($config_file);
 505       };
 506   } elsif ($params->{all}) {
 507     my %excludes = map {$_=>1} @{$params->{excludes}||[]};
 508     $config = {
 509       might_have => { fetch => 0 },
 510       has_many => { fetch => 0 },
 511       belongs_to => { fetch => 0 },
 512       sets => [
 513         map {
 514           { class => $_, quantity => 'all' };
 515         } grep {
 516           !$excludes{$_}
 517         } $schema->sources],
 518     };
 519   } else {
 520     DBIx::Class::Exception->throw('must pass config or set all');
 521   }
 522
 523   my $output_dir = dir($params->{directory});
 524   unless (-e $output_dir) {
 525     $output_dir->mkpath ||
 526     DBIx::Class::Exception->throw("output directory does not exist at $output_dir");
 527   }
 528
 529   $self->msg("generating  fixtures");
 530   my $tmp_output_dir = dir($output_dir, '-~dump~-' . $<);
 531
 532   if (-e $tmp_output_dir) {
 533     $self->msg("- clearing existing $tmp_output_dir");
 534     $tmp_output_dir->rmtree;
 535   }
 536   $self->msg("- creating $tmp_output_dir");
 537   $tmp_output_dir->mkpath;
 538
 539   # write version file (for the potential benefit of populate)
 540   $tmp_output_dir->file('_dumper_version')
 541                  ->openw
 542                  ->print($VERSION);
 543
 544   $config->{rules} ||= {};
 545   my @sources = sort { $a->{class} cmp $b->{class} } @{delete $config->{sets}};
 546
 547   while ( my ($k,$v) = each %{ $config->{rules} } ) {
 548     if ( my $source = eval { $schema->source($k) } ) {
 549       $config->{rules}{$source->source_name} = $v;
 550     }
 551   }
 552
 553   foreach my $source (@sources) {
 554     # apply rule to set if specified
 555     my $rule = $config->{rules}->{$source->{class}};
 556     $source = merge( $source, $rule ) if ($rule);
 557
 558     # fetch objects
 559     my $rs = $schema->resultset($source->{class});
 560
 561     if ($source->{cond} and ref $source->{cond} eq 'HASH') {
 562       # if value starts with \ assume it's meant to be passed as a scalar ref
 563       # to dbic. ideally this would substitute deeply
 564       $source->{cond} = {
 565         map {
 566           $_ => ($source->{cond}->{$_} =~ s/^\\//) ? \$source->{cond}->{$_}
 567                                                    : $source->{cond}->{$_}
 568         } keys %{$source->{cond}}
 569       };
 570     }
 571
 572     $rs = $rs->search($source->{cond}, { join => $source->{join} })
 573       if $source->{cond};
 574
 575     $self->msg("- dumping $source->{class}");
 576
 577     my %source_options = ( set => { %{$config}, %{$source} } );
 578     if ($source->{quantity}) {
 579       $rs = $rs->search({}, { order_by => $source->{order_by} })
 580         if $source->{order_by};
 581
 582       if ($source->{quantity} =~ /^\d+$/) {
 583         $rs = $rs->search({}, { rows => $source->{quantity} });
 584       } elsif ($source->{quantity} ne 'all') {
 585         DBIx::Class::Exception->throw("invalid value for quantity - $source->{quantity}");
 586       }
 587     }
 588     elsif ($source->{ids} && @{$source->{ids}}) {
 589       my @ids = @{$source->{ids}};
 590       my (@pks) = $rs->result_source->primary_columns;
 591       die "Can't dump multiple col-pks using 'id' option" if @pks > 1;
 592       $rs = $rs->search_rs( { $pks[0] => { -in => \@ids } } );
 593     }
 594     else {
 595       DBIx::Class::Exception->throw('must specify either quantity or ids');
 596     }
 597
 598     $source_options{set_dir} = $tmp_output_dir;
 599     $self->dump_rs($rs, \%source_options );
 600   }
 601
 602   # clear existing output dir
 603   foreach my $child ($output_dir->children) {
 604     if ($child->is_dir) {
 605       next if ($child eq $tmp_output_dir);
 606       if (grep { $_ =~ /\.fix/ } $child->children) {
 607         $child->rmtree;
 608       }
 609     } elsif ($child =~ /_dumper_version$/) {
 610       $child->remove;
 611     }
 612   }
 613
 614   $self->msg("- moving temp dir to $output_dir");
 615   move($_, dir($output_dir, $_->relative($_->parent)->stringify))
 616     for $tmp_output_dir->children;
 617
 618   if (-e $output_dir) {
 619     $self->msg("- clearing tmp dir $tmp_output_dir");
 620     # delete existing fixture set
 621     $tmp_output_dir->remove;
 622   }
 623
 624   $self->msg("done");
 625
 626   return 1;
 627 }
 628
 629 sub load_config_file {
 630   my ($self, $config_file) = @_;
 631   DBIx::Class::Exception->throw("config does not exist at $config_file")
 632     unless -e $config_file;
 633
 634   my $config = Config::Any::JSON->load($config_file);
 635
 636   #process includes
 637   if (my $incs = $config->{includes}) {
 638     $self->msg($incs);
 639     DBIx::Class::Exception->throw(
 640       'includes params of config must be an array ref of hashrefs'
 641     ) unless ref $incs eq 'ARRAY';
 642
 643     foreach my $include_config (@$incs) {
 644       DBIx::Class::Exception->throw(
 645         'includes params of config must be an array ref of hashrefs'
 646       ) unless (ref $include_config eq 'HASH') && $include_config->{file};
 647
 648       my $include_file = $self->config_dir->file($include_config->{file});
 649
 650       DBIx::Class::Exception->throw("config does not exist at $include_file")
 651         unless -e $include_file;
 652
 653       my $include = Config::Any::JSON->load($include_file);
 654       $self->msg($include);
 655       $config = merge( $config, $include );
 656     }
 657     delete $config->{includes};
 658   }
 659
 660   # validate config
 661   return DBIx::Class::Exception->throw('config has no sets')
 662     unless $config && $config->{sets} &&
 663            ref $config->{sets} eq 'ARRAY' && scalar @{$config->{sets}};
 664
 665   $config->{might_have} = { fetch => 0 } unless exists $config->{might_have};
 666   $config->{has_many} = { fetch => 0 }   unless exists $config->{has_many};
 667   $config->{belongs_to} = { fetch => 1 } unless exists $config->{belongs_to};
 668
 669   return $config;
 670 }
 671
 672 sub dump_rs {
 673     my ($self, $rs, $params) = @_;
 674
 675     while (my $row = $rs->next) {
 676         $self->dump_object($row, $params);
 677     }
 678 }
 679
 680 sub dump_object {
 681   my ($self, $object, $params) = @_;
 682   my $set = $params->{set};
 683   die 'no dir passed to dump_object' unless $params->{set_dir};
 684   die 'no object passed to dump_object' unless $object;
 685
 686   my @inherited_attrs = @{$self->_inherited_attributes};
 687
 688   my @pk_vals = map {
 689     $object->get_column($_)
 690   } $object->primary_columns;
 691
 692   my $key = join("\0", @pk_vals);
 693
 694   my $src = $object->result_source;
 695   my $exists = $self->dumped_objects->{$src->name}{$key}++;
 696
 697
 698   # write dir and gen filename
 699   my $source_dir = $params->{set_dir}->subdir(lc $src->from);
 700   $source_dir->mkpath(0, 0777);
 701
 702   # strip dir separators from file name
 703   my $file = $source_dir->file(
 704       join('-', map { s|[/\\]|_|g; $_; } @pk_vals) . '.fix'
 705   );
 706
 707
 708   # write file
 709   unless ($exists) {
 710     $self->msg('-- dumping ' . $file->stringify, 2);
 711     my %ds = $object->get_columns;
 712
 713     # mess with dates if specified
 714     if ($set->{datetime_relative}) {
 715       my $formatter= $object->result_source->schema->storage->datetime_parser;
 716       unless ($@ || !$formatter) {
 717         my $dt;
 718         if ($set->{datetime_relative} eq 'today') {
 719           $dt = DateTime->today;
 720         } else {
 721           $dt = $formatter->parse_datetime($set->{datetime_relative}) unless ($@);
 722         }
 723
 724         while (my ($col, $value) = each %ds) {
 725           my $col_info = $object->result_source->column_info($col);
 726
 727           next unless $value
 728             && $col_info->{_inflate_info}
 729               && uc($col_info->{data_type}) eq 'DATETIME';
 730
 731           $ds{$col} = $object->get_inflated_column($col)->subtract_datetime($dt);
 732         }
 733       } else {
 734         warn "datetime_relative not supported for this db driver at the moment";
 735       }
 736     }
 737
 738     # do the actual dumping
 739     my $serialized = Dump(\%ds)->Out();
 740     $file->openw->print($serialized);
 741   }
 742
 743   # don't bother looking at rels unless we are actually planning to dump at least one type
 744   my ($might_have, $belongs_to, $has_many) = map {
 745     $set->{$_}{fetch} || $set->{rules}{$src->source_name}{$_}{fetch}
 746   } qw/might_have belongs_to has_many/;
 747
 748   return unless $might_have
 749              || $belongs_to
 750              || $has_many
 751              || $set->{fetch};
 752
 753   # dump rels of object
 754   unless ($exists) {
 755     foreach my $name (sort $src->relationships) {
 756       my $info = $src->relationship_info($name);
 757       my $r_source = $src->related_source($name);
 758       # if belongs_to or might_have with might_have param set or has_many with
 759       # has_many param set then
 760       if (
 761             ( $info->{attrs}{accessor} eq 'single' &&
 762               (!$info->{attrs}{join_type} || $might_have)
 763             )
 764          || $info->{attrs}{accessor} eq 'filter'
 765          ||
 766             ($info->{attrs}{accessor} eq 'multi' && $has_many)
 767       ) {
 768         my $related_rs = $object->related_resultset($name);
 769         my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 770         # these parts of the rule only apply to has_many rels
 771         if ($rule && $info->{attrs}{accessor} eq 'multi') {
 772           $related_rs = $related_rs->search(
 773             $rule->{cond},
 774             { join => $rule->{join} }
 775           ) if ($rule->{cond});
 776
 777           $related_rs = $related_rs->search(
 778             {},
 779             { rows => $rule->{quantity} }
 780           ) if ($rule->{quantity} && $rule->{quantity} ne 'all');
 781
 782           $related_rs = $related_rs->search(
 783             {},
 784             { order_by => $rule->{order_by} }
 785           ) if ($rule->{order_by});
 786
 787         }
 788         if ($set->{has_many}{quantity} &&
 789             $set->{has_many}{quantity} =~ /^\d+$/) {
 790           $related_rs = $related_rs->search(
 791             {},
 792             { rows => $set->{has_many}->{quantity} }
 793           );
 794         }
 795
 796         my %c_params = %{$params};
 797         # inherit date param
 798         my %mock_set = map {
 799           $_ => $set->{$_}
 800         } grep { $set->{$_} } @inherited_attrs;
 801
 802         $c_params{set} = \%mock_set;
 803         $c_params{set} = merge( $c_params{set}, $rule)
 804           if $rule && $rule->{fetch};
 805
 806         $self->dump_rs($related_rs, \%c_params);
 807       }
 808     }
 809   }
 810
 811   return unless $set && $set->{fetch};
 812   foreach my $fetch (@{$set->{fetch}}) {
 813     # inherit date param
 814     $fetch->{$_} = $set->{$_} foreach
 815       grep { !$fetch->{$_} && $set->{$_} } @inherited_attrs;
 816     my $related_rs = $object->related_resultset($fetch->{rel});
 817     my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 818
 819     if ($rule) {
 820       my $info = $object->result_source->relationship_info($fetch->{rel});
 821       if ($info->{attrs}{accessor} eq 'multi') {
 822         $fetch = merge( $fetch, $rule );
 823       } elsif ($rule->{fetch}) {
 824         $fetch = merge( $fetch, { fetch => $rule->{fetch} } );
 825       }
 826     }
 827
 828     die "relationship $fetch->{rel} does not exist for " . $src->source_name
 829       unless ($related_rs);
 830
 831     if ($fetch->{cond} and ref $fetch->{cond} eq 'HASH') {
 832       # if value starts with \ assume it's meant to be passed as a scalar ref
 833       # to dbic.  ideally this would substitute deeply
 834       $fetch->{cond} = { map {
 835           $_ => ($fetch->{cond}->{$_} =~ s/^\\//) ? \$fetch->{cond}->{$_}
 836                                                   : $fetch->{cond}->{$_}
 837       } keys %{$fetch->{cond}} };
 838     }
 839
 840     $related_rs = $related_rs->search(
 841       $fetch->{cond},
 842       { join => $fetch->{join} }
 843     ) if $fetch->{cond};
 844
 845     $related_rs = $related_rs->search(
 846       {},
 847       { rows => $fetch->{quantity} }
 848     ) if $fetch->{quantity} && $fetch->{quantity} ne 'all';
 849     $related_rs = $related_rs->search(
 850       {},
 851       { order_by => $fetch->{order_by} }
 852     ) if $fetch->{order_by};
 853
 854     $self->dump_rs($related_rs, { %{$params}, set => $fetch });
 855   }
 856 }
 857
 858 sub _generate_schema {
 859   my $self = shift;
 860   my $params = shift || {};
 861   require DBI;
 862   $self->msg("\ncreating schema");
 863
 864   my $schema_class = $self->schema_class || "DBIx::Class::Fixtures::Schema";
 865   eval "require $schema_class";
 866   die $@ if $@;
 867
 868   my $pre_schema;
 869   my $connection_details = $params->{connection_details};
 870
 871   $namespace_counter++;
 872
 873   my $namespace = "DBIx::Class::Fixtures::GeneratedSchema_$namespace_counter";
 874   Class::C3::Componentised->inject_base( $namespace => $schema_class );
 875
 876   $pre_schema = $namespace->connect(@{$connection_details});
 877   unless( $pre_schema ) {
 878     return DBIx::Class::Exception->throw('connection details not valid');
 879   }
 880   my @tables = map { $pre_schema->source($_)->from } $pre_schema->sources;
 881   $self->msg("Tables to drop: [". join(', ', sort @tables) . "]");
 882   my $dbh = $pre_schema->storage->dbh;
 883
 884   # clear existing db
 885   $self->msg("- clearing DB of existing tables");
 886   $pre_schema->storage->txn_do(sub {
 887     $pre_schema->storage->with_deferred_fk_checks(sub {
 888       foreach my $table (@tables) {
 889         eval {
 890           $dbh->do("drop table $table" . ($params->{cascade} ? ' cascade' : '') )
 891         };
 892       }
 893     });
 894   });
 895
 896   # import new ddl file to db
 897   my $ddl_file = $params->{ddl};
 898   $self->msg("- deploying schema using $ddl_file");
 899   my $data = _read_sql($ddl_file);
 900   foreach (@$data) {
 901     eval { $dbh->do($_) or warn "SQL was:\n $_"};
 902           if ($@ && !$self->{ignore_sql_errors}) { die "SQL was:\n $_\n$@"; }
 903   }
 904   $self->msg("- finished importing DDL into DB");
 905
 906   # load schema object from our new DB
 907   $namespace_counter++;
 908   my $namespace2 = "DBIx::Class::Fixtures::GeneratedSchema_$namespace_counter";
 909   Class::C3::Componentised->inject_base( $namespace2 => $schema_class );
 910   my $schema = $namespace2->connect(@{$connection_details});
 911   return $schema;
 912 }
 913
 914 sub _read_sql {
 915   my $ddl_file = shift;
 916   my $fh;
 917   open $fh, "<$ddl_file" or die ("Can't open DDL file, $ddl_file ($!)");
 918   my @data = split(/\n/, join('', <$fh>));
 919   @data = grep(!/^--/, @data);
 920   @data = split(/;/, join('', @data));
 921   close($fh);
 922   @data = grep { $_ && $_ !~ /^-- / } @data;
 923   return \@data;
 924 }
 925
 926 =head2 populate
 927
 928 =over 4
 929
 930 =item Arguments: \%$attrs
 931
 932 =item Return Value: 1
 933
 934 =back
 935
 936  $fixtures->populate( {
 937    # directory to look for fixtures in, as specified to dump
 938    directory => '/home/me/app/fixtures',
 939
 940    # DDL to deploy
 941    ddl => '/home/me/app/sql/ddl.sql',
 942
 943    # database to clear, deploy and then populate
 944    connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password'],
 945
 946    # DDL to deploy after populating records, ie. FK constraints
 947    post_ddl => '/home/me/app/sql/post_ddl.sql',
 948
 949    # use CASCADE option when dropping tables
 950    cascade => 1,
 951
 952    # optional, set to 1 to run ddl but not populate
 953    no_populate => 0,
 954
 955         # optional, set to 1 to run each fixture through ->create rather than have
 956    # each $rs populated using $rs->populate. Useful if you have overridden new() logic
 957         # that effects the value of column(s).
 958         use_create => 0,
 959
 960    # Dont try to clean the database, just populate over whats there. Requires
 961    # schema option. Use this if you want to handle removing old data yourself
 962    # no_deploy => 1
 963    # schema => $schema
 964  } );
 965
 966 In this case the database app_dev will be cleared of all tables, then the
 967 specified DDL deployed to it, then finally all fixtures found in
 968 /home/me/app/fixtures will be added to it. populate will generate its own
 969 DBIx::Class schema from the DDL rather than being passed one to use. This is
 970 better as custom insert methods are avoided which can to get in the way. In
 971 some cases you might not have a DDL, and so this method will eventually allow a
 972 $schema object to be passed instead.
 973
 974 If needed, you can specify a post_ddl attribute which is a DDL to be applied
 975 after all the fixtures have been added to the database. A good use of this
 976 option would be to add foreign key constraints since databases like Postgresql
 977 cannot disable foreign key checks.
 978
 979 If your tables have foreign key constraints you may want to use the cascade
 980 attribute which will make the drop table functionality cascade, ie 'DROP TABLE
 981 $table CASCADE'.
 982
 983 C<directory> is a required attribute.
 984
 985 If you wish for DBIx::Class::Fixtures to clear the database for you pass in
 986 C<dll> (path to a DDL sql file) and C<connection_details> (array ref  of DSN,
 987 user and pass).
 988
 989 If you wish to deal with cleaning the schema yourself, then pass in a C<schema>
 990 attribute containing the connected schema you wish to operate on and set the
 991 C<no_deploy> attribute.
 992
 993 =cut
 994
 995 sub populate {
 996   my $self = shift;
 997   my ($params) = @_;
 998   DBIx::Class::Exception->throw('first arg to populate must be hash ref')
 999     unless ref $params eq 'HASH';
1000
1001   DBIx::Class::Exception->throw('directory param not specified')
1002     unless $params->{directory};
1003
1004   my $fixture_dir = dir(delete $params->{directory});
1005   DBIx::Class::Exception->throw("fixture directory '$fixture_dir' does not exist")
1006     unless -d $fixture_dir;
1007
1008   my $ddl_file;
1009   my $dbh;
1010   my $schema;
1011   if ($params->{ddl} && $params->{connection_details}) {
1012     $ddl_file = file(delete $params->{ddl});
1013     unless (-e $ddl_file) {
1014       return DBIx::Class::Exception->throw('DDL does not exist at ' . $ddl_file);
1015     }
1016     unless (ref $params->{connection_details} eq 'ARRAY') {
1017       return DBIx::Class::Exception->throw('connection details must be an arrayref');
1018     }
1019     $schema = $self->_generate_schema({
1020       ddl => $ddl_file,
1021       connection_details => delete $params->{connection_details},
1022       %{$params}
1023     });
1024   } elsif ($params->{schema} && $params->{no_deploy}) {
1025     $schema = $params->{schema};
1026   } else {
1027     DBIx::Class::Exception->throw('you must set the ddl and connection_details params');
1028   }
1029
1030
1031   return 1 if $params->{no_populate};
1032
1033   $self->msg("\nimporting fixtures");
1034   my $tmp_fixture_dir = dir($fixture_dir, "-~populate~-" . $<);
1035   my $version_file = file($fixture_dir, '_dumper_version');
1036 #  DBIx::Class::Exception->throw('no version file found');
1037 #    unless -e $version_file;
1038
1039   if (-e $tmp_fixture_dir) {
1040     $self->msg("- deleting existing temp directory $tmp_fixture_dir");
1041     $tmp_fixture_dir->rmtree;
1042   }
1043   $self->msg("- creating temp dir");
1044   $tmp_fixture_dir->mkpath();
1045   for ( map { $schema->source($_)->from } $schema->sources) {
1046     my $from_dir = $fixture_dir->subdir($_);
1047     next unless -e $from_dir;
1048     dircopy($from_dir, $tmp_fixture_dir->subdir($_) );
1049   }
1050
1051   unless (-d $tmp_fixture_dir) {
1052     DBIx::Class::Exception->throw("Unable to create temporary fixtures dir: $tmp_fixture_dir: $!");
1053   }
1054
1055   my $fixup_visitor;
1056   my $formatter = $schema->storage->datetime_parser;
1057   unless ($@ || !$formatter) {
1058     my %callbacks;
1059     if ($params->{datetime_relative_to}) {
1060       $callbacks{'DateTime::Duration'} = sub {
1061         $params->{datetime_relative_to}->clone->add_duration($_);
1062       };
1063     } else {
1064       $callbacks{'DateTime::Duration'} = sub {
1065         $formatter->format_datetime(DateTime->today->add_duration($_))
1066       };
1067     }
1068     $callbacks{object} ||= "visit_ref";
1069     $fixup_visitor = new Data::Visitor::Callback(%callbacks);
1070   }
1071
1072   $schema->storage->txn_do(sub {
1073     $schema->storage->with_deferred_fk_checks(sub {
1074       foreach my $source (sort $schema->sources) {
1075         $self->msg("- adding " . $source);
1076         my $rs = $schema->resultset($source);
1077         my $source_dir = $tmp_fixture_dir->subdir( lc $rs->result_source->from );
1078         next unless (-e $source_dir);
1079         my @rows;
1080         while (my $file = $source_dir->next) {
1081           next unless ($file =~ /\.fix$/);
1082           next if $file->is_dir;
1083           my $contents = $file->slurp;
1084           my $HASH1;
1085           eval($contents);
1086           $HASH1 = $fixup_visitor->visit($HASH1) if $fixup_visitor;
1087           if ( $params->{use_create} ) {
1088             $rs->create( $HASH1 );
1089           } else {
1090             push(@rows, $HASH1);
1091           }
1092         }
1093         $rs->populate(\@rows) if scalar(@rows);
1094       }
1095     });
1096   });
1097   $self->do_post_ddl( {
1098     schema=>$schema,
1099     post_ddl=>$params->{post_ddl}
1100   } ) if $params->{post_ddl};
1101
1102   $self->msg("- fixtures imported");
1103   $self->msg("- cleaning up");
1104   $tmp_fixture_dir->rmtree;
1105   return 1;
1106 }
1107
1108 sub do_post_ddl {
1109   my ($self, $params) = @_;
1110
1111   my $schema = $params->{schema};
1112   my $data = _read_sql($params->{post_ddl});
1113   foreach (@$data) {
1114     eval { $schema->storage->dbh->do($_) or warn "SQL was:\n $_"};
1115           if ($@ && !$self->{ignore_sql_errors}) { die "SQL was:\n $_\n$@"; }
1116   }
1117   $self->msg("- finished importing post-populate DDL into DB");
1118 }
1119
1120 sub msg {
1121   my $self = shift;
1122   my $subject = shift || return;
1123   my $level = shift || 1;
1124   return unless $self->debug >= $level;
1125   if (ref $subject) {
1126         print Dumper($subject);
1127   } else {
1128         print $subject . "\n";
1129   }
1130 }
1131
1132 =head1 AUTHOR
1133
1134   Luke Saunders <luke@shadowcatsystems.co.uk>
1135
1136   Initial development sponsored by and (c) Takkle, Inc. 2007
1137
1138 =head1 CONTRIBUTORS
1139
1140   Ash Berlin <ash@shadowcatsystems.co.uk>
1141
1142   Matt S. Trout <mst@shadowcatsystems.co.uk>
1143
1144   Drew Taylor <taylor.andrew.j@gmail.com>
1145
1146   Frank Switalski <fswitalski@gmail.com>
1147
1148 =head1 LICENSE
1149
1150   This library is free software under the same license as perl itself
1151
1152 =cut
1153
1154 1;