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