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