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