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 sqltargs => (
  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->sqltargs}, %{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->sqltargs;
 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 sqltargs
 549
 550 TODO
 551 # rename
 552
 553 =attr upgrade_directory
 554
 555 The directory (default C<'sql'>) that upgrades are stored in
 556
 557 =attr databases
 558
 559 The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
 560 generate files for
 561
 562 =attr txn_wrap
 563
 564 Set to true (which is the default) to wrap all upgrades and deploys in a single
 565 transaction.
 566
 567 =attr schema_version
 568
 569 The version the schema on your harddrive is at.  Defaults to
 570 C<< $self->schema->schema_version >>.
 571
 572 =method __ddl_consume_with_prefix
 573
 574  $dm->__ddl_consume_with_prefix( 'SQLite', [qw( 1.00 1.01 )], 'up' )
 575
 576 This is the meat of the multi-file upgrade/deploy stuff.  It returns a list of
 577 files in the order that they should be run for a generic "type" of upgrade.
 578 You should not be calling this in user code.
 579
 580 =method _ddl_schema_consume_filenames
 581
 582  $dm->__ddl_schema_consume_filenames( 'SQLite', [qw( 1.00 )] )
 583
 584 Just a curried L</__ddl_consume_with_prefix>.  Get's a list of files for an
 585 initial deploy.
 586
 587 =method _ddl_schema_produce_filename
 588
 589  $dm->__ddl_schema_produce_filename( 'SQLite', [qw( 1.00 )] )
 590
 591 Returns a single file in which an initial schema will be stored.
 592
 593 =method _ddl_schema_up_consume_filenames
 594
 595  $dm->_ddl_schema_up_consume_filenames( 'SQLite', [qw( 1.00 )] )
 596
 597 Just a curried L</__ddl_consume_with_prefix>.  Get's a list of files for an
 598 upgrade.
 599
 600 =method _ddl_schema_down_consume_filenames
 601
 602  $dm->_ddl_schema_down_consume_filenames( 'SQLite', [qw( 1.00 )] )
 603
 604 Just a curried L</__ddl_consume_with_prefix>.  Get's a list of files for a
 605 downgrade.
 606
 607 =method _ddl_schema_up_produce_filenames
 608
 609  $dm->_ddl_schema_up_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
 610
 611 Returns a single file in which the sql to upgrade from one schema to another
 612 will be stored.
 613
 614 =method _ddl_schema_down_produce_filename
 615
 616  $dm->_ddl_schema_down_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
 617
 618 Returns a single file in which the sql to downgrade from one schema to another
 619 will be stored.
 620
 621 =method _resultsource_install_filename
 622
 623  my $filename_fn = $dm->_resultsource_install_filename('User');
 624  $dm->$filename_fn('SQLite', '1.00')
 625
 626 Returns a function which in turn returns a single filename used to install a
 627 single resultsource.  Weird interface is convenient for me.  Deal with it.
 628
 629 =method _run_sql_and_perl
 630
 631  $dm->_run_sql_and_perl([qw( list of filenames )])
 632
 633 Simply put, this runs the list of files passed to it.  If the file ends in
 634 C<.sql> it runs it as sql and if it ends in C<.pl> it runs it as a perl file.
 635
 636 Depending on L</txn_wrap> all of the files run will be wrapped in a single
 637 transaction.
 638
 639 =method _prepare_install
 640
 641  $dm->_prepare_install({ add_drop_table => 0 }, sub { 'file_to_create' })
 642
 643 Generates the sql file for installing the database.  First arg is simply
 644 L<SQL::Translator> args and the second is a coderef that returns the filename
 645 to store the sql in.
 646
 647 =method _prepare_changegrade
 648
 649  $dm->_prepare_changegrade('1.00', '1.01', [qw( 1.00 1.01)], 'up')
 650
 651 Generates the sql file for migrating from one schema version to another.  First
 652 arg is the version to start from, second is the version to go to, third is the
 653 L<version set|DBIx::Class::DeploymentHandler/VERSION SET>, and last is the
 654 direction of the changegrade, be it 'up' or 'down'.
 655
 656 =method _read_sql_file
 657
 658  $dm->_read_sql_file('foo.sql')
 659
 660 Reads a sql file and returns lines in an C<ArrayRef>.  Strips out comments,
 661 transactions, and blank lines.
 662