lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm

   1 package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator;
   2 use Moose;
   3
   4 # ABSTRACT: Manage your SQL and Perl migrations in nicely laid out directories
   5
   6 use autodie;
   7 use Carp qw( carp croak );
   8
   9 use Method::Signatures::Simple;
  10 use Try::Tiny;
  11
  12 use SQL::Translator;
  13 require SQL::Translator::Diff;
  14
  15 require DBIx::Class::Storage;   # loaded for type constraint
  16 use DBIx::Class::DeploymentHandler::Types;
  17
  18 use File::Path 'mkpath';
  19 use File::Spec::Functions;
  20
  21 with 'DBIx::Class::DeploymentHandler::HandlesDeploy';
  22
  23 has schema => (
  24   isa      => 'DBIx::Class::Schema',
  25   is       => 'ro',
  26   required => 1,
  27 );
  28
  29 has storage => (
  30   isa        => 'DBIx::Class::Storage',
  31   is         => 'ro',
  32   lazy_build => 1,
  33 );
  34
  35 method _build_storage {
  36   my $s = $self->schema->storage;
  37   $s->_determine_driver;
  38   $s
  39 }
  40
  41 has sql_translator_args => (
  42   isa => 'HashRef',
  43   is  => 'ro',
  44   default => sub { {} },
  45 );
  46 has upgrade_directory => (
  47   isa      => 'Str',
  48   is       => 'ro',
  49   required => 1,
  50   default  => 'sql',
  51 );
  52
  53 has databases => (
  54   coerce  => 1,
  55   isa     => 'DBIx::Class::DeploymentHandler::Databases',
  56   is      => 'ro',
  57   default => sub { [qw( MySQL SQLite PostgreSQL )] },
  58 );
  59
  60 has txn_wrap => (
  61   is => 'ro',
  62   isa => 'Bool',
  63   default => 1,
  64 );
  65
  66 has schema_version => (
  67   is => 'ro',
  68   lazy_build => 1,
  69 );
  70
  71 method _build_schema_version { $self->schema->schema_version }
  72
  73 method __ddl_consume_with_prefix($type, $versions, $prefix) {
  74   my $base_dir = $self->upgrade_directory;
  75
  76   my $main    = catfile( $base_dir, $type      );
  77   my $generic = catfile( $base_dir, '_generic' );
  78   my $common  =
  79     catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );
  80
  81   my $dir;
  82   if (-d $main) {
  83     $dir = catfile($main, $prefix, join q(-), @{$versions})
  84   } elsif (-d $generic) {
  85     $dir = catfile($generic, $prefix, join q(-), @{$versions});
  86   } else {
  87     croak "neither $main or $generic exist; please write/generate some SQL";
  88   }
  89
  90   opendir my($dh), $dir;
  91   my %files = map { $_ => "$dir/$_" } grep { /\.(?:sql|pl)$/ && -f "$dir/$_" } readdir $dh;
  92   closedir $dh;
  93
  94   if (-d $common) {
  95     opendir my($dh), $common;
  96     for my $filename (grep { /\.(?:sql|pl)$/ && -f catfile($common,$_) } readdir $dh) {
  97       unless ($files{$filename}) {
  98         $files{$filename} = catfile($common,$filename);
  99       }
 100     }
 101     closedir $dh;
 102   }
 103
 104   return [@files{sort keys %files}]
 105 }
 106
 107 method _ddl_preinstall_consume_filenames($type, $version) {
 108   $self->__ddl_consume_with_prefix($type, [ $version ], 'preinstall')
 109 }
 110
 111 method _ddl_schema_consume_filenames($type, $version) {
 112   $self->__ddl_consume_with_prefix($type, [ $version ], 'schema')
 113 }
 114
 115 method _ddl_schema_produce_filename($type, $version) {
 116   my $dirname = catfile( $self->upgrade_directory, $type, 'schema', $version );
 117   mkpath($dirname) unless -d $dirname;
 118
 119   return catfile( $dirname, '001-auto.sql' );
 120 }
 121
 122 method _ddl_schema_up_consume_filenames($type, $versions) {
 123   $self->__ddl_consume_with_prefix($type, $versions, 'up')
 124 }
 125
 126 method _ddl_schema_down_consume_filenames($type, $versions) {
 127   $self->__ddl_consume_with_prefix($type, $versions, 'down')
 128 }
 129
 130 method _ddl_schema_up_produce_filename($type, $versions) {
 131   my $dir = $self->upgrade_directory;
 132
 133   my $dirname = catfile( $dir, $type, 'up', join q(-), @{$versions});
 134   mkpath($dirname) unless -d $dirname;
 135
 136   return catfile( $dirname, '001-auto.sql'
 137   );
 138 }
 139
 140 method _ddl_schema_down_produce_filename($type, $versions, $dir) {
 141   my $dirname = catfile( $dir, $type, 'down', join q(-), @{$versions} );
 142   mkpath($dirname) unless -d $dirname;
 143
 144   return catfile( $dirname, '001-auto.sql');
 145 }
 146
 147 method _run_sql_and_perl($filenames) {
 148   my @files = @{$filenames};
 149   my $storage = $self->storage;
 150
 151
 152   my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
 153
 154   my $sql;
 155   for my $filename (@files) {
 156     if ($filename =~ /\.sql$/) {
 157       my @sql = @{$self->_read_sql_file($filename)};
 158       $sql .= join "\n", @sql;
 159
 160       foreach my $line (@sql) {
 161         $storage->_query_start($line);
 162         try {
 163           # do a dbh_do cycle here, as we need some error checking in
 164           # place (even though we will ignore errors)
 165           $storage->dbh_do (sub { $_[1]->do($line) });
 166         }
 167         catch {
 168           carp "$_ (running '${line}')"
 169         }
 170         $storage->_query_end($line);
 171       }
 172     } elsif ( $filename =~ /^(.+)\.pl$/ ) {
 173       my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
 174
 175       no warnings 'redefine';
 176       my $fn = eval "$filedata";
 177       use warnings;
 178
 179                 if ($@) {
 180         carp "$filename failed to compile: $@";
 181                 } elsif (ref $fn eq 'CODE') {
 182         $fn->($self->schema)
 183       } else {
 184         carp "$filename should define an anonymouse sub that takes a schema but it didn't!";
 185       }
 186     } else {
 187       croak "A file ($filename) got to deploy that wasn't sql or perl!";
 188     }
 189   }
 190
 191   $guard->commit if $self->txn_wrap;
 192
 193   return $sql;
 194 }
 195
 196 sub deploy {
 197   my $self = shift;
 198   my $version = shift || $self->schema_version;
 199
 200   return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
 201     $self->storage->sqlt_type,
 202     $version,
 203   ));
 204 }
 205
 206 sub preinstall_scripts {
 207   my $self = shift;
 208   my $version = shift || $self->schema_version;
 209
 210   my @files = @{$self->_ddl_preinstall_consume_filenames(
 211     $self->storage->sqlt_type,
 212     $version,
 213   )};
 214
 215   for my $filename (@files) {
 216     # We ignore sql for now (till I figure out what to do with it)
 217     if ( $filename =~ /^(.+)\.pl$/ ) {
 218       my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
 219
 220                 no warnings 'redefine';
 221       my $fn = eval "$filedata";
 222       use warnings;
 223
 224                 if ($@) {
 225         carp "$filename failed to compile: $@";
 226                 } elsif (ref $fn eq 'CODE') {
 227         $fn->()
 228       } else {
 229         carp "$filename should define an anonymous sub but it didn't!";
 230       }
 231     } else {
 232       croak "A file ($filename) got to preinstall_scripts that wasn't sql or perl!";
 233     }
 234   }
 235 }
 236
 237 sub _prepare_install {
 238   my $self      = shift;
 239   my $sqltargs  = { %{$self->sql_translator_args}, %{shift @_} };
 240   my $to_file   = shift;
 241   my $schema    = $self->schema;
 242   my $databases = $self->databases;
 243   my $dir       = $self->upgrade_directory;
 244   my $version   = $self->schema_version;
 245
 246   my $sqlt = SQL::Translator->new({
 247     add_drop_table          => 1,
 248     ignore_constraint_names => 1,
 249     ignore_index_names      => 1,
 250     parser                  => 'SQL::Translator::Parser::DBIx::Class',
 251     %{$sqltargs}
 252   });
 253
 254   my $sqlt_schema = $sqlt->translate( data => $schema )
 255     or croak($sqlt->error);
 256
 257   foreach my $db (@$databases) {
 258     $sqlt->reset;
 259     $sqlt->{schema} = $sqlt_schema;
 260     $sqlt->producer($db);
 261
 262     my $filename = $self->$to_file($db, $version, $dir);
 263     if (-e $filename ) {
 264       carp "Overwriting existing DDL file - $filename";
 265       unlink $filename;
 266     }
 267
 268     my $output = $sqlt->translate;
 269     if(!$output) {
 270       carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
 271       next;
 272     }
 273     open my $file, q(>), $filename;
 274     print {$file} $output;
 275     close $file;
 276   }
 277 }
 278
 279 sub _resultsource_install_filename {
 280   my ($self, $source_name) = @_;
 281   return sub {
 282     my ($self, $type, $version) = @_;
 283     my $dirname = catfile( $self->upgrade_directory, $type, 'schema', $version );
 284     mkpath($dirname) unless -d $dirname;
 285
 286     return catfile( $dirname, "001-auto-$source_name.sql" );
 287   }
 288 }
 289
 290 sub install_resultsource {
 291   my ($self, $source, $version) = @_;
 292
 293   my $rs_install_file =
 294     $self->_resultsource_install_filename($source->source_name);
 295
 296   my $files = [
 297      $self->$rs_install_file(
 298       $self->storage->sqlt_type,
 299       $version,
 300     )
 301   ];
 302   $self->_run_sql_and_perl($files);
 303 }
 304
 305 sub prepare_resultsource_install {
 306   my $self = shift;
 307   my $source = shift;
 308
 309   my $filename = $self->_resultsource_install_filename($source->source_name);
 310   $self->_prepare_install({
 311       parser_args => { sources => [$source->source_name], }
 312     }, $filename);
 313 }
 314
 315 sub prepare_deploy {
 316   my $self = shift;
 317   $self->_prepare_install({}, '_ddl_schema_produce_filename');
 318 }
 319
 320 sub prepare_upgrade {
 321   my ($self, $from_version, $to_version, $version_set) = @_;
 322   $self->_prepare_changegrade($from_version, $to_version, $version_set, 'up');
 323 }
 324
 325 sub prepare_downgrade {
 326   my ($self, $from_version, $to_version, $version_set) = @_;
 327
 328   $self->_prepare_changegrade($from_version, $to_version, $version_set, 'down');
 329 }
 330
 331 method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
 332   my $schema    = $self->schema;
 333   my $databases = $self->databases;
 334   my $dir       = $self->upgrade_directory;
 335   my $sqltargs  = $self->sql_translator_args;
 336
 337   my $schema_version = $self->schema_version;
 338
 339   $sqltargs = {
 340     add_drop_table => 1,
 341     ignore_constraint_names => 1,
 342     ignore_index_names => 1,
 343     %{$sqltargs}
 344   };
 345
 346   my $sqlt = SQL::Translator->new( $sqltargs );
 347
 348   $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
 349   my $sqlt_schema = $sqlt->translate( data => $schema )
 350     or croak($sqlt->error);
 351
 352   foreach my $db (@$databases) {
 353     $sqlt->reset;
 354     $sqlt->{schema} = $sqlt_schema;
 355     $sqlt->producer($db);
 356
 357     my $prefilename = $self->_ddl_schema_produce_filename($db, $from_version, $dir);
 358     unless(-e $prefilename) {
 359       carp("No previous schema file found ($prefilename)");
 360       next;
 361     }
 362     my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
 363     my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
 364     if(-e $diff_file) {
 365       carp("Overwriting existing $direction-diff file - $diff_file");
 366       unlink $diff_file;
 367     }
 368
 369     my $source_schema;
 370     {
 371       my $t = SQL::Translator->new({
 372          %{$sqltargs},
 373          debug => 0,
 374          trace => 0,
 375       });
 376
 377       $t->parser( $db ) # could this really throw an exception?
 378         or croak($t->error);
 379
 380       my $out = $t->translate( $prefilename )
 381         or croak($t->error);
 382
 383       $source_schema = $t->schema;
 384
 385       $source_schema->name( $prefilename )
 386         unless  $source_schema->name;
 387     }
 388
 389     # The "new" style of producers have sane normalization and can support
 390     # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
 391     # And we have to diff parsed SQL against parsed SQL.
 392     my $dest_schema = $sqlt_schema;
 393
 394     unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
 395       my $t = SQL::Translator->new({
 396          %{$sqltargs},
 397          debug => 0,
 398          trace => 0,
 399       });
 400
 401       $t->parser( $db ) # could this really throw an exception?
 402         or croak($t->error);
 403
 404       my $filename = $self->_ddl_schema_produce_filename($db, $to_version, $dir);
 405       my $out = $t->translate( $filename )
 406         or croak($t->error);
 407
 408       $dest_schema = $t->schema;
 409
 410       $dest_schema->name( $filename )
 411         unless $dest_schema->name;
 412     }
 413
 414     my $diff = SQL::Translator::Diff::schema_diff(
 415        $source_schema, $db,
 416        $dest_schema,   $db,
 417        $sqltargs
 418     );
 419     open my $file, q(>), $diff_file;
 420     print {$file} $diff;
 421     close $file;
 422   }
 423 }
 424
 425 method _read_sql_file($file) {
 426   return unless $file;
 427
 428   open my $fh, '<', $file;
 429   my @data = split /;\n/, join '', <$fh>;
 430   close $fh;
 431
 432   @data = grep {
 433     $_ && # remove blank lines
 434     !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
 435   } map {
 436     s/^\s+//; s/\s+$//; # trim whitespace
 437     join '', grep { !/^--/ } split /\n/ # remove comments
 438   } @data;
 439
 440   return \@data;
 441 }
 442
 443 sub downgrade_single_step {
 444   my $self = shift;
 445   my $version_set = shift @_;
 446
 447   my $sql = $self->_run_sql_and_perl($self->_ddl_schema_down_consume_filenames(
 448     $self->storage->sqlt_type,
 449     $version_set,
 450   ));
 451
 452   return ['', $sql];
 453 }
 454
 455 sub upgrade_single_step {
 456   my $self = shift;
 457   my $version_set = shift @_;
 458
 459   my $sql = $self->_run_sql_and_perl($self->_ddl_schema_up_consume_filenames(
 460     $self->storage->sqlt_type,
 461     $version_set,
 462   ));
 463   return ['', $sql];
 464 }
 465
 466 __PACKAGE__->meta->make_immutable;
 467
 468 1;
 469
 470 # vim: ts=2 sw=2 expandtab
 471
 472 __END__
 473
 474 =head1 DESCRIPTION
 475
 476 This class is the meat of L<DBIx::Class::DeploymentHandler>.  It takes care of
 477 generating sql files representing schemata as well as sql files to move from
 478 one version of a schema to the rest.  One of the hallmark features of this
 479 class is that it allows for multiple sql files for deploy and upgrade, allowing
 480 developers to fine tune deployment.  In addition it also allows for perl files
 481 to be run at any stage of the process.
 482
 483 For basic usage see L<DBIx::Class::DeploymentHandler::HandlesDeploy>.  What's
 484 documented here is extra fun stuff or private methods.
 485
 486 =head1 DIRECTORY LAYOUT
 487
 488 Arguably this is the best feature of L<DBIx::Class::DeploymentHandler>.  It's
 489 heavily based upon L<DBIx::Migration::Directories>, but has some extensions and
 490 modifications, so even if you are familiar with it, please read this.  I feel
 491 like the best way to describe the layout is with the following example:
 492
 493  $sql_migration_dir
 494  |- SQLite
 495  |  |- down
 496  |  |  `- 1-2
 497  |  |     `- 001-auto.sql
 498  |  |- schema
 499  |  |  `- 1
 500  |  |     `- 001-auto.sql
 501  |  `- up
 502  |     |- 1-2
 503  |     |  `- 001-auto.sql
 504  |     `- 2-3
 505  |        `- 001-auto.sql
 506  |- _common
 507  |  |- down
 508  |  |  `- 1-2
 509  |  |     `- 002-remove-customers.pl
 510  |  `- up
 511  |     `- 1-2
 512  |        `- 002-generate-customers.pl
 513  |- _generic
 514  |  |- down
 515  |  |  `- 1-2
 516  |  |     `- 001-auto.sql
 517  |  |- schema
 518  |  |  `- 1
 519  |  |     `- 001-auto.sql
 520  |  `- up
 521  |     `- 1-2
 522  |        |- 001-auto.sql
 523  |        `- 002-create-stored-procedures.sql
 524  `- MySQL
 525     |- down
 526     |  `- 1-2
 527     |     `- 001-auto.sql
 528     |- schema
 529     |  `- 1
 530     |     `- 001-auto.sql
 531     `- up
 532        `- 1-2
 533           `- 001-auto.sql
 534
 535 So basically, the code
 536
 537  $dm->deploy(1)
 538
 539 on an C<SQLite> database that would simply run
 540 C<$sql_migration_dir/SQLite/schema/1/001-auto.sql>.  Next,
 541
 542  $dm->upgrade_single_step([1,2])
 543
 544 would run C<$sql_migration_dir/SQLite/up/1-2/001-auto.sql> followed by
 545 C<$sql_migration_dir/_common/up/1-2/002-generate-customers.pl>.
 546
 547 Now, a C<.pl> file doesn't have to be in the C<_common> directory, but most of
 548 the time it probably should be, since perl scripts will mostly be database
 549 independent.
 550
 551 C<_generic> exists for when you for some reason are sure that your SQL is
 552 generic enough to run on all databases.  Good luck with that one.
 553
 554 =head1 PERL SCRIPTS
 555
 556 A perl script for this tool is very simple.  It merely needs to contain a
 557 sub called C<run> that takes a L<DBIx::Class::Schema> as it's only argument.
 558 A very basic perl script might look like:
 559
 560  #!perl
 561
 562  use strict;
 563  use warnings;
 564
 565  sub run {
 566    my $schema = shift;
 567
 568    $schema->resultset('Users')->create({
 569      name => 'root',
 570      password => 'root',
 571    })
 572  }
 573
 574 =attr schema
 575
 576 The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database
 577 and generate the DDL.
 578
 579 =attr storage
 580
 581 The L<DBIx::Class::Storage> that is I<actually> used to talk to the database
 582 and generate the DDL.  This is automatically created with L</_build_storage>.
 583
 584 =attr sql_translator_args
 585
 586 The arguments that get passed to L<SQL::Translator> when it's used.
 587
 588 =attr upgrade_directory
 589
 590 The directory (default C<'sql'>) that upgrades are stored in
 591
 592 =attr databases
 593
 594 The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
 595 generate files for
 596
 597 =attr txn_wrap
 598
 599 Set to true (which is the default) to wrap all upgrades and deploys in a single
 600 transaction.
 601
 602 =attr schema_version
 603
 604 The version the schema on your harddrive is at.  Defaults to
 605 C<< $self->schema->schema_version >>.
 606
 607 =method __ddl_consume_with_prefix
 608
 609  $dm->__ddl_consume_with_prefix( 'SQLite', [qw( 1.00 1.01 )], 'up' )
 610
 611 This is the meat of the multi-file upgrade/deploy stuff.  It returns a list of
 612 files in the order that they should be run for a generic "type" of upgrade.
 613 You should not be calling this in user code.
 614
 615 =method _ddl_schema_consume_filenames
 616
 617  $dm->__ddl_schema_consume_filenames( 'SQLite', [qw( 1.00 )] )
 618
 619 Just a curried L</__ddl_consume_with_prefix>.  Get's a list of files for an
 620 initial deploy.
 621
 622 =method _ddl_schema_produce_filename
 623
 624  $dm->__ddl_schema_produce_filename( 'SQLite', [qw( 1.00 )] )
 625
 626 Returns a single file in which an initial schema will be stored.
 627
 628 =method _ddl_schema_up_consume_filenames
 629
 630  $dm->_ddl_schema_up_consume_filenames( 'SQLite', [qw( 1.00 )] )
 631
 632 Just a curried L</__ddl_consume_with_prefix>.  Get's a list of files for an
 633 upgrade.
 634
 635 =method _ddl_schema_down_consume_filenames
 636
 637  $dm->_ddl_schema_down_consume_filenames( 'SQLite', [qw( 1.00 )] )
 638
 639 Just a curried L</__ddl_consume_with_prefix>.  Get's a list of files for a
 640 downgrade.
 641
 642 =method _ddl_schema_up_produce_filenames
 643
 644  $dm->_ddl_schema_up_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
 645
 646 Returns a single file in which the sql to upgrade from one schema to another
 647 will be stored.
 648
 649 =method _ddl_schema_down_produce_filename
 650
 651  $dm->_ddl_schema_down_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
 652
 653 Returns a single file in which the sql to downgrade from one schema to another
 654 will be stored.
 655
 656 =method _resultsource_install_filename
 657
 658  my $filename_fn = $dm->_resultsource_install_filename('User');
 659  $dm->$filename_fn('SQLite', '1.00')
 660
 661 Returns a function which in turn returns a single filename used to install a
 662 single resultsource.  Weird interface is convenient for me.  Deal with it.
 663
 664 =method _run_sql_and_perl
 665
 666  $dm->_run_sql_and_perl([qw( list of filenames )])
 667
 668 Simply put, this runs the list of files passed to it.  If the file ends in
 669 C<.sql> it runs it as sql and if it ends in C<.pl> it runs it as a perl file.
 670
 671 Depending on L</txn_wrap> all of the files run will be wrapped in a single
 672 transaction.
 673
 674 =method _prepare_install
 675
 676  $dm->_prepare_install({ add_drop_table => 0 }, sub { 'file_to_create' })
 677
 678 Generates the sql file for installing the database.  First arg is simply
 679 L<SQL::Translator> args and the second is a coderef that returns the filename
 680 to store the sql in.
 681
 682 =method _prepare_changegrade
 683
 684  $dm->_prepare_changegrade('1.00', '1.01', [qw( 1.00 1.01)], 'up')
 685
 686 Generates the sql file for migrating from one schema version to another.  First
 687 arg is the version to start from, second is the version to go to, third is the
 688 L<version set|DBIx::Class::DeploymentHandler/VERSION SET>, and last is the
 689 direction of the changegrade, be it 'up' or 'down'.
 690
 691 =method _read_sql_file
 692
 693  $dm->_read_sql_file('foo.sql')
 694
 695 Reads a sql file and returns lines in an C<ArrayRef>.  Strips out comments,
 696 transactions, and blank lines.
 697