lib/DBIx/Class/Fixtures.pm

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