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