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

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