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 {
 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  |  |  `- 2-1
 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  |  |  `- 2-1
 509  |  |     `- 002-remove-customers.pl
 510  |  `- up
 511  |     `- 1-2
 512  |        `- 002-generate-customers.pl
 513  |- _generic
 514  |  |- down
 515  |  |  `- 2-1
 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     |  `- 2-1
 527     |     `- 001-auto.sql
 528     |- preinstall
 529     |  `- 1
 530     |     |- 001-create_database.pl
 531     |     `- 002-create_users_and_permissions.pl
 532     |- schema
 533     |  `- 1
 534     |     `- 001-auto.sql
 535     `- up
 536        `- 1-2
 537           `- 001-auto.sql
 538
 539 So basically, the code
 540
 541  $dm->deploy(1)
 542
 543 on an C<SQLite> database that would simply run
 544 C<$sql_migration_dir/SQLite/schema/1/001-auto.sql>.  Next,
 545
 546  $dm->upgrade_single_step([1,2])
 547
 548 would run C<$sql_migration_dir/SQLite/up/1-2/001-auto.sql> followed by
 549 C<$sql_migration_dir/_common/up/1-2/002-generate-customers.pl>.
 550
 551 Now, a C<.pl> file doesn't have to be in the C<_common> directory, but most of
 552 the time it probably should be, since perl scripts will mostly be database
 553 independent.
 554
 555 C<_generic> exists for when you for some reason are sure that your SQL is
 556 generic enough to run on all databases.  Good luck with that one.
 557
 558 Note that unlike most steps in the process, C<preinstall> will not run SQL, as
 559 there may not even be an database at preinstall time.  It will run perl scripts
 560 just like the other steps in the process, but nothing is passed to them.
 561 Until people have used this more it will remain freeform, but a recommended use
 562 of preinstall is to have it prompt for username and password, and then call the
 563 appropriate C<< CREATE DATABASE >> commands etc.
 564
 565 =head1 PERL SCRIPTS
 566
 567 A perl script for this tool is very simple.  It merely needs to contain an
 568 anonymous sub that takes a L<DBIx::Class::Schema> as it's only argument.
 569 A very basic perl script might look like:
 570
 571  #!perl
 572
 573  use strict;
 574  use warnings;
 575
 576  sub {
 577    my $schema = shift;
 578
 579    $schema->resultset('Users')->create({
 580      name => 'root',
 581      password => 'root',
 582    })
 583  }
 584
 585 =attr schema
 586
 587 The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database
 588 and generate the DDL.
 589
 590 =attr storage
 591
 592 The L<DBIx::Class::Storage> that is I<actually> used to talk to the database
 593 and generate the DDL.  This is automatically created with L</_build_storage>.
 594
 595 =attr sql_translator_args
 596
 597 The arguments that get passed to L<SQL::Translator> when it's used.
 598
 599 =attr upgrade_directory
 600
 601 The directory (default C<'sql'>) that upgrades are stored in
 602
 603 =attr databases
 604
 605 The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
 606 generate files for
 607
 608 =attr txn_wrap
 609
 610 Set to true (which is the default) to wrap all upgrades and deploys in a single
 611 transaction.
 612
 613 =attr schema_version
 614
 615 The version the schema on your harddrive is at.  Defaults to
 616 C<< $self->schema->schema_version >>.
 617
 618 =method __ddl_consume_with_prefix
 619
 620  $dm->__ddl_consume_with_prefix( 'SQLite', [qw( 1.00 1.01 )], 'up' )
 621
 622 This is the meat of the multi-file upgrade/deploy stuff.  It returns a list of
 623 files in the order that they should be run for a generic "type" of upgrade.
 624 You should not be calling this in user code.
 625
 626 =method _ddl_schema_consume_filenames
 627
 628  $dm->__ddl_schema_consume_filenames( 'SQLite', [qw( 1.00 )] )
 629
 630 Just a curried L</__ddl_consume_with_prefix>.  Get's a list of files for an
 631 initial deploy.
 632
 633 =method _ddl_schema_produce_filename
 634
 635  $dm->__ddl_schema_produce_filename( 'SQLite', [qw( 1.00 )] )
 636
 637 Returns a single file in which an initial schema will be stored.
 638
 639 =method _ddl_schema_up_consume_filenames
 640
 641  $dm->_ddl_schema_up_consume_filenames( 'SQLite', [qw( 1.00 )] )
 642
 643 Just a curried L</__ddl_consume_with_prefix>.  Get's a list of files for an
 644 upgrade.
 645
 646 =method _ddl_schema_down_consume_filenames
 647
 648  $dm->_ddl_schema_down_consume_filenames( 'SQLite', [qw( 1.00 )] )
 649
 650 Just a curried L</__ddl_consume_with_prefix>.  Get's a list of files for a
 651 downgrade.
 652
 653 =method _ddl_schema_up_produce_filenames
 654
 655  $dm->_ddl_schema_up_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
 656
 657 Returns a single file in which the sql to upgrade from one schema to another
 658 will be stored.
 659
 660 =method _ddl_schema_down_produce_filename
 661
 662  $dm->_ddl_schema_down_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
 663
 664 Returns a single file in which the sql to downgrade from one schema to another
 665 will be stored.
 666
 667 =method _resultsource_install_filename
 668
 669  my $filename_fn = $dm->_resultsource_install_filename('User');
 670  $dm->$filename_fn('SQLite', '1.00')
 671
 672 Returns a function which in turn returns a single filename used to install a
 673 single resultsource.  Weird interface is convenient for me.  Deal with it.
 674
 675 =method _run_sql_and_perl
 676
 677  $dm->_run_sql_and_perl([qw( list of filenames )])
 678
 679 Simply put, this runs the list of files passed to it.  If the file ends in
 680 C<.sql> it runs it as sql and if it ends in C<.pl> it runs it as a perl file.
 681
 682 Depending on L</txn_wrap> all of the files run will be wrapped in a single
 683 transaction.
 684
 685 =method _prepare_install
 686
 687  $dm->_prepare_install({ add_drop_table => 0 }, sub { 'file_to_create' })
 688
 689 Generates the sql file for installing the database.  First arg is simply
 690 L<SQL::Translator> args and the second is a coderef that returns the filename
 691 to store the sql in.
 692
 693 =method _prepare_changegrade
 694
 695  $dm->_prepare_changegrade('1.00', '1.01', [qw( 1.00 1.01)], 'up')
 696
 697 Generates the sql file for migrating from one schema version to another.  First
 698 arg is the version to start from, second is the version to go to, third is the
 699 L<version set|DBIx::Class::DeploymentHandler/VERSION SET>, and last is the
 700 direction of the changegrade, be it 'up' or 'down'.
 701
 702 =method _read_sql_file
 703
 704  $dm->_read_sql_file('foo.sql')
 705
 706 Reads a sql file and returns lines in an C<ArrayRef>.  Strips out comments,
 707 transactions, and blank lines.
 708