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

   1 package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator;
   2 use Moose;
   3 use Method::Signatures::Simple;
   4 use Try::Tiny;
   5 use SQL::Translator;
   6 require SQL::Translator::Diff;
   7 require DBIx::Class::Storage;   # loaded for type constraint
   8 use autodie;
   9 use File::Path;
  10
  11 with 'DBIx::Class::DeploymentHandler::HandlesDeploy';
  12
  13 use Carp 'carp';
  14
  15 has schema => (
  16   isa      => 'DBIx::Class::Schema',
  17   is       => 'ro',
  18   required => 1,
  19   handles => [qw( schema_version )],
  20 );
  21
  22 has storage => (
  23   isa        => 'DBIx::Class::Storage',
  24   is         => 'ro',
  25   lazy_build => 1,
  26 );
  27
  28 method _build_storage {
  29   my $s = $self->schema->storage;
  30   $s->_determine_driver;
  31   $s
  32 }
  33
  34 has sqltargs => (
  35   isa => 'HashRef',
  36   is  => 'ro',
  37   default => sub { {} },
  38 );
  39 has upgrade_directory => (
  40   isa      => 'Str',
  41   is       => 'ro',
  42   required => 1,
  43   default  => 'sql',
  44 );
  45
  46 has databases => (
  47   coerce  => 1,
  48   isa     => 'DBIx::Class::DeploymentHandler::Databases',
  49   is      => 'ro',
  50   default => sub { [qw( MySQL SQLite PostgreSQL )] },
  51 );
  52
  53 has _filedata => (
  54   isa => 'ArrayRef[Str]',
  55   is  => 'rw',
  56 );
  57
  58 method __ddl_consume_with_prefix($type, $versions, $prefix) {
  59   my $base_dir = $self->upgrade_directory;
  60
  61   my $main    = File::Spec->catfile( $base_dir, $type                         );
  62   my $generic = File::Spec->catfile( $base_dir, '_generic'                    );
  63   my $common =  File::Spec->catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );
  64
  65   my $dir;
  66   if (-d $main) {
  67     $dir = File::Spec->catfile($main, $prefix, join q(-), @{$versions})
  68   } elsif (-d $generic) {
  69     $dir = File::Spec->catfile($main, $prefix, join q(-), @{$versions})
  70   } else {
  71     die 'PREPARE TO SQL'
  72   }
  73
  74   opendir my($dh), $dir;
  75   my %files = map { $_ => "$dir/$_" } grep { /\.sql$/ && -f "$dir/$_" } readdir($dh);
  76   closedir $dh;
  77
  78   if (-d $common) {
  79     opendir my($dh), $common;
  80     for my $filename (grep { /\.sql$/ && -f "$common/$_" } readdir($dh)) {
  81       unless ($files{$filename}) {
  82         $files{$filename} = "$common/$_";
  83       }
  84     }
  85     closedir $dh;
  86   }
  87
  88   return [@files{sort keys %files}]
  89 }
  90
  91 method _ddl_schema_consume_filenames($type, $version) {
  92   $self->__ddl_consume_with_prefix($type, [ $version ], 'schema')
  93 }
  94
  95 method _ddl_schema_produce_filename($type, $version) {
  96   my $base_dir = $self->upgrade_directory;
  97   my $dirname = File::Spec->catfile(
  98     $base_dir, $type, 'schema', $version
  99   );
 100   File::Path::mkpath($dirname) unless -d $dirname;
 101
 102   return File::Spec->catfile(
 103     $dirname, '001-auto.sql'
 104   );
 105 }
 106
 107 method _ddl_schema_up_consume_filenames($type, $versions) {
 108   $self->__ddl_consume_with_prefix($type, $versions, 'up')
 109 }
 110
 111 method _ddl_schema_down_consume_filenames($type, $versions) {
 112   $self->__ddl_consume_with_prefix($type, $versions, 'down')
 113 }
 114
 115 method _ddl_schema_up_produce_filename($type, $versions) {
 116   my $dir = $self->upgrade_directory;
 117
 118   my $dirname = File::Spec->catfile(
 119     $dir, $type, 'up', join( q(-), @{$versions} )
 120   );
 121   File::Path::mkpath($dirname) unless -d $dirname;
 122
 123   return File::Spec->catfile(
 124     $dirname, '001-auto.sql'
 125   );
 126 }
 127
 128 method _ddl_schema_down_produce_filename($type, $versions, $dir) {
 129   my $dirname = File::Spec->catfile(
 130     $dir, $type, 'down', join( q(-), @{$versions} )
 131   );
 132   File::Path::mkpath($dirname) unless -d $dirname;
 133
 134   return File::Spec->catfile(
 135     $dirname, '001-auto.sql'
 136   );
 137 }
 138
 139 method _deployment_statements {
 140   my $dir      = $self->upgrade_directory;
 141   my $schema   = $self->schema;
 142   my $type     = $self->storage->sqlt_type;
 143   my $sqltargs = $self->sqltargs;
 144   my $version  = $self->schema_version;
 145
 146   my @filenames = @{$self->_ddl_schema_consume_filenames($type, $version)};
 147
 148   for my $filename (@filenames) {
 149     if(-f $filename) {
 150         my $file;
 151         open $file, q(<), $filename
 152           or carp "Can't open $filename ($!)";
 153         my @rows = <$file>;
 154         close $file;
 155         return join '', @rows;
 156     }
 157   }
 158
 159   # sources needs to be a parser arg, but for simplicty allow at top level
 160   # coming in
 161   $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
 162       if exists $sqltargs->{sources};
 163
 164   my $tr = SQL::Translator->new(
 165     producer => "SQL::Translator::Producer::${type}",
 166     %$sqltargs,
 167     parser => 'SQL::Translator::Parser::DBIx::Class',
 168     data => $schema,
 169   );
 170
 171   my $ret = $tr->translate;
 172
 173   $schema->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
 174     unless defined $ret;
 175
 176   return $ret;
 177 }
 178
 179 sub _deploy {
 180   my $self = shift;
 181   my $storage  = $self->storage;
 182
 183 #< frew> k, also, we filter out comments and transaction stuff and blank lines
 184 #< frew> is that really necesary?
 185 #< frew> and what if I want to run my upgrade in a txn?  seems like something you'd
 186 #        always want to do really
 187 #< ribasushi> again - some stuff chokes
 188 #< frew> ok, so I see filtering out -- and \s*
 189 #< frew> but I think the txn filtering should be optional and default to NOT filter it
 190 #        out
 191 #< ribasushi> then you have a problem
 192 #< frew> tell me
 193 #< ribasushi> someone runs a deploy in txn_do
 194 #< ribasushi> the inner begin will blow up
 195 #< frew> because it's a nested TXN?
 196 #< ribasushi> (you an't begin twice on most dbs)
 197 #< ribasushi> right
 198 #< ribasushi> on sqlite - for sure
 199 #< frew> so...read the docs and set txn_filter to true?
 200 #< ribasushi> more like wrap deploy in a txn
 201 #< frew> I like that better
 202 #< ribasushi> and make sure the ddl has no literal txns in them
 203 #< frew> sure
 204 #< ribasushi> this way you have stuff under control
 205 #< frew> so we have txn_wrap default to true
 206 #< frew> and if people wanna do that by hand they can
 207   my $sql = $self->_deployment_statements();
 208   foreach my $line ( split(/;\n/, $sql)) {
 209     $line = join '', grep { !/^--/ } split /\n/, $line;
 210     next if !$line || $line =~ /^BEGIN TRANSACTION|^COMMIT|^\s+$/;
 211     $storage->_query_start($line);
 212     try {
 213       # do a dbh_do cycle here, as we need some error checking in
 214       # place (even though we will ignore errors)
 215       $storage->dbh_do (sub { $_[1]->do($line) });
 216     }
 217     catch {
 218       carp "$_ (running '${line}')"
 219     }
 220     $storage->_query_end($line);
 221   }
 222 }
 223
 224 sub prepare_install {
 225   my $self = shift;
 226   my $schema    = $self->schema;
 227   my $databases = $self->databases;
 228   my $dir       = $self->upgrade_directory;
 229   my $sqltargs  = $self->sqltargs;
 230   my $version = $schema->schema_version;
 231
 232   unless( -d $dir ) {
 233     carp "Upgrade directory $dir does not exist, using ./\n";
 234     $dir = './';
 235   }
 236
 237
 238   my $sqlt = SQL::Translator->new({
 239     add_drop_table          => 1,
 240     ignore_constraint_names => 1,
 241     ignore_index_names      => 1,
 242     parser                  => 'SQL::Translator::Parser::DBIx::Class',
 243     %{$sqltargs || {}}
 244   });
 245
 246   my $sqlt_schema = $sqlt->translate({ data => $schema })
 247     or $self->throw_exception ($sqlt->error);
 248
 249   foreach my $db (@$databases) {
 250     $sqlt->reset;
 251     $sqlt->{schema} = $sqlt_schema;
 252     $sqlt->producer($db);
 253
 254     my $filename = $self->_ddl_schema_produce_filename($db, $version, $dir);
 255     if (-e $filename ) {
 256       carp "Overwriting existing DDL file - $filename";
 257       unlink $filename;
 258     }
 259
 260     my $output = $sqlt->translate;
 261     if(!$output) {
 262       carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
 263       next;
 264     }
 265     my $file;
 266     unless( open $file, q(>), $filename ) {
 267       $self->throw_exception("Can't open $filename for writing ($!)");
 268       next;
 269     }
 270     print {$file} $output;
 271     close $file;
 272   }
 273 }
 274
 275 sub prepare_upgrade {
 276   my ($self, $from_version, $to_version, $version_set) = @_;
 277
 278   $from_version ||= $self->db_version;
 279   $to_version   ||= $self->schema_version;
 280
 281   # for updates prepared automatically (rob's stuff)
 282   # one would want to explicitly set $version_set to
 283   # [$to_version]
 284   $version_set  ||= [$from_version, $to_version];
 285
 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   $from_version ||= $self->db_version;
 293   $to_version   ||= $self->schema_version;
 294
 295   # for updates prepared automatically (rob's stuff)
 296   # one would want to explicitly set $version_set to
 297   # [$to_version]
 298   $version_set  ||= [$from_version, $to_version];
 299
 300   $self->_prepare_changegrade($from_version, $to_version, $version_set, 'down');
 301 }
 302
 303 method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
 304   my $schema    = $self->schema;
 305   my $databases = $self->databases;
 306   my $dir       = $self->upgrade_directory;
 307   my $sqltargs  = $self->sqltargs;
 308
 309   my $schema_version = $schema->schema_version;
 310
 311   $sqltargs = {
 312     add_drop_table => 1,
 313     ignore_constraint_names => 1,
 314     ignore_index_names => 1,
 315     %{$sqltargs}
 316   };
 317
 318   my $sqlt = SQL::Translator->new( $sqltargs );
 319
 320   $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
 321   my $sqlt_schema = $sqlt->translate({ data => $schema })
 322     or $self->throw_exception ($sqlt->error);
 323
 324   foreach my $db (@$databases) {
 325     $sqlt->reset;
 326     $sqlt->{schema} = $sqlt_schema;
 327     $sqlt->producer($db);
 328
 329     my $prefilename = $self->_ddl_schema_produce_filename($db, $from_version, $dir);
 330     unless(-e $prefilename) {
 331       carp("No previous schema file found ($prefilename)");
 332       next;
 333     }
 334     my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
 335     my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
 336     if(-e $diff_file) {
 337       carp("Overwriting existing $direction-diff file - $diff_file");
 338       unlink $diff_file;
 339     }
 340
 341     my $source_schema;
 342     {
 343       my $t = SQL::Translator->new({
 344          %{$sqltargs},
 345          debug => 0,
 346          trace => 0,
 347       });
 348
 349       $t->parser( $db ) # could this really throw an exception?
 350         or $self->throw_exception ($t->error);
 351
 352       my $out = $t->translate( $prefilename )
 353         or $self->throw_exception ($t->error);
 354
 355       $source_schema = $t->schema;
 356
 357       $source_schema->name( $prefilename )
 358         unless  $source_schema->name;
 359     }
 360
 361     # The "new" style of producers have sane normalization and can support
 362     # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
 363     # And we have to diff parsed SQL against parsed SQL.
 364     my $dest_schema = $sqlt_schema;
 365
 366     unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
 367       my $t = SQL::Translator->new({
 368          %{$sqltargs},
 369          debug => 0,
 370          trace => 0,
 371       });
 372
 373       $t->parser( $db ) # could this really throw an exception?
 374         or $self->throw_exception ($t->error);
 375
 376       my $filename = $self->_ddl_schema_produce_filename($db, $to_version, $dir);
 377       my $out = $t->translate( $filename )
 378         or $self->throw_exception ($t->error);
 379
 380       $dest_schema = $t->schema;
 381
 382       $dest_schema->name( $filename )
 383         unless $dest_schema->name;
 384     }
 385
 386     my $diff = SQL::Translator::Diff::schema_diff(
 387        $source_schema, $db,
 388        $dest_schema,   $db,
 389        $sqltargs
 390     );
 391     my $file;
 392     unless(open $file, q(>), $diff_file) {
 393       $self->throw_exception("Can't write to $diff_file ($!)");
 394       next;
 395     }
 396     print {$file} $diff;
 397     close $file;
 398   }
 399 }
 400
 401 method _read_sql_file($file) {
 402   return unless $file;
 403
 404   open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)");
 405   my @data = split /\n/, join '', <$fh>;
 406   close $fh;
 407
 408   @data = grep {
 409     $_ &&
 410     !/^--/ &&
 411     !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/m
 412   } split /;/,
 413     join '', @data;
 414
 415   return \@data;
 416 }
 417
 418 # these are exactly the same for now
 419 sub _downgrade_single_step {
 420   my $self = shift;
 421   my @version_set = @{ shift @_ };
 422   my @upgrade_files = @{$self->_ddl_schema_up_consume_filenames(
 423     $self->storage->sqlt_type,
 424     \@version_set,
 425   )};
 426
 427   for my $upgrade_file (@upgrade_files) {
 428     unless (-f $upgrade_file) {
 429       # croak?
 430       carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
 431       return;
 432     }
 433
 434     $self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22
 435     $self->schema->txn_do(sub { $self->_do_upgrade });
 436   }
 437 }
 438
 439 sub _upgrade_single_step {
 440   my $self = shift;
 441   my @version_set = @{ shift @_ };
 442   my @upgrade_files = @{$self->_ddl_schema_up_consume_filenames(
 443     $self->storage->sqlt_type,
 444     \@version_set,
 445   )};
 446
 447   for my $upgrade_file (@upgrade_files) {
 448     unless (-f $upgrade_file) {
 449       # croak?
 450       carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
 451       return;
 452     }
 453
 454     $self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22
 455     $self->schema->txn_do(sub { $self->_do_upgrade });
 456   }
 457 }
 458
 459 method _do_upgrade { $self->_run_upgrade(qr/.*?/) }
 460
 461 method _run_upgrade($stm) {
 462   return unless $self->_filedata;
 463   my @statements = grep { $_ =~ $stm } @{$self->_filedata};
 464
 465   for (@statements) {
 466     $self->storage->debugobj->query_start($_) if $self->storage->debug;
 467     $self->_apply_statement($_);
 468     $self->storage->debugobj->query_end($_) if $self->storage->debug;
 469   }
 470 }
 471
 472 method _apply_statement($statement) {
 473   # croak?
 474   $self->storage->dbh->do($_) or carp "SQL was: $_"
 475 }
 476
 477 1;
 478
 479 __END__
 480
 481 vim: ts=2 sw=2 expandtab