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;
   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
  19 use base qw(Class::Accessor);
  20
  21 our %db_to_parser = (
  22   'mysql'       => 'DateTime::Format::MySQL',
  23   'pg'          => 'DateTime::Format::Pg',
  24 );
  25
  26 __PACKAGE__->mk_accessors(qw(config_dir _inherited_attributes debug schema_class ));
  27
  28 =head1 VERSION
  29
  30 Version 1.000
  31
  32 =cut
  33
  34 our $VERSION = '1.000';
  35
  36 =head1 NAME
  37
  38 DBIx::Class::Fixtures
  39
  40 =head1 SYNOPSIS
  41
  42   use DBIx::Class::Fixtures;
  43
  44   ...
  45
  46   my $fixtures = DBIx::Class::Fixtures->new({ config_dir => '/home/me/app/fixture_configs' });
  47
  48   $fixtures->dump({
  49     config => 'set_config.json',
  50     schema => $source_dbic_schema,
  51     directory => '/home/me/app/fixtures'
  52   });
  53
  54   $fixtures->populate({
  55     directory => '/home/me/app/fixtures',
  56     ddl => '/home/me/app/sql/ddl.sql',
  57     connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password']
  58   });
  59
  60 =head1 DESCRIPTION
  61
  62 =head1 AUTHOR
  63
  64 Luke Saunders <luke@shadowcatsystems.co.uk>
  65
  66 =head1 CONTRIBUTORS
  67
  68 =head1 METHODS
  69
  70 =head2 new
  71
  72 =cut
  73
  74 sub new {
  75   my $class = shift;
  76
  77   my ($params) = @_;
  78   unless (ref $params eq 'HASH') {
  79     return DBIx::Class::Exception->throw('first arg to DBIx::Class::Fixtures->new() must be hash ref');
  80   }
  81
  82   unless ($params->{config_dir}) {
  83     return DBIx::Class::Exception->throw('config_dir param not specified');
  84   }
  85
  86   my $config_dir = dir($params->{config_dir});
  87   unless (-e $params->{config_dir}) {
  88     return DBIx::Class::Exception->throw('config_dir directory doesn\'t exist');
  89   }
  90
  91   my $self = {
  92               config_dir => $config_dir,
  93               _inherited_attributes => [qw/datetime_relative might_have rules/],
  94               debug => $params->{debug}
  95   };
  96
  97   bless $self, $class;
  98
  99   return $self;
 100 }
 101
 102 =head2 dump
 103
 104 =cut
 105
 106 sub dump {
 107   my $self = shift;
 108
 109   my ($params) = @_;
 110   unless (ref $params eq 'HASH') {
 111     return DBIx::Class::Exception->throw('first arg to dump must be hash ref');
 112   }
 113
 114   foreach my $param (qw/config schema directory/) {
 115     unless ($params->{$param}) {
 116       return DBIx::Class::Exception->throw($param . ' param not specified');
 117     }
 118   }
 119
 120   my $config_file = file($self->config_dir, $params->{config});
 121   unless (-e $config_file) {
 122     return DBIx::Class::Exception->throw('config does not exist at ' . $config_file);
 123   }
 124
 125   my $config = Config::Any::JSON->load($config_file);
 126   unless ($config && $config->{sets} && ref $config->{sets} eq 'ARRAY' && scalar(@{$config->{sets}})) {
 127     return DBIx::Class::Exception->throw('config has no sets');
 128   }
 129
 130   my $output_dir = dir($params->{directory});
 131   unless (-e $output_dir) {
 132     return DBIx::Class::Exception->throw('output directory does not exist at ' . $output_dir);
 133   }
 134
 135   my $schema = $params->{schema};
 136
 137   $self->msg("generating  fixtures");
 138   my $tmp_output_dir = dir($output_dir, '-~dump~-');
 139
 140   if (-e $tmp_output_dir) {
 141     $self->msg("- clearing existing $tmp_output_dir");
 142     $tmp_output_dir->rmtree;
 143   }
 144   $self->msg("- creating $tmp_output_dir");
 145   $tmp_output_dir->mkpath;
 146
 147   # write version file (for the potential benefit of populate)
 148   my $version_file = file($tmp_output_dir, '_dumper_version');
 149   write_file($version_file->stringify, $VERSION);
 150
 151   $config->{rules} ||= {};
 152   my @sources = sort { $a->{class} cmp $b->{class} } @{delete $config->{sets}};
 153   my %options = ( is_root => 1 );
 154   foreach my $source (@sources) {
 155     # apply rule to set if specified
 156     my $rule = $config->{rules}->{$source->{class}};
 157     $source = merge( $source, $rule ) if ($rule);
 158
 159     # fetch objects
 160     my $rs = $schema->resultset($source->{class});
 161         $rs = $rs->search($source->{cond}, { join => $source->{join} }) if ($source->{cond});
 162     $self->msg("- dumping $source->{class}");
 163     my @objects;
 164     my %source_options = ( set => { %{$config}, %{$source} } );
 165     if ($source->{quantity}) {
 166       $rs = $rs->search({}, { order_by => $source->{order_by} }) if ($source->{order_by});
 167       if ($source->{quantity} eq 'all') {
 168         push (@objects, $rs->all);
 169       } elsif ($source->{quantity} =~ /^\d+$/) {
 170         push (@objects, $rs->search({}, { rows => $source->{quantity} }));
 171       } else {
 172         DBIx::Class::Exception->throw('invalid value for quantity - ' . $source->{quantity});
 173       }
 174     }
 175     if ($source->{ids}) {
 176       my @ids = @{$source->{ids}};
 177       my @id_objects = grep { $_ } map { $rs->find($_) } @ids;
 178       push (@objects, @id_objects);
 179     }
 180     unless ($source->{quantity} || $source->{ids}) {
 181       DBIx::Class::Exception->throw('must specify either quantity or ids');
 182     }
 183
 184     # dump objects
 185     foreach my $object (@objects) {
 186       $source_options{set_dir} = $tmp_output_dir;
 187       $self->dump_object($object, { %options, %source_options } );
 188       next;
 189     }
 190   }
 191
 192   foreach my $dir ($output_dir->children) {
 193     next if ($dir eq $tmp_output_dir);
 194     $dir->remove || $dir->rmtree;
 195   }
 196
 197   $self->msg("- moving temp dir to $output_dir");
 198   move($_, dir($output_dir, $_->relative($_->parent)->stringify)) for $tmp_output_dir->children;
 199   if (-e $output_dir) {
 200     $self->msg("- clearing tmp dir $tmp_output_dir");
 201     # delete existing fixture set
 202     $tmp_output_dir->remove;
 203   }
 204
 205   $self->msg("done");
 206
 207   return 1;
 208 }
 209
 210 sub dump_object {
 211   my ($self, $object, $params, $rr_info) = @_;
 212   my $set = $params->{set};
 213   die 'no dir passed to dump_object' unless $params->{set_dir};
 214   die 'no object passed to dump_object' unless $object;
 215
 216   my @inherited_attrs = @{$self->_inherited_attributes};
 217
 218   # write dir and gen filename
 219   my $source_dir = dir($params->{set_dir}, lc($object->result_source->from));
 220   mkdir($source_dir->stringify, 0777);
 221   my $file = file($source_dir, join('-', map { $object->get_column($_) } sort $object->primary_columns) . '.fix');
 222
 223   # write file
 224   my $exists = (-e $file->stringify) ? 1 : 0;
 225   unless ($exists) {
 226     $self->msg('-- dumping ' . $file->stringify, 2);
 227     my %ds = $object->get_columns;
 228
 229     my $driver = $object->result_source->schema->storage->dbh->{Driver}->{Name};
 230     my $formatter= $db_to_parser{$driver};
 231     eval "require $formatter" if ($formatter);
 232
 233     # mess with dates if specified
 234     if ($set->{datetime_relative}) {
 235       unless ($@ || !$formatter) {
 236         my $dt;
 237         if ($set->{datetime_relative} eq 'today') {
 238           $dt = DateTime->today;
 239         } else {
 240           $dt = $formatter->parse_datetime($set->{datetime_relative}) unless ($@);
 241         }
 242
 243         while (my ($col, $value) = each %ds) {
 244           my $col_info = $object->result_source->column_info($col);
 245
 246           next unless $value
 247             && $col_info->{_inflate_info}
 248               && uc($col_info->{data_type}) eq 'DATETIME';
 249
 250           $ds{$col} = $object->get_inflated_column($col)->subtract_datetime($dt);
 251         }
 252       } else {
 253         warn "datetime_relative not supported for $driver at the moment";
 254       }
 255     }
 256
 257     # do the actual dumping
 258     my $serialized = Dump(\%ds)->Out();
 259     write_file($file->stringify, $serialized);
 260     my $mode = 0777; chmod $mode, $file->stringify;
 261   }
 262
 263   # dump rels of object
 264   my $s = $object->result_source;
 265   unless ($exists) {
 266     foreach my $name (sort $s->relationships) {
 267       my $info = $s->relationship_info($name);
 268       my $r_source = $s->related_source($name);
 269       # if belongs_to or might_have with might_have param set or has_many with has_many param set then
 270       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}))) {
 271         my $related_rs = $object->related_resultset($name);
 272         my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 273         # these parts of the rule only apply to has_many rels
 274         if ($rule && $info->{attrs}{accessor} eq 'multi') {
 275           $related_rs = $related_rs->search($rule->{cond}, { join => $rule->{join} }) if ($rule->{cond});
 276           $related_rs = $related_rs->search({}, { rows => $rule->{quantity} }) if ($rule->{quantity} && $rule->{quantity} ne 'all');
 277           $related_rs = $related_rs->search({}, { order_by => $rule->{order_by} }) if ($rule->{order_by});
 278         }
 279         if ($set->{has_many}->{quantity} && $set->{has_many}->{quantity} =~ /^\d+$/) {
 280           $related_rs = $related_rs->search({}, { rows => $set->{has_many}->{quantity} });
 281         }
 282         my %c_params = %{$params};
 283         # inherit date param
 284         my %mock_set = map { $_ => $set->{$_} } grep { $set->{$_} } @inherited_attrs;
 285         $c_params{set} = \%mock_set;
 286         #               use Data::Dumper; print ' -- ' . Dumper($c_params{set}, $rule->{fetch}) if ($rule && $rule->{fetch});
 287         $c_params{set} = merge( $c_params{set}, $rule) if ($rule && $rule->{fetch});
 288         #               use Data::Dumper; print ' -- ' . Dumper(\%c_params) if ($rule && $rule->{fetch});
 289         $self->dump_object($_, \%c_params) foreach $related_rs->all;
 290       }
 291     }
 292   }
 293
 294   return unless $set && $set->{fetch};
 295   foreach my $fetch (@{$set->{fetch}}) {
 296     # inherit date param
 297     $fetch->{$_} = $set->{$_} foreach grep { !$fetch->{$_} && $set->{$_} } @inherited_attrs;
 298     my $related_rs = $object->related_resultset($fetch->{rel});
 299     my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 300     if ($rule) {
 301       my $info = $object->result_source->relationship_info($fetch->{rel});
 302       if ($info->{attrs}{accessor} eq 'multi') {
 303         $fetch = merge( $fetch, $rule );
 304       } elsif ($rule->{fetch}) {
 305         $fetch = merge( $fetch, { fetch => $rule->{fetch} } );
 306       }
 307     }
 308     die "relationship " . $fetch->{rel} . " does not exist for " . $s->source_name unless ($related_rs);
 309     if ($fetch->{cond} and ref $fetch->{cond} eq 'HASH') {
 310       # if value starts with / assume it's meant to be passed as a scalar ref to dbic
 311       # ideally this would substitute deeply
 312       $fetch->{cond} = { map { $_ => ($fetch->{cond}->{$_} =~ s/^\\//) ? \$fetch->{cond}->{$_} : $fetch->{cond}->{$_} } keys %{$fetch->{cond}} };
 313     }
 314     $related_rs = $related_rs->search($fetch->{cond}, { join => $fetch->{join} }) if ($fetch->{cond});
 315     $related_rs = $related_rs->search({}, { rows => $fetch->{quantity} }) if ($fetch->{quantity} && $fetch->{quantity} ne 'all');
 316     $related_rs = $related_rs->search({}, { order_by => $fetch->{order_by} }) if ($fetch->{order_by});
 317     $self->dump_object($_, { %{$params}, set => $fetch }) foreach $related_rs->all;
 318   }
 319 }
 320
 321 sub _generate_schema {
 322   my $self = shift;
 323   my $params = shift || {};
 324   require DBI;
 325   $self->msg("\ncreating schema");
 326   #   die 'must pass version param to generate_schema_from_ddl' unless $params->{version};
 327
 328   my $schema_class = $self->schema_class || "DBIx::Class::Fixtures::Schema";
 329   eval "require $schema_class";
 330   die $@ if $@;
 331
 332   my $pre_schema;
 333   my $connection_details = $params->{connection_details};
 334   unless( $pre_schema = $schema_class->connect(@{$connection_details}) ) {
 335     return DBIx::Class::Exception->throw('connection details not valid');
 336   }
 337   my @tables = map { $pre_schema->source($_)->from }$pre_schema->sources;
 338   my $dbh = $pre_schema->storage->dbh;
 339
 340   # clear existing db
 341   $self->msg("- clearing DB of existing tables");
 342   eval { $dbh->do('SET foreign_key_checks=0') };
 343   $dbh->do('drop table ' . $_) for (@tables);
 344
 345   # import new ddl file to db
 346   my $ddl_file = $params->{ddl};
 347   $self->msg("- deploying schema using $ddl_file");
 348   my $fh;
 349   open $fh, "<$ddl_file" or die ("Can't open DDL file, $ddl_file ($!)");
 350   my @data = split(/\n/, join('', <$fh>));
 351   @data = grep(!/^--/, @data);
 352   @data = split(/;/, join('', @data));
 353   close($fh);
 354   @data = grep { $_ && $_ !~ /^-- / } @data;
 355   for (@data) {
 356       eval { $dbh->do($_) or warn "SQL was:\n $_"};
 357           if ($@) { die "SQL was:\n $_\n$@"; }
 358   }
 359   $self->msg("- finished importing DDL into DB");
 360
 361   # load schema object from our new DB
 362   $self->msg("- loading fresh DBIC object from DB");
 363   my $schema = $schema_class->connect(@{$connection_details});
 364   return $schema;
 365 }
 366
 367 sub populate {
 368   my $self = shift;
 369   my ($params) = @_;
 370   unless (ref $params eq 'HASH') {
 371     return DBIx::Class::Exception->throw('first arg to populate must be hash ref');
 372   }
 373
 374   foreach my $param (qw/directory/) {
 375     unless ($params->{$param}) {
 376       return DBIx::Class::Exception->throw($param . ' param not specified');
 377     }
 378   }
 379   my $fixture_dir = dir(delete $params->{directory});
 380   unless (-e $fixture_dir) {
 381     return DBIx::Class::Exception->throw('fixture directory does not exist at ' . $fixture_dir);
 382   }
 383
 384   my $ddl_file;
 385   my $dbh;
 386   if ($params->{ddl} && $params->{connection_details}) {
 387     $ddl_file = file(delete $params->{ddl});
 388     unless (-e $ddl_file) {
 389       return DBIx::Class::Exception->throw('DDL does not exist at ' . $ddl_file);
 390     }
 391     unless (ref $params->{connection_details} eq 'ARRAY') {
 392       return DBIx::Class::Exception->throw('connection details must be an arrayref');
 393     }
 394   } elsif ($params->{schema}) {
 395     return DBIx::Class::Exception->throw('passing a schema is not supported at the moment');
 396   } else {
 397     return DBIx::Class::Exception->throw('you must set the ddl and connection_details params');
 398   }
 399
 400   my $schema = $self->_generate_schema({ ddl => $ddl_file, connection_details => delete $params->{connection_details}, %{$params} });
 401   $self->msg("\nimporting fixtures");
 402   my $tmp_fixture_dir = dir($fixture_dir, "-~populate~-" . $<);
 403
 404   my $version_file = file($fixture_dir, '_dumper_version');
 405   unless (-e $version_file) {
 406 #     return DBIx::Class::Exception->throw('no version file found');
 407   }
 408
 409   if (-e $tmp_fixture_dir) {
 410     $self->msg("- deleting existing temp directory $tmp_fixture_dir");
 411     $tmp_fixture_dir->rmtree;
 412   }
 413   $self->msg("- creating temp dir");
 414   dircopy(dir($fixture_dir, $schema->source($_)->from), dir($tmp_fixture_dir, $schema->source($_)->from)) for $schema->sources;
 415
 416   eval { $schema->storage->dbh->do('SET foreign_key_checks=0') };
 417
 418   my $fixup_visitor;
 419   my $driver = $schema->storage->dbh->{Driver}->{Name};
 420   my $formatter= $db_to_parser{$driver};
 421   eval "require $formatter" if ($formatter);
 422   unless ($@ || !$formatter) {
 423     my %callbacks;
 424     if ($params->{datetime_relative_to}) {
 425       $callbacks{'DateTime::Duration'} = sub {
 426         $params->{datetime_relative_to}->clone->add_duration($_);
 427       };
 428     } else {
 429       $callbacks{'DateTime::Duration'} = sub {
 430         $formatter->format_datetime(DateTime->today->add_duration($_))
 431       };
 432     }
 433     $callbacks{object} ||= "visit_ref";
 434     $fixup_visitor = new Data::Visitor::Callback(%callbacks);
 435   }
 436   foreach my $source (sort $schema->sources) {
 437     $self->msg("- adding " . $source);
 438     my $rs = $schema->resultset($source);
 439     my $source_dir = dir($tmp_fixture_dir, lc($rs->result_source->from));
 440     next unless (-e $source_dir);
 441     while (my $file = $source_dir->next) {
 442       next unless ($file =~ /\.fix$/);
 443       next if $file->is_dir;
 444       my $contents = $file->slurp;
 445       my $HASH1;
 446       eval($contents);
 447       $HASH1 = $fixup_visitor->visit($HASH1) if $fixup_visitor;
 448       $rs->create($HASH1);
 449     }
 450   }
 451
 452   $self->msg("- fixtures imported");
 453   $self->msg("- cleaning up");
 454   $tmp_fixture_dir->rmtree;
 455   eval { $schema->storage->dbh->do('SET foreign_key_checks=1') };
 456 }
 457
 458 sub msg {
 459   my $self = shift;
 460   my $subject = shift || return;
 461   my $level = shift || 1;
 462
 463   return unless $self->debug >= $level;
 464   if (ref $subject) {
 465         print Dumper($subject);
 466   } else {
 467         print $subject . "\n";
 468   }
 469 }
 470 1;