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