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
 188   return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
 189     $self->storage->sqlt_type,
 190     $self->schema_version
 191   ));
 192 }
 193
 194 sub _prepare_install {
 195   my $self = shift;
 196   my $sqltargs  = { %{$self->sqltargs}, %{shift @_} };
 197   my $to_file   = shift;
 198   my $schema    = $self->schema;
 199   my $databases = $self->databases;
 200   my $dir       = $self->upgrade_directory;
 201   my $version = $schema->schema_version;
 202
 203   my $sqlt = SQL::Translator->new({
 204     add_drop_table          => 1,
 205     ignore_constraint_names => 1,
 206     ignore_index_names      => 1,
 207     parser                  => 'SQL::Translator::Parser::DBIx::Class',
 208     %{$sqltargs}
 209   });
 210
 211   my $sqlt_schema = $sqlt->translate( data => $schema )
 212     or croak($sqlt->error);
 213
 214   foreach my $db (@$databases) {
 215     $sqlt->reset;
 216     $sqlt->{schema} = $sqlt_schema;
 217     $sqlt->producer($db);
 218
 219     my $filename = $self->$to_file($db, $version, $dir);
 220     if (-e $filename ) {
 221       carp "Overwriting existing DDL file - $filename";
 222       unlink $filename;
 223     }
 224
 225     my $output = $sqlt->translate;
 226     if(!$output) {
 227       carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
 228       next;
 229     }
 230     open my $file, q(>), $filename;
 231     print {$file} $output;
 232     close $file;
 233   }
 234 }
 235
 236 sub _resultsource_install_filename {
 237   my ($self, $source_name) = @_;
 238   return sub {
 239     my ($self, $type, $version) = @_;
 240     my $dirname = catfile( $self->upgrade_directory, $type, 'schema', $version );
 241     mkpath($dirname) unless -d $dirname;
 242
 243     return catfile( $dirname, "001-auto-$source_name.sql" );
 244   }
 245 }
 246
 247 sub install_resultsource {
 248   my ($self, $source, $version) = @_;
 249
 250   my $rs_install_file =
 251     $self->_resultsource_install_filename($source->source_name);
 252
 253   my $files = [
 254      $self->$rs_install_file(
 255       $self->storage->sqlt_type,
 256       $version,
 257     )
 258   ];
 259   $self->_run_sql_and_perl($files);
 260 }
 261
 262 sub prepare_resultsource_install {
 263   my $self = shift;
 264   my $source = shift;
 265
 266   my $filename = $self->_resultsource_install_filename($source->source_name);
 267   $self->_prepare_install({
 268       parser_args => { sources => [$source->source_name], }
 269     }, $filename);
 270 }
 271
 272 sub prepare_install {
 273   my $self = shift;
 274   $self->_prepare_install({}, '_ddl_schema_produce_filename');
 275 }
 276
 277 sub prepare_upgrade {
 278   my ($self, $from_version, $to_version, $version_set) = @_;
 279   $self->_prepare_changegrade($from_version, $to_version, $version_set, 'up');
 280 }
 281
 282 sub prepare_downgrade {
 283   my ($self, $from_version, $to_version, $version_set) = @_;
 284
 285   $self->_prepare_changegrade($from_version, $to_version, $version_set, 'down');
 286 }
 287
 288 method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
 289   my $schema    = $self->schema;
 290   my $databases = $self->databases;
 291   my $dir       = $self->upgrade_directory;
 292   my $sqltargs  = $self->sqltargs;
 293
 294   my $schema_version = $schema->schema_version;
 295
 296   $sqltargs = {
 297     add_drop_table => 1,
 298     ignore_constraint_names => 1,
 299     ignore_index_names => 1,
 300     %{$sqltargs}
 301   };
 302
 303   my $sqlt = SQL::Translator->new( $sqltargs );
 304
 305   $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
 306   my $sqlt_schema = $sqlt->translate( data => $schema )
 307     or croak($sqlt->error);
 308
 309   foreach my $db (@$databases) {
 310     $sqlt->reset;
 311     $sqlt->{schema} = $sqlt_schema;
 312     $sqlt->producer($db);
 313
 314     my $prefilename = $self->_ddl_schema_produce_filename($db, $from_version, $dir);
 315     unless(-e $prefilename) {
 316       carp("No previous schema file found ($prefilename)");
 317       next;
 318     }
 319     my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
 320     my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
 321     if(-e $diff_file) {
 322       carp("Overwriting existing $direction-diff file - $diff_file");
 323       unlink $diff_file;
 324     }
 325
 326     my $source_schema;
 327     {
 328       my $t = SQL::Translator->new({
 329          %{$sqltargs},
 330          debug => 0,
 331          trace => 0,
 332       });
 333
 334       $t->parser( $db ) # could this really throw an exception?
 335         or croak($t->error);
 336
 337       my $out = $t->translate( $prefilename )
 338         or croak($t->error);
 339
 340       $source_schema = $t->schema;
 341
 342       $source_schema->name( $prefilename )
 343         unless  $source_schema->name;
 344     }
 345
 346     # The "new" style of producers have sane normalization and can support
 347     # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
 348     # And we have to diff parsed SQL against parsed SQL.
 349     my $dest_schema = $sqlt_schema;
 350
 351     unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
 352       my $t = SQL::Translator->new({
 353          %{$sqltargs},
 354          debug => 0,
 355          trace => 0,
 356       });
 357
 358       $t->parser( $db ) # could this really throw an exception?
 359         or croak($t->error);
 360
 361       my $filename = $self->_ddl_schema_produce_filename($db, $to_version, $dir);
 362       my $out = $t->translate( $filename )
 363         or croak($t->error);
 364
 365       $dest_schema = $t->schema;
 366
 367       $dest_schema->name( $filename )
 368         unless $dest_schema->name;
 369     }
 370
 371     my $diff = SQL::Translator::Diff::schema_diff(
 372        $source_schema, $db,
 373        $dest_schema,   $db,
 374        $sqltargs
 375     );
 376     open my $file, q(>), $diff_file;
 377     print {$file} $diff;
 378     close $file;
 379   }
 380 }
 381
 382 method _read_sql_file($file) {
 383   return unless $file;
 384
 385   open my $fh, '<', $file;
 386   my @data = split /;\n/, join '', <$fh>;
 387   close $fh;
 388
 389   @data = grep {
 390     $_ && # remove blank lines
 391     !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
 392   } map {
 393     s/^\s+//; s/\s+$//; # trim whitespace
 394     join '', grep { !/^--/ } split /\n/ # remove comments
 395   } @data;
 396
 397   return \@data;
 398 }
 399
 400 sub downgrade_single_step {
 401   my $self = shift;
 402   my $version_set = shift @_;
 403
 404   my $sql = $self->_run_sql_and_perl($self->_ddl_schema_down_consume_filenames(
 405     $self->storage->sqlt_type,
 406     $version_set,
 407   ));
 408
 409   return ['', $sql];
 410 }
 411
 412 sub upgrade_single_step {
 413   my $self = shift;
 414   my $version_set = shift @_;
 415
 416   my $sql = $self->_run_sql_and_perl($self->_ddl_schema_up_consume_filenames(
 417     $self->storage->sqlt_type,
 418     $version_set,
 419   ));
 420   return ['', $sql];
 421 }
 422
 423 __PACKAGE__->meta->make_immutable;
 424
 425 1;
 426
 427 # vim: ts=2 sw=2 expandtab
 428
 429 __END__
 430
 431 =head1 DESCRIPTION
 432
 433 This class is the meat of L<DBIx::Class::DeploymentHandler>.  It takes care of
 434 generating sql files representing schemata as well as sql files to move from
 435 one version of a schema to the rest.  One of the hallmark features of this
 436 class is that it allows for multiple sql files for deploy and upgrade, allowing
 437 developers to fine tune deployment.  In addition it also allows for perl files
 438 to be run at any stage of the process.
 439
 440 For basic usage see L<DBIx::Class::DeploymentHandler::HandlesDeploy>.  What's
 441 documented here is extra fun stuff or private methods.
 442
 443 =head1 DIRECTORY LAYOUT
 444
 445 It's heavily based upon L<DBIx::Migration::Directories>.
 446
 447 =attr schema
 448
 449 The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database
 450 and generate the DDL.
 451
 452 =attr storage
 453
 454 The L<DBIx::Class::Storage> that is I<actually> used to talk to the database
 455 and generate the DDL.  This is automatically created with L</_build_storage>.
 456
 457 =attr sqltargs
 458
 459 #rename
 460
 461 =attr upgrade_directory
 462
 463 The directory (default C<'sql'>) that upgrades are stored in
 464
 465 =attr databases
 466
 467 The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
 468 generate files for
 469
 470 =attr txn_wrap
 471
 472 Set to true (which is the default) to wrap all upgrades and deploys in a single
 473 transaction.
 474
 475 =method __ddl_consume_with_prefix
 476
 477  $dm->__ddl_consume_with_prefix( 'SQLite', [qw( 1.00 1.01 )], 'up' )
 478
 479 This is the meat of the multi-file upgrade/deploy stuff.  It returns a list of
 480 files in the order that they should be run for a generic "type" of upgrade.
 481 You should not be calling this in user code.
 482
 483 =method _ddl_schema_consume_filenames
 484
 485  $dm->__ddl_schema_consume_filenames( 'SQLite', [qw( 1.00 )] )
 486
 487 Just a curried L</__ddl_consume_with_prefix>.  Get's a list of files for an
 488 initial deploy.
 489
 490 =method _ddl_schema_produce_filename
 491
 492  $dm->__ddl_schema_produce_filename( 'SQLite', [qw( 1.00 )] )
 493
 494 Returns a single file in which an initial schema will be stored.
 495
 496 =method _ddl_schema_up_consume_filenames
 497
 498  $dm->_ddl_schema_up_consume_filenames( 'SQLite', [qw( 1.00 )] )
 499
 500 Just a curried L</__ddl_consume_with_prefix>.  Get's a list of files for an
 501 upgrade.
 502
 503 =method _ddl_schema_down_consume_filenames
 504
 505  $dm->_ddl_schema_down_consume_filenames( 'SQLite', [qw( 1.00 )] )
 506
 507 Just a curried L</__ddl_consume_with_prefix>.  Get's a list of files for a
 508 downgrade.
 509
 510 =method _ddl_schema_up_produce_filenames
 511
 512  $dm->_ddl_schema_up_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
 513
 514 Returns a single file in which the sql to upgrade from one schema to another
 515 will be stored.
 516
 517 =method _ddl_schema_down_produce_filename
 518
 519  $dm->_ddl_schema_down_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
 520
 521 Returns a single file in which the sql to downgrade from one schema to another
 522 will be stored.
 523
 524 =method _resultsource_install_filename
 525
 526  my $filename_fn = $dm->_resultsource_install_filename('User');
 527  $dm->$filename_fn('SQLite', '1.00')
 528
 529 Returns a function which in turn returns a single filename used to install a
 530 single resultsource.  Weird interface is convenient for me.  Deal with it.
 531
 532 =method _run_sql_and_perl
 533
 534  $dm->_run_sql_and_perl([qw( list of filenames )])
 535
 536 Simply put, this runs the list of files passed to it.  If the file ends in
 537 C<.sql> it runs it as sql and if it ends in C<.pl> it runs it as a perl file.
 538
 539 Depending on L</txn_wrap> all of the files run will be wrapped in a single
 540 transaction.
 541
 542 =method _prepare_install
 543
 544  $dm->_prepare_install({ add_drop_table => 0 }, sub { 'file_to_create' })
 545
 546 Generates the sql file for installing the database.  First arg is simply
 547 L<SQL::Translator> args and the second is a coderef that returns the filename
 548 to store the sql in.
 549
 550 =method _prepare_changegrade
 551
 552  $dm->_prepare_changegrade('1.00', '1.01', [qw( 1.00 1.01)], 'up')
 553
 554 Generates the sql file for migrating from one schema version to another.  First
 555 arg is the version to start from, second is the version to go to, third is the
 556 L<version set|DBIx::Class::DeploymentHandler/VERSION SET>, and last is the
 557 direction of the changegrade, be it 'up' or 'down'.
 558
 559 =method _read_sql_file
 560
 561  $dm->_read_sql_file('foo.sql')
 562
 563 Reads a sql file and returns lines in an C<ArrayRef>.  Strips out comments,
 564 transactions, and blank lines.
 565