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.000001
  29
  30 =cut
  31
  32 our $VERSION = '1.000001';
  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   or
 377
 378   $fixtures->dump({
 379     all => 1, # just dump everything that's in the schema
 380     schema => $source_dbic_schema,
 381     directory => '/home/me/app/fixtures' # output directory
 382   });
 383
 384 In this case objects will be dumped to subdirectories in the specified directory. For example:
 385
 386   /home/me/app/fixtures/artist/1.fix
 387   /home/me/app/fixtures/artist/3.fix
 388   /home/me/app/fixtures/producer/5.fix
 389
 390 schema and directory are required attributes. also, one of config or all must be specified.
 391
 392 =cut
 393
 394 sub dump {
 395   my $self = shift;
 396
 397   my ($params) = @_;
 398   unless (ref $params eq 'HASH') {
 399     return DBIx::Class::Exception->throw('first arg to dump must be hash ref');
 400   }
 401
 402   foreach my $param (qw/schema directory/) {
 403     unless ($params->{$param}) {
 404       return DBIx::Class::Exception->throw($param . ' param not specified');
 405     }
 406   }
 407
 408   my $schema = $params->{schema};
 409   my $config_file;
 410   my $config;
 411   if ($params->{config}) {
 412     $config_file = file($self->config_dir, $params->{config});
 413     unless (-e $config_file) {
 414       return DBIx::Class::Exception->throw('config does not exist at ' . $config_file);
 415     }
 416
 417     $config = Config::Any::JSON->load($config_file);
 418     unless ($config && $config->{sets} && ref $config->{sets} eq 'ARRAY' && scalar(@{$config->{sets}})) {
 419       return DBIx::Class::Exception->throw('config has no sets');
 420     }
 421
 422     $config->{might_have} = { fetch => 0 } unless (exists $config->{might_have});
 423     $config->{has_many} = { fetch => 0 } unless (exists $config->{has_many});
 424     $config->{belongs_to} = { fetch => 1 } unless (exists $config->{belongs_to});
 425   } elsif ($params->{all}) {
 426     $config = { might_have => { fetch => 0 }, has_many => { fetch => 0 }, belongs_to => { fetch => 0 }, sets => [map {{ class => $_, quantity => 'all' }} $schema->sources] };
 427     print Dumper($config);
 428   } else {
 429     return DBIx::Class::Exception->throw('must pass config or set all');
 430   }
 431
 432   my $output_dir = dir($params->{directory});
 433   unless (-e $output_dir) {
 434     $output_dir->mkpath ||
 435       return DBIx::Class::Exception->throw('output directory does not exist at ' . $output_dir);
 436   }
 437
 438   $self->msg("generating  fixtures");
 439   my $tmp_output_dir = dir($output_dir, '-~dump~-' . $<);
 440
 441   if (-e $tmp_output_dir) {
 442     $self->msg("- clearing existing $tmp_output_dir");
 443     $tmp_output_dir->rmtree;
 444   }
 445   $self->msg("- creating $tmp_output_dir");
 446   $tmp_output_dir->mkpath;
 447
 448   # write version file (for the potential benefit of populate)
 449   my $version_file = file($tmp_output_dir, '_dumper_version');
 450   write_file($version_file->stringify, $VERSION);
 451
 452   $config->{rules} ||= {};
 453   my @sources = sort { $a->{class} cmp $b->{class} } @{delete $config->{sets}};
 454   my %options = ( is_root => 1 );
 455   foreach my $source (@sources) {
 456     # apply rule to set if specified
 457     my $rule = $config->{rules}->{$source->{class}};
 458     $source = merge( $source, $rule ) if ($rule);
 459
 460     # fetch objects
 461     my $rs = $schema->resultset($source->{class});
 462     $rs = $rs->search($source->{cond}, { join => $source->{join} }) if ($source->{cond});
 463     $self->msg("- dumping $source->{class}");
 464     my @objects;
 465     my %source_options = ( set => { %{$config}, %{$source} } );
 466     if ($source->{quantity}) {
 467       $rs = $rs->search({}, { order_by => $source->{order_by} }) if ($source->{order_by});
 468       if ($source->{quantity} eq 'all') {
 469         push (@objects, $rs->all);
 470       } elsif ($source->{quantity} =~ /^\d+$/) {
 471         push (@objects, $rs->search({}, { rows => $source->{quantity} }));
 472       } else {
 473         DBIx::Class::Exception->throw('invalid value for quantity - ' . $source->{quantity});
 474       }
 475     }
 476     if ($source->{ids}) {
 477       my @ids = @{$source->{ids}};
 478       my @id_objects = grep { $_ } map { $rs->find($_) } @ids;
 479       push (@objects, @id_objects);
 480     }
 481     unless ($source->{quantity} || $source->{ids}) {
 482       DBIx::Class::Exception->throw('must specify either quantity or ids');
 483     }
 484
 485     # dump objects
 486     foreach my $object (@objects) {
 487       $source_options{set_dir} = $tmp_output_dir;
 488       $self->dump_object($object, { %options, %source_options } );
 489       next;
 490     }
 491   }
 492
 493   foreach my $dir ($output_dir->children) {
 494     next if ($dir eq $tmp_output_dir);
 495     $dir->remove || $dir->rmtree;
 496   }
 497
 498   $self->msg("- moving temp dir to $output_dir");
 499   move($_, dir($output_dir, $_->relative($_->parent)->stringify)) for $tmp_output_dir->children;
 500   if (-e $output_dir) {
 501     $self->msg("- clearing tmp dir $tmp_output_dir");
 502     # delete existing fixture set
 503     $tmp_output_dir->remove;
 504   }
 505
 506   $self->msg("done");
 507
 508   return 1;
 509 }
 510
 511 sub dump_object {
 512   my ($self, $object, $params, $rr_info) = @_;
 513   my $set = $params->{set};
 514   die 'no dir passed to dump_object' unless $params->{set_dir};
 515   die 'no object passed to dump_object' unless $object;
 516
 517   my @inherited_attrs = @{$self->_inherited_attributes};
 518
 519   # write dir and gen filename
 520   my $source_dir = dir($params->{set_dir}, lc($object->result_source->from));
 521   mkdir($source_dir->stringify, 0777);
 522   my $file = file($source_dir, join('-', map { $object->get_column($_) } sort $object->primary_columns) . '.fix');
 523
 524   # write file
 525   my $exists = (-e $file->stringify) ? 1 : 0;
 526   unless ($exists) {
 527     $self->msg('-- dumping ' . $file->stringify, 2);
 528     my %ds = $object->get_columns;
 529
 530     my $formatter= $object->result_source->schema->storage->datetime_parser;
 531     # mess with dates if specified
 532     if ($set->{datetime_relative}) {
 533       unless ($@ || !$formatter) {
 534         my $dt;
 535         if ($set->{datetime_relative} eq 'today') {
 536           $dt = DateTime->today;
 537         } else {
 538           $dt = $formatter->parse_datetime($set->{datetime_relative}) unless ($@);
 539         }
 540
 541         while (my ($col, $value) = each %ds) {
 542           my $col_info = $object->result_source->column_info($col);
 543
 544           next unless $value
 545             && $col_info->{_inflate_info}
 546               && uc($col_info->{data_type}) eq 'DATETIME';
 547
 548           $ds{$col} = $object->get_inflated_column($col)->subtract_datetime($dt);
 549         }
 550       } else {
 551         warn "datetime_relative not supported for this db driver at the moment";
 552       }
 553     }
 554
 555     # do the actual dumping
 556     my $serialized = Dump(\%ds)->Out();
 557     write_file($file->stringify, $serialized);
 558     my $mode = 0777; chmod $mode, $file->stringify;
 559   }
 560
 561   # don't bother looking at rels unless we are actually planning to dump at least one type
 562   return unless ($set->{might_have}->{fetch} || $set->{belongs_to}->{fetch} || $set->{has_many}->{fetch} || $set->{fetch});
 563
 564   # dump rels of object
 565   my $s = $object->result_source;
 566   unless ($exists) {
 567     foreach my $name (sort $s->relationships) {
 568       my $info = $s->relationship_info($name);
 569       my $r_source = $s->related_source($name);
 570       # if belongs_to or might_have with might_have param set or has_many with has_many param set then
 571       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}))) {
 572         my $related_rs = $object->related_resultset($name);
 573         my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 574         # these parts of the rule only apply to has_many rels
 575         if ($rule && $info->{attrs}{accessor} eq 'multi') {
 576           $related_rs = $related_rs->search($rule->{cond}, { join => $rule->{join} }) if ($rule->{cond});
 577           $related_rs = $related_rs->search({}, { rows => $rule->{quantity} }) if ($rule->{quantity} && $rule->{quantity} ne 'all');
 578           $related_rs = $related_rs->search({}, { order_by => $rule->{order_by} }) if ($rule->{order_by});
 579         }
 580         if ($set->{has_many}->{quantity} && $set->{has_many}->{quantity} =~ /^\d+$/) {
 581           $related_rs = $related_rs->search({}, { rows => $set->{has_many}->{quantity} });
 582         }
 583         my %c_params = %{$params};
 584         # inherit date param
 585         my %mock_set = map { $_ => $set->{$_} } grep { $set->{$_} } @inherited_attrs;
 586         $c_params{set} = \%mock_set;
 587         #               use Data::Dumper; print ' -- ' . Dumper($c_params{set}, $rule->{fetch}) if ($rule && $rule->{fetch});
 588         $c_params{set} = merge( $c_params{set}, $rule) if ($rule && $rule->{fetch});
 589         #               use Data::Dumper; print ' -- ' . Dumper(\%c_params) if ($rule && $rule->{fetch});
 590         $self->dump_object($_, \%c_params) foreach $related_rs->all;
 591       }
 592     }
 593   }
 594
 595   return unless $set && $set->{fetch};
 596   foreach my $fetch (@{$set->{fetch}}) {
 597     # inherit date param
 598     $fetch->{$_} = $set->{$_} foreach grep { !$fetch->{$_} && $set->{$_} } @inherited_attrs;
 599     my $related_rs = $object->related_resultset($fetch->{rel});
 600     my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 601     if ($rule) {
 602       my $info = $object->result_source->relationship_info($fetch->{rel});
 603       if ($info->{attrs}{accessor} eq 'multi') {
 604         $fetch = merge( $fetch, $rule );
 605       } elsif ($rule->{fetch}) {
 606         $fetch = merge( $fetch, { fetch => $rule->{fetch} } );
 607       }
 608     }
 609     die "relationship " . $fetch->{rel} . " does not exist for " . $s->source_name unless ($related_rs);
 610     if ($fetch->{cond} and ref $fetch->{cond} eq 'HASH') {
 611       # if value starts with / assume it's meant to be passed as a scalar ref to dbic
 612       # ideally this would substitute deeply
 613       $fetch->{cond} = { map { $_ => ($fetch->{cond}->{$_} =~ s/^\\//) ? \$fetch->{cond}->{$_} : $fetch->{cond}->{$_} } keys %{$fetch->{cond}} };
 614     }
 615     $related_rs = $related_rs->search($fetch->{cond}, { join => $fetch->{join} }) if ($fetch->{cond});
 616     $related_rs = $related_rs->search({}, { rows => $fetch->{quantity} }) if ($fetch->{quantity} && $fetch->{quantity} ne 'all');
 617     $related_rs = $related_rs->search({}, { order_by => $fetch->{order_by} }) if ($fetch->{order_by});
 618     $self->dump_object($_, { %{$params}, set => $fetch }) foreach $related_rs->all;
 619   }
 620 }
 621
 622 sub _generate_schema {
 623   my $self = shift;
 624   my $params = shift || {};
 625   require DBI;
 626   $self->msg("\ncreating schema");
 627   #   die 'must pass version param to generate_schema_from_ddl' unless $params->{version};
 628
 629   my $schema_class = $self->schema_class || "DBIx::Class::Fixtures::Schema";
 630   eval "require $schema_class";
 631   die $@ if $@;
 632
 633   my $pre_schema;
 634   my $connection_details = $params->{connection_details};
 635   $namespace_counter++;
 636   my $namespace = "DBIx::Class::Fixtures::GeneratedSchema_" . $namespace_counter;
 637   Class::C3::Componentised->inject_base( $namespace => $schema_class );
 638   $pre_schema = $namespace->connect(@{$connection_details});
 639   unless( $pre_schema ) {
 640     return DBIx::Class::Exception->throw('connection details not valid');
 641   }
 642   my @tables = map { $pre_schema->source($_)->from } $pre_schema->sources;
 643   my $dbh = $pre_schema->storage->dbh;
 644
 645   # clear existing db
 646   $self->msg("- clearing DB of existing tables");
 647   eval { $dbh->do('SET foreign_key_checks=0') };
 648   $dbh->do('drop table ' . $_) for (@tables);
 649
 650   # import new ddl file to db
 651   my $ddl_file = $params->{ddl};
 652   $self->msg("- deploying schema using $ddl_file");
 653   my $fh;
 654   open $fh, "<$ddl_file" or die ("Can't open DDL file, $ddl_file ($!)");
 655   my @data = split(/\n/, join('', <$fh>));
 656   @data = grep(!/^--/, @data);
 657   @data = split(/;/, join('', @data));
 658   close($fh);
 659   @data = grep { $_ && $_ !~ /^-- / } @data;
 660   for (@data) {
 661       eval { $dbh->do($_) or warn "SQL was:\n $_"};
 662           if ($@) { die "SQL was:\n $_\n$@"; }
 663   }
 664   $self->msg("- finished importing DDL into DB");
 665
 666   # load schema object from our new DB
 667   $namespace_counter++;
 668   my $namespace2 = "DBIx::Class::Fixtures::GeneratedSchema_" . $namespace_counter;
 669   Class::C3::Componentised->inject_base( $namespace2 => $schema_class );
 670   my $schema = $namespace2->connect(@{$connection_details});
 671   return $schema;
 672 }
 673
 674
 675 =head2 populate
 676
 677 =over 4
 678
 679 =item Arguments: \%$attrs
 680
 681 =item Return Value: 1
 682
 683 =back
 684
 685   $fixtures->populate({
 686     directory => '/home/me/app/fixtures', # directory to look for fixtures in, as specified to dump
 687     ddl => '/home/me/app/sql/ddl.sql', # DDL to deploy
 688     connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password'] # database to clear, deploy and then populate
 689   });
 690
 691 In this case the database app_dev will be cleared of all tables, then the specified DDL deployed to it,
 692 then finally all fixtures found in /home/me/app/fixtures will be added to it. populate will generate
 693 its own DBIx::Class schema from the DDL rather than being passed one to use. This is better as
 694 custom insert methods are avoided which can to get in the way. In some cases you might not
 695 have a DDL, and so this method will eventually allow a $schema object to be passed instead.
 696
 697 directory, dll and connection_details are all required attributes.
 698
 699 =cut
 700
 701 sub populate {
 702   my $self = shift;
 703   my ($params) = @_;
 704   unless (ref $params eq 'HASH') {
 705     return DBIx::Class::Exception->throw('first arg to populate must be hash ref');
 706   }
 707
 708   foreach my $param (qw/directory/) {
 709     unless ($params->{$param}) {
 710       return DBIx::Class::Exception->throw($param . ' param not specified');
 711     }
 712   }
 713   my $fixture_dir = dir(delete $params->{directory});
 714   unless (-e $fixture_dir) {
 715     return DBIx::Class::Exception->throw('fixture directory does not exist at ' . $fixture_dir);
 716   }
 717
 718   my $ddl_file;
 719   my $dbh;
 720   if ($params->{ddl} && $params->{connection_details}) {
 721     $ddl_file = file(delete $params->{ddl});
 722     unless (-e $ddl_file) {
 723       return DBIx::Class::Exception->throw('DDL does not exist at ' . $ddl_file);
 724     }
 725     unless (ref $params->{connection_details} eq 'ARRAY') {
 726       return DBIx::Class::Exception->throw('connection details must be an arrayref');
 727     }
 728   } elsif ($params->{schema}) {
 729     return DBIx::Class::Exception->throw('passing a schema is not supported at the moment');
 730   } else {
 731     return DBIx::Class::Exception->throw('you must set the ddl and connection_details params');
 732   }
 733
 734   my $schema = $self->_generate_schema({ ddl => $ddl_file, connection_details => delete $params->{connection_details}, %{$params} });
 735   $self->msg("\nimporting fixtures");
 736   my $tmp_fixture_dir = dir($fixture_dir, "-~populate~-" . $<);
 737
 738   my $version_file = file($fixture_dir, '_dumper_version');
 739   unless (-e $version_file) {
 740 #     return DBIx::Class::Exception->throw('no version file found');
 741   }
 742
 743   if (-e $tmp_fixture_dir) {
 744     $self->msg("- deleting existing temp directory $tmp_fixture_dir");
 745     $tmp_fixture_dir->rmtree;
 746   }
 747   $self->msg("- creating temp dir");
 748   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;
 749
 750   eval { $schema->storage->dbh->do('SET foreign_key_checks=0') };
 751
 752   my $fixup_visitor;
 753   my $formatter= $schema->storage->datetime_parser;
 754   unless ($@ || !$formatter) {
 755     my %callbacks;
 756     if ($params->{datetime_relative_to}) {
 757       $callbacks{'DateTime::Duration'} = sub {
 758         $params->{datetime_relative_to}->clone->add_duration($_);
 759       };
 760     } else {
 761       $callbacks{'DateTime::Duration'} = sub {
 762         $formatter->format_datetime(DateTime->today->add_duration($_))
 763       };
 764     }
 765     $callbacks{object} ||= "visit_ref";
 766     $fixup_visitor = new Data::Visitor::Callback(%callbacks);
 767   }
 768   foreach my $source (sort $schema->sources) {
 769     $self->msg("- adding " . $source);
 770     my $rs = $schema->resultset($source);
 771     my $source_dir = dir($tmp_fixture_dir, lc($rs->result_source->from));
 772     next unless (-e $source_dir);
 773     while (my $file = $source_dir->next) {
 774       next unless ($file =~ /\.fix$/);
 775       next if $file->is_dir;
 776       my $contents = $file->slurp;
 777       my $HASH1;
 778       eval($contents);
 779       $HASH1 = $fixup_visitor->visit($HASH1) if $fixup_visitor;
 780       $rs->create($HASH1);
 781     }
 782   }
 783
 784   $self->msg("- fixtures imported");
 785   $self->msg("- cleaning up");
 786   $tmp_fixture_dir->rmtree;
 787   eval { $schema->storage->dbh->do('SET foreign_key_checks=1') };
 788
 789   return 1;
 790 }
 791
 792 sub msg {
 793   my $self = shift;
 794   my $subject = shift || return;
 795   my $level = shift || 1;
 796
 797   return unless $self->debug >= $level;
 798   if (ref $subject) {
 799         print Dumper($subject);
 800   } else {
 801         print $subject . "\n";
 802   }
 803 }
 804
 805 =head1 AUTHOR
 806
 807   Luke Saunders <luke@shadowcatsystems.co.uk>
 808
 809   Initial development sponsored by and (c) Takkle, Inc. 2007
 810
 811 =head1 CONTRIBUTORS
 812
 813   Ash Berlin <ash@shadowcatsystems.co.uk>
 814   Matt S. Trout <mst@shadowcatsystems.co.uk>
 815
 816 =head1 LICENSE
 817
 818   This library is free software under the same license as perl itself
 819
 820 =cut
 821
 822 1;