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 @_ || {})->{version} || $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 $args         = shift;
 209   my $version      = $args->{version}      || $self->schema_version;
 210   my $storage_type = $args->{storage_type} || $self->storage->sqlt_type;
 211
 212   my @files = @{$self->_ddl_preinstall_consume_filenames(
 213     $storage_type,
 214     $version,
 215   )};
 216
 217   for my $filename (@files) {
 218     # We ignore sql for now (till I figure out what to do with it)
 219     if ( $filename =~ /^(.+)\.pl$/ ) {
 220       my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
 221
 222       no warnings 'redefine';
 223       my $fn = eval "$filedata";
 224       use warnings;
 225
 226       if ($@) {
 227         carp "$filename failed to compile: $@";
 228       } elsif (ref $fn eq 'CODE') {
 229         $fn->()
 230       } else {
 231         carp "$filename should define an anonymous sub but it didn't!";
 232       }
 233     } else {
 234       croak "A file ($filename) got to preinstall_scripts that wasn't sql or perl!";
 235     }
 236   }
 237 }
 238
 239 sub _prepare_install {
 240   my $self      = shift;
 241   my $sqltargs  = { %{$self->sql_translator_args}, %{shift @_} };
 242   my $to_file   = shift;
 243   my $schema    = $self->schema;
 244   my $databases = $self->databases;
 245   my $dir       = $self->upgrade_directory;
 246   my $version   = $self->schema_version;
 247
 248   my $sqlt = SQL::Translator->new({
 249     add_drop_table          => 1,
 250     ignore_constraint_names => 1,
 251     ignore_index_names      => 1,
 252     parser                  => 'SQL::Translator::Parser::DBIx::Class',
 253     %{$sqltargs}
 254   });
 255
 256   my $sqlt_schema = $sqlt->translate( data => $schema )
 257     or croak($sqlt->error);
 258
 259   foreach my $db (@$databases) {
 260     $sqlt->reset;
 261     $sqlt->{schema} = $sqlt_schema;
 262     $sqlt->producer($db);
 263
 264     my $filename = $self->$to_file($db, $version, $dir);
 265     if (-e $filename ) {
 266       carp "Overwriting existing DDL file - $filename";
 267       unlink $filename;
 268     }
 269
 270     my $output = $sqlt->translate;
 271     if(!$output) {
 272       carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
 273       next;
 274     }
 275     open my $file, q(>), $filename;
 276     print {$file} $output;
 277     close $file;
 278   }
 279 }
 280
 281 sub _resultsource_install_filename {
 282   my ($self, $source_name) = @_;
 283   return sub {
 284     my ($self, $type, $version) = @_;
 285     my $dirname = catfile( $self->upgrade_directory, $type, 'schema', $version );
 286     mkpath($dirname) unless -d $dirname;
 287
 288     return catfile( $dirname, "001-auto-$source_name.sql" );
 289   }
 290 }
 291
 292 sub install_resultsource {
 293   my ($self, $args) = @_;
 294   my $source          = $args->{result_source};
 295   my $version         = $args->{version};
 296   my $rs_install_file =
 297     $self->_resultsource_install_filename($source->source_name);
 298
 299   my $files = [
 300      $self->$rs_install_file(
 301       $self->storage->sqlt_type,
 302       $version,
 303     )
 304   ];
 305   $self->_run_sql_and_perl($files);
 306 }
 307
 308 sub prepare_resultsource_install {
 309   my $self = shift;
 310   my $source = (shift @_)->{result_source};
 311
 312   my $filename = $self->_resultsource_install_filename($source->source_name);
 313   $self->_prepare_install({
 314       parser_args => { sources => [$source->source_name], }
 315     }, $filename);
 316 }
 317
 318 sub prepare_deploy {
 319   my $self = shift;
 320   $self->_prepare_install({}, '_ddl_schema_produce_filename');
 321 }
 322
 323 sub prepare_upgrade {
 324   my ($self, $args) = @_;
 325   $self->_prepare_changegrade(
 326     $args->{from_version}, $args->{to_version}, $args->{version_set}, 'up'
 327   );
 328 }
 329
 330 sub prepare_downgrade {
 331   my ($self, $args) = @_;
 332   $self->_prepare_changegrade(
 333     $args->{from_version}, $args->{to_version}, $args->{version_set}, 'down'
 334   );
 335 }
 336
 337 method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
 338   my $schema    = $self->schema;
 339   my $databases = $self->databases;
 340   my $dir       = $self->upgrade_directory;
 341   my $sqltargs  = $self->sql_translator_args;
 342
 343   my $schema_version = $self->schema_version;
 344
 345   $sqltargs = {
 346     add_drop_table => 1,
 347     ignore_constraint_names => 1,
 348     ignore_index_names => 1,
 349     %{$sqltargs}
 350   };
 351
 352   my $sqlt = SQL::Translator->new( $sqltargs );
 353
 354   $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
 355   my $sqlt_schema = $sqlt->translate( data => $schema )
 356     or croak($sqlt->error);
 357
 358   foreach my $db (@$databases) {
 359     $sqlt->reset;
 360     $sqlt->{schema} = $sqlt_schema;
 361     $sqlt->producer($db);
 362
 363     my $prefilename = $self->_ddl_schema_produce_filename($db, $from_version, $dir);
 364     unless(-e $prefilename) {
 365       carp("No previous schema file found ($prefilename)");
 366       next;
 367     }
 368     my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
 369     my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
 370     if(-e $diff_file) {
 371       carp("Overwriting existing $direction-diff file - $diff_file");
 372       unlink $diff_file;
 373     }
 374
 375     my $source_schema;
 376     {
 377       my $t = SQL::Translator->new({
 378          %{$sqltargs},
 379          debug => 0,
 380          trace => 0,
 381       });
 382
 383       $t->parser( $db ) # could this really throw an exception?
 384         or croak($t->error);
 385
 386       my $out = $t->translate( $prefilename )
 387         or croak($t->error);
 388
 389       $source_schema = $t->schema;
 390
 391       $source_schema->name( $prefilename )
 392         unless  $source_schema->name;
 393     }
 394
 395     # The "new" style of producers have sane normalization and can support
 396     # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
 397     # And we have to diff parsed SQL against parsed SQL.
 398     my $dest_schema = $sqlt_schema;
 399
 400     unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
 401       my $t = SQL::Translator->new({
 402          %{$sqltargs},
 403          debug => 0,
 404          trace => 0,
 405       });
 406
 407       $t->parser( $db ) # could this really throw an exception?
 408         or croak($t->error);
 409
 410       my $filename = $self->_ddl_schema_produce_filename($db, $to_version, $dir);
 411       my $out = $t->translate( $filename )
 412         or croak($t->error);
 413
 414       $dest_schema = $t->schema;
 415
 416       $dest_schema->name( $filename )
 417         unless $dest_schema->name;
 418     }
 419
 420     my $diff = SQL::Translator::Diff::schema_diff(
 421        $source_schema, $db,
 422        $dest_schema,   $db,
 423        $sqltargs
 424     );
 425     open my $file, q(>), $diff_file;
 426     print {$file} $diff;
 427     close $file;
 428   }
 429 }
 430
 431 method _read_sql_file($file) {
 432   return unless $file;
 433
 434   open my $fh, '<', $file;
 435   my @data = split /;\n/, join '', <$fh>;
 436   close $fh;
 437
 438   @data = grep {
 439     $_ && # remove blank lines
 440     !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
 441   } map {
 442     s/^\s+//; s/\s+$//; # trim whitespace
 443     join '', grep { !/^--/ } split /\n/ # remove comments
 444   } @data;
 445
 446   return \@data;
 447 }
 448
 449 sub downgrade_single_step {
 450   my $self = shift;
 451   my $version_set = (shift @_)->{version_set};
 452
 453   my $sql = $self->_run_sql_and_perl($self->_ddl_schema_down_consume_filenames(
 454     $self->storage->sqlt_type,
 455     $version_set,
 456   ));
 457
 458   return ['', $sql];
 459 }
 460
 461 sub upgrade_single_step {
 462   my $self = shift;
 463   my $version_set = (shift @_)->{version_set};
 464
 465   my $sql = $self->_run_sql_and_perl($self->_ddl_schema_up_consume_filenames(
 466     $self->storage->sqlt_type,
 467     $version_set,
 468   ));
 469   return ['', $sql];
 470 }
 471
 472 __PACKAGE__->meta->make_immutable;
 473
 474 1;
 475
 476 # vim: ts=2 sw=2 expandtab
 477
 478 __END__
 479
 480 =head1 DESCRIPTION
 481
 482 This class is the meat of L<DBIx::Class::DeploymentHandler>.  It takes care of
 483 generating sql files representing schemata as well as sql files to move from
 484 one version of a schema to the rest.  One of the hallmark features of this
 485 class is that it allows for multiple sql files for deploy and upgrade, allowing
 486 developers to fine tune deployment.  In addition it also allows for perl files
 487 to be run at any stage of the process.
 488
 489 For basic usage see L<DBIx::Class::DeploymentHandler::HandlesDeploy>.  What's
 490 documented here is extra fun stuff or private methods.
 491
 492 =head1 DIRECTORY LAYOUT
 493
 494 Arguably this is the best feature of L<DBIx::Class::DeploymentHandler>.  It's
 495 heavily based upon L<DBIx::Migration::Directories>, but has some extensions and
 496 modifications, so even if you are familiar with it, please read this.  I feel
 497 like the best way to describe the layout is with the following example:
 498
 499  $sql_migration_dir
 500  |- SQLite
 501  |  |- down
 502  |  |  `- 2-1
 503  |  |     `- 001-auto.sql
 504  |  |- schema
 505  |  |  `- 1
 506  |  |     `- 001-auto.sql
 507  |  `- up
 508  |     |- 1-2
 509  |     |  `- 001-auto.sql
 510  |     `- 2-3
 511  |        `- 001-auto.sql
 512  |- _common
 513  |  |- down
 514  |  |  `- 2-1
 515  |  |     `- 002-remove-customers.pl
 516  |  `- up
 517  |     `- 1-2
 518  |        `- 002-generate-customers.pl
 519  |- _generic
 520  |  |- down
 521  |  |  `- 2-1
 522  |  |     `- 001-auto.sql
 523  |  |- schema
 524  |  |  `- 1
 525  |  |     `- 001-auto.sql
 526  |  `- up
 527  |     `- 1-2
 528  |        |- 001-auto.sql
 529  |        `- 002-create-stored-procedures.sql
 530  `- MySQL
 531     |- down
 532     |  `- 2-1
 533     |     `- 001-auto.sql
 534     |- preinstall
 535     |  `- 1
 536     |     |- 001-create_database.pl
 537     |     `- 002-create_users_and_permissions.pl
 538     |- schema
 539     |  `- 1
 540     |     `- 001-auto.sql
 541     `- up
 542        `- 1-2
 543           `- 001-auto.sql
 544
 545 So basically, the code
 546
 547  $dm->deploy(1)
 548
 549 on an C<SQLite> database that would simply run
 550 C<$sql_migration_dir/SQLite/schema/1/001-auto.sql>.  Next,
 551
 552  $dm->upgrade_single_step([1,2])
 553
 554 would run C<$sql_migration_dir/SQLite/up/1-2/001-auto.sql> followed by
 555 C<$sql_migration_dir/_common/up/1-2/002-generate-customers.pl>.
 556
 557 Now, a C<.pl> file doesn't have to be in the C<_common> directory, but most of
 558 the time it probably should be, since perl scripts will mostly be database
 559 independent.
 560
 561 C<_generic> exists for when you for some reason are sure that your SQL is
 562 generic enough to run on all databases.  Good luck with that one.
 563
 564 Note that unlike most steps in the process, C<preinstall> will not run SQL, as
 565 there may not even be an database at preinstall time.  It will run perl scripts
 566 just like the other steps in the process, but nothing is passed to them.
 567 Until people have used this more it will remain freeform, but a recommended use
 568 of preinstall is to have it prompt for username and password, and then call the
 569 appropriate C<< CREATE DATABASE >> commands etc.
 570
 571 =head1 PERL SCRIPTS
 572
 573 A perl script for this tool is very simple.  It merely needs to contain an
 574 anonymous sub that takes a L<DBIx::Class::Schema> as it's only argument.
 575 A very basic perl script might look like:
 576
 577  #!perl
 578
 579  use strict;
 580  use warnings;
 581
 582  sub {
 583    my $schema = shift;
 584
 585    $schema->resultset('Users')->create({
 586      name => 'root',
 587      password => 'root',
 588    })
 589  }
 590
 591 =attr schema
 592
 593 The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database
 594 and generate the DDL.
 595
 596 =attr storage
 597
 598 The L<DBIx::Class::Storage> that is I<actually> used to talk to the database
 599 and generate the DDL.  This is automatically created with L</_build_storage>.
 600
 601 =attr sql_translator_args
 602
 603 The arguments that get passed to L<SQL::Translator> when it's used.
 604
 605 =attr upgrade_directory
 606
 607 The directory (default C<'sql'>) that upgrades are stored in
 608
 609 =attr databases
 610
 611 The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
 612 generate files for
 613
 614 =attr txn_wrap
 615
 616 Set to true (which is the default) to wrap all upgrades and deploys in a single
 617 transaction.
 618
 619 =attr schema_version
 620
 621 The version the schema on your harddrive is at.  Defaults to
 622 C<< $self->schema->schema_version >>.
 623
 624 =method __ddl_consume_with_prefix
 625
 626  $dm->__ddl_consume_with_prefix( 'SQLite', [qw( 1.00 1.01 )], 'up' )
 627
 628 This is the meat of the multi-file upgrade/deploy stuff.  It returns a list of
 629 files in the order that they should be run for a generic "type" of upgrade.
 630 You should not be calling this in user code.
 631
 632 =method _ddl_schema_consume_filenames
 633
 634  $dm->__ddl_schema_consume_filenames( 'SQLite', [qw( 1.00 )] )
 635
 636 Just a curried L</__ddl_consume_with_prefix>.  Get's a list of files for an
 637 initial deploy.
 638
 639 =method _ddl_schema_produce_filename
 640
 641  $dm->__ddl_schema_produce_filename( 'SQLite', [qw( 1.00 )] )
 642
 643 Returns a single file in which an initial schema will be stored.
 644
 645 =method _ddl_schema_up_consume_filenames
 646
 647  $dm->_ddl_schema_up_consume_filenames( 'SQLite', [qw( 1.00 )] )
 648
 649 Just a curried L</__ddl_consume_with_prefix>.  Get's a list of files for an
 650 upgrade.
 651
 652 =method _ddl_schema_down_consume_filenames
 653
 654  $dm->_ddl_schema_down_consume_filenames( 'SQLite', [qw( 1.00 )] )
 655
 656 Just a curried L</__ddl_consume_with_prefix>.  Get's a list of files for a
 657 downgrade.
 658
 659 =method _ddl_schema_up_produce_filenames
 660
 661  $dm->_ddl_schema_up_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
 662
 663 Returns a single file in which the sql to upgrade from one schema to another
 664 will be stored.
 665
 666 =method _ddl_schema_down_produce_filename
 667
 668  $dm->_ddl_schema_down_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
 669
 670 Returns a single file in which the sql to downgrade from one schema to another
 671 will be stored.
 672
 673 =method _resultsource_install_filename
 674
 675  my $filename_fn = $dm->_resultsource_install_filename('User');
 676  $dm->$filename_fn('SQLite', '1.00')
 677
 678 Returns a function which in turn returns a single filename used to install a
 679 single resultsource.  Weird interface is convenient for me.  Deal with it.
 680
 681 =method _run_sql_and_perl
 682
 683  $dm->_run_sql_and_perl([qw( list of filenames )])
 684
 685 Simply put, this runs the list of files passed to it.  If the file ends in
 686 C<.sql> it runs it as sql and if it ends in C<.pl> it runs it as a perl file.
 687
 688 Depending on L</txn_wrap> all of the files run will be wrapped in a single
 689 transaction.
 690
 691 =method _prepare_install
 692
 693  $dm->_prepare_install({ add_drop_table => 0 }, sub { 'file_to_create' })
 694
 695 Generates the sql file for installing the database.  First arg is simply
 696 L<SQL::Translator> args and the second is a coderef that returns the filename
 697 to store the sql in.
 698
 699 =method _prepare_changegrade
 700
 701  $dm->_prepare_changegrade('1.00', '1.01', [qw( 1.00 1.01)], 'up')
 702
 703 Generates the sql file for migrating from one schema version to another.  First
 704 arg is the version to start from, second is the version to go to, third is the
 705 L<version set|DBIx::Class::DeploymentHandler/VERSION SET>, and last is the
 706 direction of the changegrade, be it 'up' or 'down'.
 707
 708 =method _read_sql_file
 709
 710  $dm->_read_sql_file('foo.sql')
 711
 712 Reads a sql file and returns lines in an C<ArrayRef>.  Strips out comments,
 713 transactions, and blank lines.
 714