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 Config::Any::JSON;
  10 use Data::Dump::Streamer;
  11 use Data::Visitor::Callback;
  12 use Hash::Merge qw( merge );
  13 use Data::Dumper;
  14 use Class::C3::Componentised;
  15 use MIME::Base64;
  16 use IO::All;
  17 use File::Temp qw/tempdir/;
  18
  19 use base qw(Class::Accessor::Grouped);
  20
  21 our $namespace_counter = 0;
  22
  23 __PACKAGE__->mk_group_accessors( 'simple' => qw/config_dir
  24     _inherited_attributes debug schema_class dumped_objects config_attrs/);
  25
  26 our $VERSION = '1.001036';
  27
  28 $VERSION = eval $VERSION;
  29
  30 =head1 NAME
  31
  32 DBIx::Class::Fixtures - Dump data and repopulate a database using rules
  33
  34 =head1 SYNOPSIS
  35
  36  use DBIx::Class::Fixtures;
  37
  38  ...
  39
  40  my $fixtures = DBIx::Class::Fixtures->new({
  41      config_dir => '/home/me/app/fixture_configs'
  42  });
  43
  44  $fixtures->dump({
  45    config => 'set_config.json',
  46    schema => $source_dbic_schema,
  47    directory => '/home/me/app/fixtures'
  48  });
  49
  50  $fixtures->populate({
  51    directory => '/home/me/app/fixtures',
  52    ddl => '/home/me/app/sql/ddl.sql',
  53    connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password'],
  54    post_ddl => '/home/me/app/sql/post_ddl.sql',
  55  });
  56
  57 =head1 DESCRIPTION
  58
  59 Dump fixtures from source database to filesystem then import to another
  60 database (with same schema) at any time. Use as a constant dataset for running
  61 tests against or for populating development databases when impractical to use
  62 production clones. Describe fixture set using relations and conditions based on
  63 your DBIx::Class schema.
  64
  65 =head1 DEFINE YOUR FIXTURE SET
  66
  67 Fixture sets are currently defined in .json files which must reside in your
  68 config_dir (e.g. /home/me/app/fixture_configs/a_fixture_set.json). They
  69 describe which data to pull and dump from the source database.
  70
  71 For example:
  72
  73  {
  74    "sets": [
  75      {
  76        "class": "Artist",
  77        "ids": ["1", "3"]
  78      },
  79      {
  80        "class": "Producer",
  81        "ids": ["5"],
  82        "fetch": [
  83          {
  84            "rel": "artists",
  85            "quantity": "2"
  86          }
  87        ]
  88      }
  89    ]
  90  }
  91
  92 This will fetch artists with primary keys 1 and 3, the producer with primary
  93 key 5 and two of producer 5's artists where 'artists' is a has_many DBIx::Class
  94 rel from Producer to Artist.
  95
  96 The top level attributes are as follows:
  97
  98 =head2 sets
  99
 100 Sets must be an array of hashes, as in the example given above. Each set
 101 defines a set of objects to be included in the fixtures. For details on valid
 102 set attributes see L</SET ATTRIBUTES> below.
 103
 104 =head2 rules
 105
 106 Rules place general conditions on classes. For example if whenever an artist
 107 was dumped you also wanted all of their cds dumped too, then you could use a
 108 rule to specify this. For example:
 109
 110  {
 111    "sets": [
 112      {
 113        "class": "Artist",
 114        "ids": ["1", "3"]
 115      },
 116      {
 117        "class": "Producer",
 118        "ids": ["5"],
 119        "fetch": [
 120          {
 121            "rel": "artists",
 122            "quantity": "2"
 123          }
 124        ]
 125      }
 126    ],
 127    "rules": {
 128      "Artist": {
 129        "fetch": [ {
 130          "rel": "cds",
 131          "quantity": "all"
 132        } ]
 133      }
 134    }
 135  }
 136
 137 In this case all the cds of artists 1, 3 and all producer 5's artists will be
 138 dumped as well. Note that 'cds' is a has_many DBIx::Class relation from Artist
 139 to CD. This is eqivalent to:
 140
 141  {
 142    "sets": [
 143     {
 144        "class": "Artist",
 145        "ids": ["1", "3"],
 146        "fetch": [ {
 147          "rel": "cds",
 148          "quantity": "all"
 149        } ]
 150      },
 151      {
 152        "class": "Producer",
 153        "ids": ["5"],
 154        "fetch": [ {
 155          "rel": "artists",
 156          "quantity": "2",
 157          "fetch": [ {
 158            "rel": "cds",
 159            "quantity": "all"
 160          } ]
 161        } ]
 162      }
 163    ]
 164  }
 165
 166 rules must be a hash keyed by class name.
 167
 168 L</RULE ATTRIBUTES>
 169
 170 =head2 includes
 171
 172 To prevent repetition between configs you can include other configs. For
 173 example:
 174
 175  {
 176    "sets": [ {
 177      "class": "Producer",
 178      "ids": ["5"]
 179    } ],
 180    "includes": [
 181      { "file": "base.json" }
 182    ]
 183  }
 184
 185 Includes must be an arrayref of hashrefs where the hashrefs have key 'file'
 186 which is the name of another config file in the same directory. The original
 187 config is merged with its includes using L<Hash::Merge>.
 188
 189 =head2 datetime_relative
 190
 191 Only available for MySQL and PostgreSQL at the moment, must be a value that
 192 DateTime::Format::* can parse. For example:
 193
 194  {
 195    "sets": [ {
 196      "class": "RecentItems",
 197      "ids": ["9"]
 198    } ],
 199    "datetime_relative": "2007-10-30 00:00:00"
 200  }
 201
 202 This will work when dumping from a MySQL database and will cause any datetime
 203 fields (where datatype => 'datetime' in the column def of the schema class) to
 204 be dumped as a DateTime::Duration object relative to the date specified in the
 205 datetime_relative value. For example if the RecentItem object had a date field
 206 set to 2007-10-25, then when the fixture is imported the field will be set to 5
 207 days in the past relative to the current time.
 208
 209 =head2 might_have
 210
 211 Specifies whether to automatically dump might_have relationships. Should be a
 212 hash with one attribute - fetch. Set fetch to 1 or 0.
 213
 214  {
 215    "might_have": { "fetch": 1 },
 216    "sets": [
 217      {
 218        "class": "Artist",
 219        "ids": ["1", "3"]
 220      },
 221      {
 222        "class": "Producer",
 223        "ids": ["5"]
 224      }
 225    ]
 226  }
 227
 228 Note: belongs_to rels are automatically dumped whether you like it or not, this
 229 is to avoid FKs to nowhere when importing.  General rules on has_many rels are
 230 not accepted at this top level, but you can turn them on for individual sets -
 231 see L</SET ATTRIBUTES>.
 232
 233 =head1 SET ATTRIBUTES
 234
 235 =head2 class
 236
 237 Required attribute. Specifies the DBIx::Class object class you wish to dump.
 238
 239 =head2 ids
 240
 241 Array of primary key ids to fetch, basically causing an $rs->find($_) for each.
 242 If the id is not in the source db then it just won't get dumped, no warnings or
 243 death.
 244
 245 =head2 quantity
 246
 247 Must be either an integer or the string 'all'. Specifying an integer will
 248 effectively set the 'rows' attribute on the resultset clause, specifying 'all'
 249 will cause the rows attribute to be left off and for all matching rows to be
 250 dumped. There's no randomising here, it's just the first x rows.
 251
 252 =head2 cond
 253
 254 A hash specifying the conditions dumped objects must match. Essentially this is
 255 a JSON representation of a DBIx::Class search clause. For example:
 256
 257  {
 258    "sets": [{
 259      "class": "Artist",
 260      "quantiy": "all",
 261      "cond": { "name": "Dave" }
 262    }]
 263  }
 264
 265 This will dump all artists whose name is 'dave'. Essentially
 266 $artist_rs->search({ name => 'Dave' })->all.
 267
 268 Sometimes in a search clause it's useful to use scalar refs to do things like:
 269
 270  $artist_rs->search({ no1_singles => \'> no1_albums' })
 271
 272 This could be specified in the cond hash like so:
 273
 274  {
 275    "sets": [ {
 276      "class": "Artist",
 277      "quantiy": "all",
 278      "cond": { "no1_singles": "\> no1_albums" }
 279    } ]
 280  }
 281
 282 So if the value starts with a backslash the value is made a scalar ref before
 283 being passed to search.
 284
 285 =head2 join
 286
 287 An array of relationships to be used in the cond clause.
 288
 289  {
 290    "sets": [ {
 291      "class": "Artist",
 292      "quantiy": "all",
 293      "cond": { "cds.position": { ">": 4 } },
 294      "join": ["cds"]
 295    } ]
 296  }
 297
 298 Fetch all artists who have cds with position greater than 4.
 299
 300 =head2 fetch
 301
 302 Must be an array of hashes. Specifies which rels to also dump. For example:
 303
 304  {
 305    "sets": [ {
 306      "class": "Artist",
 307      "ids": ["1", "3"],
 308      "fetch": [ {
 309        "rel": "cds",
 310        "quantity": "3",
 311        "cond": { "position": "2" }
 312      } ]
 313    } ]
 314  }
 315
 316 Will cause the cds of artists 1 and 3 to be dumped where the cd position is 2.
 317
 318 Valid attributes are: 'rel', 'quantity', 'cond', 'has_many', 'might_have' and
 319 'join'. rel is the name of the DBIx::Class rel to follow, the rest are the same
 320 as in the set attributes. quantity is necessary for has_many relationships, but
 321 not if using for belongs_to or might_have relationships.
 322
 323 =head2 has_many
 324
 325 Specifies whether to fetch has_many rels for this set. Must be a hash
 326 containing keys fetch and quantity.
 327
 328 Set fetch to 1 if you want to fetch them, and quantity to either 'all' or an
 329 integer.
 330
 331 Be careful here, dumping has_many rels can lead to a lot of data being dumped.
 332
 333 =head2 might_have
 334
 335 As with has_many but for might_have relationships. Quantity doesn't do anything
 336 in this case.
 337
 338 This value will be inherited by all fetches in this set. This is not true for
 339 the has_many attribute.
 340
 341 =head2 external
 342
 343 In some cases your database information might be keys to values in some sort of
 344 external storage.  The classic example is you are using L<DBIx::Class::InflateColumn::FS>
 345 to store blob information on the filesystem.  In this case you may wish the ability
 346 to backup your external storage in the same way your database data.  The L</external>
 347 attribute lets you specify a handler for this type of issue.  For example:
 348
 349     {
 350         "sets": [{
 351             "class": "Photo",
 352             "quantity": "all",
 353             "external": {
 354                 "file": {
 355                     "class": "File",
 356                     "args": {"path":"__ATTR(photo_dir)__"}
 357                 }
 358             }
 359         }]
 360     }
 361
 362 This would use L<DBIx::Class::Fixtures::External::File> to read from a directory
 363 where the path to a file is specified by the C<file> field of the C<Photo> source.
 364 We use the uninflated value of the field so you need to completely handle backup
 365 and restore.  For the common case we provide  L<DBIx::Class::Fixtures::External::File>
 366 and you can create your own custom handlers by placing a '+' in the namespace:
 367
 368     "class": "+MyApp::Schema::SomeExternalStorage",
 369
 370 Although if possible I'd love to get patches to add some of the other common
 371 types (I imagine storage in MogileFS, Redis, etc or even Amazon might be popular.)
 372
 373 See L<DBIx::Class::Fixtures::External::File> for the external handler interface.
 374
 375 =head1 RULE ATTRIBUTES
 376
 377 =head2 cond
 378
 379 Same as with L</SET ATTRIBUTES>
 380
 381 =head2 fetch
 382
 383 Same as with L</SET ATTRIBUTES>
 384
 385 =head2 join
 386
 387 Same as with L</SET ATTRIBUTES>
 388
 389 =head2 has_many
 390
 391 Same as with L</SET ATTRIBUTES>
 392
 393 =head2 might_have
 394
 395 Same as with L</SET ATTRIBUTES>
 396
 397 =head1 RULE SUBSTITUTIONS
 398
 399 You can provide the following substitution patterns for your rule values. An
 400 example of this might be:
 401
 402     {
 403         "sets": [{
 404             "class": "Photo",
 405             "quantity": "__ENV(NUMBER_PHOTOS_DUMPED)__",
 406         }]
 407     }
 408
 409 =head2 ENV
 410
 411 Provide a value from %ENV
 412
 413 =head2 ATTR
 414
 415 Provide a value from L</config_attrs>
 416
 417 =head2 catfile
 418
 419 Create the path to a file from a list
 420
 421 =head2 catdir
 422
 423 Create the path to a directory from a list
 424
 425 =head1 METHODS
 426
 427 =head2 new
 428
 429 =over 4
 430
 431 =item Arguments: \%$attrs
 432
 433 =item Return Value: $fixture_object
 434
 435 =back
 436
 437 Returns a new DBIx::Class::Fixture object. %attrs can have the following
 438 parameters:
 439
 440 =over
 441
 442 =item config_dir:
 443
 444 required. must contain a valid path to the directory in which your .json
 445 configs reside.
 446
 447 =item debug:
 448
 449 determines whether to be verbose
 450
 451 =item ignore_sql_errors:
 452
 453 ignore errors on import of DDL etc
 454
 455 =item config_attrs
 456
 457 A hash of information you can use to do replacements inside your configuration
 458 sets.  For example, if your set looks like:
 459
 460    {
 461      "sets": [ {
 462        "class": "Artist",
 463        "ids": ["1", "3"],
 464        "fetch": [ {
 465          "rel": "cds",
 466          "quantity": "__ATTR(quantity)__",
 467        } ]
 468      } ]
 469    }
 470
 471     my $fixtures = DBIx::Class::Fixtures->new( {
 472       config_dir => '/home/me/app/fixture_configs'
 473       config_attrs => {
 474         quantity => 100,
 475       },
 476     });
 477
 478 You may wish to do this if you want to let whoever runs the dumps have a bit
 479 more control
 480
 481 =back
 482
 483  my $fixtures = DBIx::Class::Fixtures->new( {
 484    config_dir => '/home/me/app/fixture_configs'
 485  } );
 486
 487 =cut
 488
 489 sub new {
 490   my $class = shift;
 491
 492   my ($params) = @_;
 493   unless (ref $params eq 'HASH') {
 494     return DBIx::Class::Exception->throw('first arg to DBIx::Class::Fixtures->new() must be hash ref');
 495   }
 496
 497   unless ($params->{config_dir}) {
 498     return DBIx::Class::Exception->throw('config_dir param not specified');
 499   }
 500
 501   my $config_dir = io->dir($params->{config_dir});
 502   unless (-e $params->{config_dir}) {
 503     return DBIx::Class::Exception->throw('config_dir directory doesn\'t exist');
 504   }
 505
 506   my $self = {
 507               config_dir            => $config_dir,
 508               _inherited_attributes => [qw/datetime_relative might_have rules belongs_to/],
 509               debug                 => $params->{debug} || 0,
 510               ignore_sql_errors     => $params->{ignore_sql_errors},
 511               dumped_objects        => {},
 512               use_create            => $params->{use_create} || 0,
 513               use_find_or_create    => $params->{use_find_or_create} || 0,
 514               config_attrs          => $params->{config_attrs} || {},
 515   };
 516
 517   bless $self, $class;
 518
 519   return $self;
 520 }
 521
 522 =head2 available_config_sets
 523
 524 Returns a list of all the config sets found in the L</config_dir>.  These will
 525 be a list of the json based files containing dump rules.
 526
 527 =cut
 528
 529 my @config_sets;
 530 sub available_config_sets {
 531   @config_sets = scalar(@config_sets) ? @config_sets : map {
 532     $_->filename;
 533   } grep {
 534     -f "$_" && $_=~/json$/;
 535   } shift->config_dir->all;
 536 }
 537
 538 =head2 dump
 539
 540 =over 4
 541
 542 =item Arguments: \%$attrs
 543
 544 =item Return Value: 1
 545
 546 =back
 547
 548  $fixtures->dump({
 549    config => 'set_config.json', # config file to use. must be in the config
 550                                 # directory specified in the constructor
 551    schema => $source_dbic_schema,
 552    directory => '/home/me/app/fixtures' # output directory
 553  });
 554
 555 or
 556
 557  $fixtures->dump({
 558    all => 1, # just dump everything that's in the schema
 559    schema => $source_dbic_schema,
 560    directory => '/home/me/app/fixtures' # output directory
 561  });
 562
 563 In this case objects will be dumped to subdirectories in the specified
 564 directory. For example:
 565
 566  /home/me/app/fixtures/artist/1.fix
 567  /home/me/app/fixtures/artist/3.fix
 568  /home/me/app/fixtures/producer/5.fix
 569
 570 schema and directory are required attributes. also, one of config or all must
 571 be specified.
 572
 573 Lastly, the C<config> parameter can be a Perl HashRef instead of a file name.
 574 If this form is used your HashRef should conform to the structure rules defined
 575 for the JSON representations.
 576
 577 =cut
 578
 579 sub dump {
 580   my $self = shift;
 581
 582   my ($params) = @_;
 583   unless (ref $params eq 'HASH') {
 584     return DBIx::Class::Exception->throw('first arg to dump must be hash ref');
 585   }
 586
 587   foreach my $param (qw/schema directory/) {
 588     unless ($params->{$param}) {
 589       return DBIx::Class::Exception->throw($param . ' param not specified');
 590     }
 591   }
 592
 593   if($params->{excludes} && !$params->{all}) {
 594     return DBIx::Class::Exception->throw("'excludes' param only works when using the 'all' param");
 595   }
 596
 597   my $schema = $params->{schema};
 598   my $config;
 599   if ($params->{config}) {
 600     $config = ref $params->{config} eq 'HASH' ?
 601       $params->{config} :
 602       do {
 603         #read config
 604         my $config_file = io->catfile($self->config_dir, $params->{config});
 605         $self->load_config_file("$config_file");
 606       };
 607   } elsif ($params->{all}) {
 608     my %excludes = map {$_=>1} @{$params->{excludes}||[]};
 609     $config = {
 610       might_have => { fetch => 0 },
 611       has_many => { fetch => 0 },
 612       belongs_to => { fetch => 0 },
 613       sets => [
 614         map {
 615           { class => $_, quantity => 'all' };
 616         } grep {
 617           !$excludes{$_}
 618         } $schema->sources],
 619     };
 620   } else {
 621     DBIx::Class::Exception->throw('must pass config or set all');
 622   }
 623
 624   my $output_dir = io->dir($params->{directory});
 625   unless (-e "$output_dir") {
 626     $output_dir->mkpath ||
 627     DBIx::Class::Exception->throw("output directory does not exist at $output_dir");
 628   }
 629
 630   $self->msg("generating  fixtures");
 631   my $tmp_output_dir = io->dir(tempdir);
 632
 633   if (-e "$tmp_output_dir") {
 634     $self->msg("- clearing existing $tmp_output_dir");
 635     $tmp_output_dir->rmtree;
 636   }
 637   $self->msg("- creating $tmp_output_dir");
 638   $tmp_output_dir->mkpath;
 639
 640   # write version file (for the potential benefit of populate)
 641   $tmp_output_dir->file('_dumper_version')->print($VERSION);
 642
 643   # write our current config set
 644   $tmp_output_dir->file('_config_set')->print( Dumper $config );
 645
 646   $config->{rules} ||= {};
 647   my @sources = sort { $a->{class} cmp $b->{class} } @{delete $config->{sets}};
 648
 649   while ( my ($k,$v) = each %{ $config->{rules} } ) {
 650     if ( my $source = eval { $schema->source($k) } ) {
 651       $config->{rules}{$source->source_name} = $v;
 652     }
 653   }
 654
 655   foreach my $source (@sources) {
 656     # apply rule to set if specified
 657     my $rule = $config->{rules}->{$source->{class}};
 658     $source = merge( $source, $rule ) if ($rule);
 659
 660     # fetch objects
 661     my $rs = $schema->resultset($source->{class});
 662
 663     if ($source->{cond} and ref $source->{cond} eq 'HASH') {
 664       # if value starts with \ assume it's meant to be passed as a scalar ref
 665       # to dbic. ideally this would substitute deeply
 666       $source->{cond} = {
 667         map {
 668           $_ => ($source->{cond}->{$_} =~ s/^\\//) ? \$source->{cond}->{$_}
 669                                                    : $source->{cond}->{$_}
 670         } keys %{$source->{cond}}
 671       };
 672     }
 673
 674     $rs = $rs->search($source->{cond}, { join => $source->{join} })
 675       if $source->{cond};
 676
 677     $self->msg("- dumping $source->{class}");
 678
 679     my %source_options = ( set => { %{$config}, %{$source} } );
 680     if ($source->{quantity}) {
 681       $rs = $rs->search({}, { order_by => $source->{order_by} })
 682         if $source->{order_by};
 683
 684       if ($source->{quantity} =~ /^\d+$/) {
 685         $rs = $rs->search({}, { rows => $source->{quantity} });
 686       } elsif ($source->{quantity} ne 'all') {
 687         DBIx::Class::Exception->throw("invalid value for quantity - $source->{quantity}");
 688       }
 689     }
 690     elsif ($source->{ids} && @{$source->{ids}}) {
 691       my @ids = @{$source->{ids}};
 692       my (@pks) = $rs->result_source->primary_columns;
 693       die "Can't dump multiple col-pks using 'id' option" if @pks > 1;
 694       $rs = $rs->search_rs( { $pks[0] => { -in => \@ids } } );
 695     }
 696     else {
 697       DBIx::Class::Exception->throw('must specify either quantity or ids');
 698     }
 699
 700     $source_options{set_dir} = $tmp_output_dir;
 701     $self->dump_rs($rs, \%source_options );
 702   }
 703
 704   # clear existing output dir
 705   foreach my $child ($output_dir->all) {
 706     if ($child->is_dir) {
 707       next if ("$child" eq "$tmp_output_dir");
 708       if (grep { $_ =~ /\.fix/ } $child->all) {
 709         $child->rmtree;
 710       }
 711     } elsif ($child =~ /_dumper_version$/) {
 712       $child->unlink;
 713     }
 714   }
 715
 716   $self->msg("- moving temp dir to $output_dir");
 717   $tmp_output_dir->copy("$output_dir");
 718
 719   if (-e "$output_dir") {
 720     $self->msg("- clearing tmp dir $tmp_output_dir");
 721     # delete existing fixture set
 722     $tmp_output_dir->rmtree;
 723   }
 724
 725   $self->msg("done");
 726
 727   return 1;
 728 }
 729
 730 sub load_config_file {
 731   my ($self, $config_file) = @_;
 732   DBIx::Class::Exception->throw("config does not exist at $config_file")
 733     unless -e "$config_file";
 734
 735   my $config = Config::Any::JSON->load($config_file);
 736
 737   #process includes
 738   if (my $incs = $config->{includes}) {
 739     $self->msg($incs);
 740     DBIx::Class::Exception->throw(
 741       'includes params of config must be an array ref of hashrefs'
 742     ) unless ref $incs eq 'ARRAY';
 743
 744     foreach my $include_config (@$incs) {
 745       DBIx::Class::Exception->throw(
 746         'includes params of config must be an array ref of hashrefs'
 747       ) unless (ref $include_config eq 'HASH') && $include_config->{file};
 748
 749       my $include_file = $self->config_dir->file($include_config->{file});
 750
 751       DBIx::Class::Exception->throw("config does not exist at $include_file")
 752         unless -e "$include_file";
 753
 754       my $include = Config::Any::JSON->load($include_file);
 755       $self->msg($include);
 756       $config = merge( $config, $include );
 757     }
 758     delete $config->{includes};
 759   }
 760
 761   # validate config
 762   return DBIx::Class::Exception->throw('config has no sets')
 763     unless $config && $config->{sets} &&
 764            ref $config->{sets} eq 'ARRAY' && scalar @{$config->{sets}};
 765
 766   $config->{might_have} = { fetch => 0 } unless exists $config->{might_have};
 767   $config->{has_many} = { fetch => 0 }   unless exists $config->{has_many};
 768   $config->{belongs_to} = { fetch => 1 } unless exists $config->{belongs_to};
 769
 770   return $config;
 771 }
 772
 773 sub dump_rs {
 774     my ($self, $rs, $params) = @_;
 775
 776     while (my $row = $rs->next) {
 777         $self->dump_object($row, $params);
 778     }
 779 }
 780
 781 sub dump_object {
 782   my ($self, $object, $params) = @_;
 783   my $set = $params->{set};
 784
 785   my $v = Data::Visitor::Callback->new(
 786     plain_value => sub {
 787       my ($visitor, $data) = @_;
 788       my $subs = {
 789        ENV => sub {
 790           my ( $self, $v ) = @_;
 791           if (! defined($ENV{$v})) {
 792             return "";
 793           } else {
 794             return $ENV{ $v };
 795           }
 796         },
 797         ATTR => sub {
 798           my ($self, $v) = @_;
 799           if(my $attr = $self->config_attrs->{$v}) {
 800             return $attr;
 801           } else {
 802             return "";
 803           }
 804         },
 805         catfile => sub {
 806           my ($self, @args) = @_;
 807           "".io->catfile(@args);
 808         },
 809         catdir => sub {
 810           my ($self, @args) = @_;
 811           "".io->catdir(@args);
 812         },
 813       };
 814
 815       my $subsre = join( '|', keys %$subs );
 816       $_ =~ s{__($subsre)(?:\((.+?)\))?__}{ $subs->{ $1 }->( $self, $2 ? split( /,/, $2 ) : () ) }eg;
 817
 818       return $_;
 819     }
 820   );
 821
 822   $v->visit( $set );
 823
 824   die 'no dir passed to dump_object' unless $params->{set_dir};
 825   die 'no object passed to dump_object' unless $object;
 826
 827   my @inherited_attrs = @{$self->_inherited_attributes};
 828
 829   my @pk_vals = map {
 830     $object->get_column($_)
 831   } $object->primary_columns;
 832
 833   my $key = join("\0", @pk_vals);
 834
 835   my $src = $object->result_source;
 836   my $exists = $self->dumped_objects->{$src->name}{$key}++;
 837
 838
 839   # write dir and gen filename
 840   my $source_dir = io->catdir($params->{set_dir}, $self->_name_for_source($src));
 841   $source_dir->mkpath(0, 0777);
 842
 843   # Convert characters not allowed on windows
 844   my $file = io->catfile("$source_dir",
 845       join('-', map { s|[/\\:\*\|\?"<>]|_|g; $_; } @pk_vals) . '.fix'
 846   );
 847
 848   # write file
 849   unless ($exists) {
 850     $self->msg('-- dumping ' . "$file", 2);
 851
 852     # get_columns will return virtual columns; we just want stored columns.
 853     # columns_info keys seems to be the actual storage column names, so we'll
 854     # use that.
 855     my $col_info = $src->columns_info;
 856     my @column_names = keys %$col_info;
 857     my %columns = $object->get_columns;
 858     my %ds; @ds{@column_names} = @columns{@column_names};
 859
 860     if($set->{external}) {
 861       foreach my $field (keys %{$set->{external}}) {
 862         my $key = $ds{$field};
 863         my ($plus, $class) = ( $set->{external}->{$field}->{class}=~/^(\+)*(.+)$/);
 864         my $args = $set->{external}->{$field}->{args};
 865
 866         $class = "DBIx::Class::Fixtures::External::$class" unless $plus;
 867         eval "use $class";
 868
 869         $ds{external}->{$field} =
 870           encode_base64( $class
 871            ->backup($key => $args),'');
 872       }
 873     }
 874
 875     # mess with dates if specified
 876     if ($set->{datetime_relative}) {
 877       my $formatter= $object->result_source->schema->storage->datetime_parser;
 878       unless ($@ || !$formatter) {
 879         my $dt;
 880         if ($set->{datetime_relative} eq 'today') {
 881           $dt = DateTime->today;
 882         } else {
 883           $dt = $formatter->parse_datetime($set->{datetime_relative}) unless ($@);
 884         }
 885
 886         while (my ($col, $value) = each %ds) {
 887           my $col_info = $object->result_source->column_info($col);
 888
 889           next unless $value
 890             && $col_info->{_inflate_info}
 891               && (
 892                   (uc($col_info->{data_type}) eq 'DATETIME')
 893                     or (uc($col_info->{data_type}) eq 'DATE')
 894                     or (uc($col_info->{data_type}) eq 'TIME')
 895                     or (uc($col_info->{data_type}) eq 'TIMESTAMP')
 896                     or (uc($col_info->{data_type}) eq 'INTERVAL')
 897                  );
 898
 899           $ds{$col} = $object->get_inflated_column($col)->subtract_datetime($dt);
 900         }
 901       } else {
 902         warn "datetime_relative not supported for this db driver at the moment";
 903       }
 904     }
 905
 906     # do the actual dumping
 907     my $serialized = Dump(\%ds)->Out();
 908
 909     $file->print($serialized);
 910   }
 911
 912   # don't bother looking at rels unless we are actually planning to dump at least one type
 913   my ($might_have, $belongs_to, $has_many) = map {
 914     $set->{$_}{fetch} || $set->{rules}{$src->source_name}{$_}{fetch}
 915   } qw/might_have belongs_to has_many/;
 916
 917   return unless $might_have
 918              || $belongs_to
 919              || $has_many
 920              || $set->{fetch};
 921
 922   # dump rels of object
 923   unless ($exists) {
 924     foreach my $name (sort $src->relationships) {
 925       my $info = $src->relationship_info($name);
 926       my $r_source = $src->related_source($name);
 927       # if belongs_to or might_have with might_have param set or has_many with
 928       # has_many param set then
 929       if (
 930             ( $info->{attrs}{accessor} eq 'single' &&
 931               (!$info->{attrs}{join_type} || $might_have)
 932             )
 933          || $info->{attrs}{accessor} eq 'filter'
 934          ||
 935             ($info->{attrs}{accessor} eq 'multi' && $has_many)
 936       ) {
 937         my $related_rs = $object->related_resultset($name);
 938         my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 939         # these parts of the rule only apply to has_many rels
 940         if ($rule && $info->{attrs}{accessor} eq 'multi') {
 941           $related_rs = $related_rs->search(
 942             $rule->{cond},
 943             { join => $rule->{join} }
 944           ) if ($rule->{cond});
 945
 946           $related_rs = $related_rs->search(
 947             {},
 948             { rows => $rule->{quantity} }
 949           ) if ($rule->{quantity} && $rule->{quantity} ne 'all');
 950
 951           $related_rs = $related_rs->search(
 952             {},
 953             { order_by => $rule->{order_by} }
 954           ) if ($rule->{order_by});
 955
 956         }
 957         if ($set->{has_many}{quantity} &&
 958             $set->{has_many}{quantity} =~ /^\d+$/) {
 959           $related_rs = $related_rs->search(
 960             {},
 961             { rows => $set->{has_many}->{quantity} }
 962           );
 963         }
 964
 965         my %c_params = %{$params};
 966         # inherit date param
 967         my %mock_set = map {
 968           $_ => $set->{$_}
 969         } grep { $set->{$_} } @inherited_attrs;
 970
 971         $c_params{set} = \%mock_set;
 972         $c_params{set} = merge( $c_params{set}, $rule)
 973           if $rule && $rule->{fetch};
 974
 975         $self->dump_rs($related_rs, \%c_params);
 976       }
 977     }
 978   }
 979
 980   return unless $set && $set->{fetch};
 981   foreach my $fetch (@{$set->{fetch}}) {
 982     # inherit date param
 983     $fetch->{$_} = $set->{$_} foreach
 984       grep { !$fetch->{$_} && $set->{$_} } @inherited_attrs;
 985     my $related_rs = $object->related_resultset($fetch->{rel});
 986     my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 987
 988     if ($rule) {
 989       my $info = $object->result_source->relationship_info($fetch->{rel});
 990       if ($info->{attrs}{accessor} eq 'multi') {
 991         $fetch = merge( $fetch, $rule );
 992       } elsif ($rule->{fetch}) {
 993         $fetch = merge( $fetch, { fetch => $rule->{fetch} } );
 994       }
 995     }
 996
 997     die "relationship $fetch->{rel} does not exist for " . $src->source_name
 998       unless ($related_rs);
 999
1000     if ($fetch->{cond} and ref $fetch->{cond} eq 'HASH') {
1001       # if value starts with \ assume it's meant to be passed as a scalar ref
1002       # to dbic.  ideally this would substitute deeply
1003       $fetch->{cond} = { map {
1004           $_ => ($fetch->{cond}->{$_} =~ s/^\\//) ? \$fetch->{cond}->{$_}
1005                                                   : $fetch->{cond}->{$_}
1006       } keys %{$fetch->{cond}} };
1007     }
1008
1009     $related_rs = $related_rs->search(
1010       $fetch->{cond},
1011       { join => $fetch->{join} }
1012     ) if $fetch->{cond};
1013
1014     $related_rs = $related_rs->search(
1015       {},
1016       { rows => $fetch->{quantity} }
1017     ) if $fetch->{quantity} && $fetch->{quantity} ne 'all';
1018     $related_rs = $related_rs->search(
1019       {},
1020       { order_by => $fetch->{order_by} }
1021     ) if $fetch->{order_by};
1022
1023     $self->dump_rs($related_rs, { %{$params}, set => $fetch });
1024   }
1025 }
1026
1027 sub _generate_schema {
1028   my $self = shift;
1029   my $params = shift || {};
1030   require DBI;
1031   $self->msg("\ncreating schema");
1032
1033   my $schema_class = $self->schema_class || "DBIx::Class::Fixtures::Schema";
1034   eval "require $schema_class";
1035   die $@ if $@;
1036
1037   my $pre_schema;
1038   my $connection_details = $params->{connection_details};
1039
1040   $namespace_counter++;
1041
1042   my $namespace = "DBIx::Class::Fixtures::GeneratedSchema_$namespace_counter";
1043   Class::C3::Componentised->inject_base( $namespace => $schema_class );
1044
1045   $pre_schema = $namespace->connect(@{$connection_details});
1046   unless( $pre_schema ) {
1047     return DBIx::Class::Exception->throw('connection details not valid');
1048   }
1049   my @tables = map { $self->_name_for_source($pre_schema->source($_)) } $pre_schema->sources;
1050   $self->msg("Tables to drop: [". join(', ', sort @tables) . "]");
1051   my $dbh = $pre_schema->storage->dbh;
1052
1053   # clear existing db
1054   $self->msg("- clearing DB of existing tables");
1055   $pre_schema->storage->txn_do(sub {
1056     $pre_schema->storage->with_deferred_fk_checks(sub {
1057       foreach my $table (@tables) {
1058         eval {
1059           $dbh->do("drop table $table" . ($params->{cascade} ? ' cascade' : '') )
1060         };
1061       }
1062     });
1063   });
1064
1065   # import new ddl file to db
1066   my $ddl_file = $params->{ddl};
1067   $self->msg("- deploying schema using $ddl_file");
1068   my $data = _read_sql($ddl_file);
1069   foreach (@$data) {
1070     eval { $dbh->do($_) or warn "SQL was:\n $_"};
1071           if ($@ && !$self->{ignore_sql_errors}) { die "SQL was:\n $_\n$@"; }
1072   }
1073   $self->msg("- finished importing DDL into DB");
1074
1075   # load schema object from our new DB
1076   $namespace_counter++;
1077   my $namespace2 = "DBIx::Class::Fixtures::GeneratedSchema_$namespace_counter";
1078   Class::C3::Componentised->inject_base( $namespace2 => $schema_class );
1079   my $schema = $namespace2->connect(@{$connection_details});
1080   return $schema;
1081 }
1082
1083 sub _read_sql {
1084   my $ddl_file = shift;
1085   my $fh;
1086   open $fh, "<$ddl_file" or die ("Can't open DDL file, $ddl_file ($!)");
1087   my @data = split(/\n/, join('', <$fh>));
1088   @data = grep(!/^--/, @data);
1089   @data = split(/;/, join('', @data));
1090   close($fh);
1091   @data = grep { $_ && $_ !~ /^-- / } @data;
1092   return \@data;
1093 }
1094
1095 =head2 dump_config_sets
1096
1097 Works just like L</dump> but instead of specifying a single json config set
1098 located in L</config_dir> we dump each set named in the C<configs> parameter.
1099
1100 The parameters are the same as for L</dump> except instead of a C<directory>
1101 parameter we have a C<directory_template> which is a coderef expected to return
1102 a scalar that is a root directory where we will do the actual dumping.  This
1103 coderef get three arguments: C<$self>, C<$params> and C<$set_name>.  For
1104 example:
1105
1106     $fixture->dump_all_config_sets({
1107       schema => $schema,
1108       configs => [qw/one.json other.json/],
1109       directory_template => sub {
1110         my ($fixture, $params, $set) = @_;
1111         return io->catdir('var', 'fixtures', $params->{schema}->version, $set);
1112       },
1113     });
1114
1115 =cut
1116
1117 sub dump_config_sets {
1118   my ($self, $params) = @_;
1119   my $available_config_sets = delete $params->{configs};
1120   my $directory_template = delete $params->{directory_template} ||
1121     DBIx::Class::Exception->throw("'directory_template is required parameter");
1122
1123   for my $set (@$available_config_sets) {
1124     my $localparams = $params;
1125     $localparams->{directory} = $directory_template->($self, $localparams, $set);
1126     $localparams->{config} = $set;
1127     $self->dump($localparams);
1128     $self->dumped_objects({}); ## Clear dumped for next go, if there is one!
1129   }
1130 }
1131
1132 =head2 dump_all_config_sets
1133
1134     my %local_params = %$params;
1135     my $local_self = bless { %$self }, ref($self);
1136     $local_params{directory} = $directory_template->($self, \%local_params, $set);
1137     $local_params{config} = $set;
1138     $self->dump(\%local_params);
1139
1140
1141 Works just like L</dump> but instead of specifying a single json config set
1142 located in L</config_dir> we dump each set in turn to the specified directory.
1143
1144 The parameters are the same as for L</dump> except instead of a C<directory>
1145 parameter we have a C<directory_template> which is a coderef expected to return
1146 a scalar that is a root directory where we will do the actual dumping.  This
1147 coderef get three arguments: C<$self>, C<$params> and C<$set_name>.  For
1148 example:
1149
1150     $fixture->dump_all_config_sets({
1151       schema => $schema,
1152       directory_template => sub {
1153         my ($fixture, $params, $set) = @_;
1154         return io->catdir('var', 'fixtures', $params->{schema}->version, $set);
1155       },
1156     });
1157
1158 =cut
1159
1160 sub dump_all_config_sets {
1161   my ($self, $params) = @_;
1162   $self->dump_config_sets({
1163     %$params,
1164     configs=>[$self->available_config_sets],
1165   });
1166 }
1167
1168 =head2 populate
1169
1170 =over 4
1171
1172 =item Arguments: \%$attrs
1173
1174 =item Return Value: 1
1175
1176 =back
1177
1178  $fixtures->populate( {
1179    # directory to look for fixtures in, as specified to dump
1180    directory => '/home/me/app/fixtures',
1181
1182    # DDL to deploy
1183    ddl => '/home/me/app/sql/ddl.sql',
1184
1185    # database to clear, deploy and then populate
1186    connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password'],
1187
1188    # DDL to deploy after populating records, ie. FK constraints
1189    post_ddl => '/home/me/app/sql/post_ddl.sql',
1190
1191    # use CASCADE option when dropping tables
1192    cascade => 1,
1193
1194    # optional, set to 1 to run ddl but not populate
1195    no_populate => 0,
1196
1197    # optional, set to 1 to run each fixture through ->create rather than have
1198    # each $rs populated using $rs->populate. Useful if you have overridden new() logic
1199    # that effects the value of column(s).
1200    use_create => 0,
1201
1202    # optional, same as use_create except with find_or_create.
1203    # Useful if you are populating a persistent data store.
1204    use_find_or_create => 0,
1205
1206    # Dont try to clean the database, just populate over whats there. Requires
1207    # schema option. Use this if you want to handle removing old data yourself
1208    # no_deploy => 1
1209    # schema => $schema
1210  } );
1211
1212 In this case the database app_dev will be cleared of all tables, then the
1213 specified DDL deployed to it, then finally all fixtures found in
1214 /home/me/app/fixtures will be added to it. populate will generate its own
1215 DBIx::Class schema from the DDL rather than being passed one to use. This is
1216 better as custom insert methods are avoided which can to get in the way. In
1217 some cases you might not have a DDL, and so this method will eventually allow a
1218 $schema object to be passed instead.
1219
1220 If needed, you can specify a post_ddl attribute which is a DDL to be applied
1221 after all the fixtures have been added to the database. A good use of this
1222 option would be to add foreign key constraints since databases like Postgresql
1223 cannot disable foreign key checks.
1224
1225 If your tables have foreign key constraints you may want to use the cascade
1226 attribute which will make the drop table functionality cascade, ie 'DROP TABLE
1227 $table CASCADE'.
1228
1229 C<directory> is a required attribute.
1230
1231 If you wish for DBIx::Class::Fixtures to clear the database for you pass in
1232 C<dll> (path to a DDL sql file) and C<connection_details> (array ref  of DSN,
1233 user and pass).
1234
1235 If you wish to deal with cleaning the schema yourself, then pass in a C<schema>
1236 attribute containing the connected schema you wish to operate on and set the
1237 C<no_deploy> attribute.
1238
1239 =cut
1240
1241 sub populate {
1242   my $self = shift;
1243   my ($params) = @_;
1244   DBIx::Class::Exception->throw('first arg to populate must be hash ref')
1245     unless ref $params eq 'HASH';
1246
1247   DBIx::Class::Exception->throw('directory param not specified')
1248     unless $params->{directory};
1249
1250   my $fixture_dir = io->dir(delete $params->{directory});
1251   DBIx::Class::Exception->throw("fixture directory '$fixture_dir' does not exist")
1252     unless -d "$fixture_dir";
1253
1254   my $ddl_file;
1255   my $dbh;
1256   my $schema;
1257   if ($params->{ddl} && $params->{connection_details}) {
1258     $ddl_file = io->file(delete $params->{ddl});
1259     unless (-e "$ddl_file") {
1260       return DBIx::Class::Exception->throw('DDL does not exist at ' . $ddl_file);
1261     }
1262     unless (ref $params->{connection_details} eq 'ARRAY') {
1263       return DBIx::Class::Exception->throw('connection details must be an arrayref');
1264     }
1265     $schema = $self->_generate_schema({
1266       ddl => "$ddl_file",
1267       connection_details => delete $params->{connection_details},
1268       %{$params}
1269     });
1270   } elsif ($params->{schema} && $params->{no_deploy}) {
1271     $schema = $params->{schema};
1272   } else {
1273     DBIx::Class::Exception->throw('you must set the ddl and connection_details params');
1274   }
1275
1276
1277   return 1 if $params->{no_populate};
1278
1279   $self->msg("\nimporting fixtures");
1280   my $tmp_fixture_dir = io->dir(tempdir());
1281   my $config_set_path = io->file($fixture_dir, '_config_set');
1282   my $config_set = -e "$config_set_path" ? do { my $VAR1; eval($config_set_path->slurp); $VAR1 } : '';
1283
1284   my $v = Data::Visitor::Callback->new(
1285     plain_value => sub {
1286       my ($visitor, $data) = @_;
1287       my $subs = {
1288        ENV => sub {
1289           my ( $self, $v ) = @_;
1290           if (! defined($ENV{$v})) {
1291             return "";
1292           } else {
1293             return $ENV{ $v };
1294           }
1295         },
1296         ATTR => sub {
1297           my ($self, $v) = @_;
1298           if(my $attr = $self->config_attrs->{$v}) {
1299             return $attr;
1300           } else {
1301             return "";
1302           }
1303         },
1304         catfile => sub {
1305           my ($self, @args) = @_;
1306           io->catfile(@args);
1307         },
1308         catdir => sub {
1309           my ($self, @args) = @_;
1310           io->catdir(@args);
1311         },
1312       };
1313
1314       my $subsre = join( '|', keys %$subs );
1315       $_ =~ s{__($subsre)(?:\((.+?)\))?__}{ $subs->{ $1 }->( $self, $2 ? split( /,/, $2 ) : () ) }eg;
1316
1317       return $_;
1318     }
1319   );
1320
1321   $v->visit( $config_set );
1322
1323
1324   my %sets_by_src;
1325   if($config_set) {
1326     %sets_by_src = map { delete($_->{class}) => $_ }
1327       @{$config_set->{sets}}
1328   }
1329
1330   if (-e "$tmp_fixture_dir") {
1331     $self->msg("- deleting existing temp directory $tmp_fixture_dir");
1332     $tmp_fixture_dir->rmtree;
1333   }
1334   $self->msg("- creating temp dir");
1335   $tmp_fixture_dir->mkpath();
1336   for ( map { $self->_name_for_source($schema->source($_)) } $schema->sources) {
1337     my $from_dir = io->catdir($fixture_dir, $_);
1338     next unless -e "$from_dir";
1339     $from_dir->copy( io->catdir($tmp_fixture_dir, $_)."" );
1340   }
1341
1342   unless (-d "$tmp_fixture_dir") {
1343     DBIx::Class::Exception->throw("Unable to create temporary fixtures dir: $tmp_fixture_dir: $!");
1344   }
1345
1346   my $fixup_visitor;
1347   my $formatter = $schema->storage->datetime_parser;
1348   unless ($@ || !$formatter) {
1349     my %callbacks;
1350     if ($params->{datetime_relative_to}) {
1351       $callbacks{'DateTime::Duration'} = sub {
1352         $params->{datetime_relative_to}->clone->add_duration($_);
1353       };
1354     } else {
1355       $callbacks{'DateTime::Duration'} = sub {
1356         $formatter->format_datetime(DateTime->today->add_duration($_))
1357       };
1358     }
1359     $callbacks{object} ||= "visit_ref";
1360     $fixup_visitor = new Data::Visitor::Callback(%callbacks);
1361   }
1362
1363   my @sorted_source_names = $self->_get_sorted_sources( $schema );
1364   $schema->storage->txn_do(sub {
1365     $schema->storage->with_deferred_fk_checks(sub {
1366       foreach my $source (@sorted_source_names) {
1367         $self->msg("- adding " . $source);
1368         my $rs = $schema->resultset($source);
1369         my $source_dir = io->catdir($tmp_fixture_dir, $self->_name_for_source($rs->result_source));
1370         next unless (-e "$source_dir");
1371         my @rows;
1372         while (my $file = $source_dir->next) {
1373           next unless ($file =~ /\.fix$/);
1374           next if $file->is_dir;
1375           my $contents = $file->slurp;
1376           my $HASH1;
1377           eval($contents);
1378           $HASH1 = $fixup_visitor->visit($HASH1) if $fixup_visitor;
1379           if(my $external = delete $HASH1->{external}) {
1380             my @fields = keys %{$sets_by_src{$source}->{external}};
1381             foreach my $field(@fields) {
1382               my $key = $HASH1->{$field};
1383               my $content = decode_base64 ($external->{$field});
1384               my $args = $sets_by_src{$source}->{external}->{$field}->{args};
1385               my ($plus, $class) = ( $sets_by_src{$source}->{external}->{$field}->{class}=~/^(\+)*(.+)$/);
1386               $class = "DBIx::Class::Fixtures::External::$class" unless $plus;
1387               eval "use $class";
1388               $class->restore($key, $content, $args);
1389             }
1390           }
1391           if ( $params->{use_create} ) {
1392             $rs->create( $HASH1 );
1393           } elsif( $params->{use_find_or_create} ) {
1394             $rs->find_or_create( $HASH1 );
1395           } else {
1396             push(@rows, $HASH1);
1397           }
1398         }
1399         $rs->populate(\@rows) if scalar(@rows);
1400
1401         ## Now we need to do some db specific cleanup
1402         ## this probably belongs in a more isolated space.  Right now this is
1403         ## to just handle postgresql SERIAL types that use Sequences
1404         ## Will completely ignore sequences in Oracle due to having to drop
1405         ## and recreate them
1406
1407         my $table = $rs->result_source->name;
1408         for my $column(my @columns =  $rs->result_source->columns) {
1409           my $info = $rs->result_source->column_info($column);
1410           if(my $sequence = $info->{sequence}) {
1411              $self->msg("- updating sequence $sequence");
1412             $rs->result_source->storage->dbh_do(sub {
1413               my ($storage, $dbh, @cols) = @_;
1414               if ( $dbh->{Driver}->{Name} eq "Oracle" ) {
1415                 $self->msg("- Cannot change sequence values in Oracle");
1416               } else {
1417                 $self->msg(
1418          my $sql = sprintf("SELECT setval(?, (SELECT max(%s) FROM %s));",$dbh->quote_identifier($column),$dbh->quote_identifier($table))
1419              );
1420                 my $sth = $dbh->prepare($sql);
1421                    $sth->bind_param(1,$sequence);
1422
1423                 my $rv = $sth->execute or die $sth->errstr;
1424                 $self->msg("- $sql");
1425               }
1426             });
1427           }
1428         }
1429
1430       }
1431     });
1432   });
1433   $self->do_post_ddl( {
1434     schema=>$schema,
1435     post_ddl=>$params->{post_ddl}
1436   } ) if $params->{post_ddl};
1437
1438   $self->msg("- fixtures imported");
1439   $self->msg("- cleaning up");
1440   $tmp_fixture_dir->rmtree;
1441   return 1;
1442 }
1443
1444 # the overall logic is modified from SQL::Translator::Parser::DBIx::Class->parse
1445 sub _get_sorted_sources {
1446   my ( $self, $dbicschema ) = @_;
1447
1448
1449   my %table_monikers = map { $_ => 1 } $dbicschema->sources;
1450
1451   my %tables;
1452   foreach my $moniker (sort keys %table_monikers) {
1453     my $source = $dbicschema->source($moniker);
1454
1455     my $table_name = $source->name;
1456     my @primary = $source->primary_columns;
1457     my @rels = $source->relationships();
1458
1459     my %created_FK_rels;
1460     foreach my $rel (sort @rels) {
1461       my $rel_info = $source->relationship_info($rel);
1462
1463       # Ignore any rel cond that isn't a straight hash
1464       next unless ref $rel_info->{cond} eq 'HASH';
1465
1466       my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} keys(%{$rel_info->{cond}});
1467
1468       # determine if this relationship is a self.fk => foreign.pk (i.e. belongs_to)
1469       my $fk_constraint;
1470       if ( exists $rel_info->{attrs}{is_foreign_key_constraint} ) {
1471         $fk_constraint = $rel_info->{attrs}{is_foreign_key_constraint};
1472       } elsif ( $rel_info->{attrs}{accessor}
1473           && $rel_info->{attrs}{accessor} eq 'multi' ) {
1474         $fk_constraint = 0;
1475       } else {
1476         $fk_constraint = not $source->_compare_relationship_keys(\@keys, \@primary);
1477       }
1478
1479       # Dont add a relation if its not constraining
1480       next unless $fk_constraint;
1481
1482       my $rel_table = $source->related_source($rel)->source_name;
1483       # Make sure we don't create the same relation twice
1484       my $key_test = join("\x00", sort @keys);
1485       next if $created_FK_rels{$rel_table}->{$key_test};
1486
1487       if (scalar(@keys)) {
1488         $created_FK_rels{$rel_table}->{$key_test} = 1;
1489
1490         # calculate dependencies: do not consider deferrable constraints and
1491         # self-references for dependency calculations
1492         if (! $rel_info->{attrs}{is_deferrable} and $rel_table ne $table_name) {
1493           $tables{$moniker}{$rel_table}++;
1494         }
1495       }
1496     }
1497     $tables{$moniker} = {} unless exists $tables{$moniker};
1498   }
1499
1500   # resolve entire dep tree
1501   my $dependencies = {
1502     map { $_ => _resolve_deps ($_, \%tables) } (keys %tables)
1503   };
1504
1505   # return the sorted result
1506   return sort {
1507     keys %{$dependencies->{$a} || {} } <=> keys %{ $dependencies->{$b} || {} }
1508       ||
1509     $a cmp $b
1510   } (keys %tables);
1511 }
1512
1513 sub _resolve_deps {
1514   my ( $question, $answers, $seen ) = @_;
1515   my $ret = {};
1516   $seen ||= {};
1517
1518   my %seen = map { $_ => $seen->{$_} + 1 } ( keys %$seen );
1519   $seen{$question} = 1;
1520
1521   for my $dep (keys %{ $answers->{$question} }) {
1522     return {} if $seen->{$dep};
1523     my $subdeps = _resolve_deps( $dep, $answers, \%seen );
1524     $ret->{$_} += $subdeps->{$_} for ( keys %$subdeps );
1525     ++$ret->{$dep};
1526   }
1527   return $ret;
1528 }
1529
1530 sub do_post_ddl {
1531   my ($self, $params) = @_;
1532
1533   my $schema = $params->{schema};
1534   my $data = _read_sql($params->{post_ddl});
1535   foreach (@$data) {
1536     eval { $schema->storage->dbh->do($_) or warn "SQL was:\n $_"};
1537           if ($@ && !$self->{ignore_sql_errors}) { die "SQL was:\n $_\n$@"; }
1538   }
1539   $self->msg("- finished importing post-populate DDL into DB");
1540 }
1541
1542 sub msg {
1543   my $self = shift;
1544   my $subject = shift || return;
1545   my $level = shift || 1;
1546   return unless $self->debug >= $level;
1547   if (ref $subject) {
1548         print Dumper($subject);
1549   } else {
1550         print $subject . "\n";
1551   }
1552 }
1553
1554 # Helper method for ensuring that the name used for a given source
1555 # is always the same (This is used to name the fixture directories
1556 # for example)
1557
1558 sub _name_for_source {
1559     my ($self, $source) = @_;
1560
1561     return ref $source->name ? $source->source_name : $source->name;
1562 }
1563
1564 =head1 AUTHOR
1565
1566   Luke Saunders <luke@shadowcatsystems.co.uk>
1567
1568   Initial development sponsored by and (c) Takkle, Inc. 2007
1569
1570 =head1 CONTRIBUTORS
1571
1572   Ash Berlin <ash@shadowcatsystems.co.uk>
1573
1574   Matt S. Trout <mst@shadowcatsystems.co.uk>
1575
1576   John Napiorkowski <jjnapiork@cpan.org>
1577
1578   Drew Taylor <taylor.andrew.j@gmail.com>
1579
1580   Frank Switalski <fswitalski@gmail.com>
1581
1582   Chris Akins <chris.hexx@gmail.com>
1583
1584   Tom Bloor <t.bloor@shadowcat.co.uk>
1585
1586   Samuel Kaufman <skaufman@cpan.org>
1587
1588 =head1 LICENSE
1589
1590   This library is free software under the same license as perl itself
1591
1592 =cut
1593
1594 1;