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