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